;;;; moremacros.scm  -*- Hen -*-
;;;; Kon Lovett, Aug '10

(module moremacros

(;export
  (str# $conc$)
  ->boolean
  assure
  whennot
  type-case type-case*
  swap-set!
  fluid-set!
  stiff-set!
  set!/op
  make-reference-let
  ;
  warning-guard
  checked-guard
  ;define-parameter
  define-warning-parameter
  define-checked-parameter
  ;must export helper macro, otherwise "hangs" during expansion of generated macro
  $grlaux$)

(import scheme chicken)

(import (only data-structures conc))

(import-for-syntax
  (only miscmacros repeat define-parameter))

;;; Helpers

; maybe a problem with expansion environment namespace pollution
(define-for-syntax (make-identifier . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

;;;

;; Expression templates

(define $conc$ conc)

(define-syntax str#
  (ir-macro-transformer
    (lambda (frm inj cmp)
      ; (str# "...#{...}...#---...")
      (let ((strp (open-input-string (cadr frm))))
        ; interpret w/ {} as ()
        (parameterize ((parentheses-synonyms #t))
          (let loop ((ls '()) (sl #f))
            ; output char
            (define (out-char ch)
              (if sl (cons ch sl) (list ch)) )
            ; end of interp
            (define (end-str)
              (if sl (cons (list->string (reverse sl)) ls) ls) )
            ; in the '#
            (define (sharp-body)
              (let ((ch (peek-char strp)))
                (cond
                  ((eof-object? ch)
                    (loop ls sl) )
                  ; dup so identity
                  ((char=? #\# ch)
                    (begin
                      (read-char strp) ;drop char
                      (loop ls (out-char #\#)) ) )
                  ; begin special eval region
                  ((char=? #\{ #;#\} ch)
                    (loop (cons (inj (car (read strp))) (end-str)) #f) )
                  ; end special eval region no matter what
                  ;!!! we do not test for #\} !!!
                  (else
                    (loop (cons (inj (read strp)) (end-str)) #f) ) ) ) )
            ; in the '# or not
            (let ((ch (read-char strp)))
              (cond
                ; were done
                ((eof-object? ch)
                  `($conc$ ,@(reverse (end-str))) )
                ; we're interpolating
                ((char=? #\# ch)
                  (sharp-body) )
                ; ordinary char
                (else
                  (loop ls (out-char ch)) ) ) ) ) ) ) ) ) )

;; Returns expression value or error

(define-syntax ->boolean
  (syntax-rules ()
    ((_ ?obj)
      (and ?obj
           #t) ) ) )

;; Returns expression value or error

(define-syntax assure
  (syntax-rules ()
    ((_ ?expr ?loc ?arg0 ...)
      (or ?expr
          (error ?loc ?arg0 ...)) ) ) )

;;

#;
(define-syntax reverse-literal-list
  (syntax-rules ()

    ((_)
      '() )

    ((_ ?elt)
      (list ?elt) )

    ((_ "aux" (?eltn ?eltn-1 ...))
      (list ?eltn ?eltn-1 ...) )

    ((_ "aux" (?elti-1 ?elti-2 ...) ?elti ?elti+1 ...)
      (reverse-literal-list "aux" (?elti ?elti-1 ?elti-2 ...) ?elti+1 ...) )

    ((_ ?elt0 ?elt1 ...)
      (reverse-literal-list "aux" (?elt0) ?elt1 ...) ) ) )

;; `Unless' synonym

(define-syntax whennot
  (syntax-rules ()
    ((_ ?condition ?body0 ...)
      (unless ?condition ?body0 ...) ) ) )

;;

(define-syntax ($type-case$ f r c)
  (let ((loc (cadr f))
        (?expr (caddr f))
        (?forms (cdddr f)) )
    (let ((var (if (c (r 'type-case*) loc) 'it (gensym))))
      (define (make-type-pred typnam)
        `(,(make-identifier typnam #\?) ,var))
      `(,(r 'let) ((,var ,?expr))
         (,(r 'cond)
           ,@(let loop ((forms ?forms)
                        (lst '()))
              (if (null? forms) (reverse lst)
                (let* ((tcase (car forms))
                       (typnam (car tcase))
                       (next (cdr forms)) )
                  (if (c (r 'else) typnam)
                    (if (null? next) (loop '() (cons (cons (r 'else) (cdr tcase)) lst))
                      (syntax-error loc "else form out of position" tcase) )
                    (loop (cdr forms)
                          (cons
                            (cons
                              (cond
                                ((symbol? typnam) (make-type-pred typnam) )
                                ((pair? typnam)   `(or ,@(map make-type-pred typnam)) )
                                (else
                                  (syntax-error loc "invalid case" tcase) ) )
                              (cdr tcase))
                            lst)) ) ) ) ) ) ) ) ) )

(define-syntax type-case
	(syntax-rules ()
		((_ ?expr (typ0 exp0 ...) ...)
      ($type-case$ type-case ?expr (typ0 exp0 ...) ...) ) ) )

(define-syntax type-case*
	(syntax-rules ()
		((_ ?expr (typ0 exp0 ...) ...)
      ($type-case$ type-case* ?expr (typ0 exp0 ...) ...) ) ) )

;; Exchange bindings of two variables

(define-syntax swap-set!
	(syntax-rules ()
		((_ ?a ?b)
      (let ((_tmp ?a))
       (set! ?a ?b)
       (set! ?b _tmp)) ) ) )

;; Parallel chained set

(define-syntax fluid-set!
	(syntax-rules ()

		((_ ?var ?val)
		  (set! ?var ?val) )

		((_ ?var ?val ?rest ...)
		  (let ((_tmp ?val))
		    (fluid-set! ?rest ...)
		    (set! ?var _tmp) ) ) ) )

;; Serial chained set (CL SETQ like)

(define-syntax stiff-set!
	(syntax-rules ()

		((_ ?var ?val)
		  (set! ?var ?val) )

		((_ ?var ?val ?rest ...)
		  (begin
		    (set! ?var ?val)
		    (stiff-set! ?rest ...) ) ) ) )

;; Assign the result of the operation on the variable to itself
;; Like C var <op>= <args>

#; ;too many ellipses: (?act1 ...)
(define-syntax set!/op
	(syntax-rules ()
		((_ ?var ?op ?rest ...)
      (letrec-syntax (
          ($build-call$
            (syntax-rules (<>)

              ((_ ?op ?var)
                (?op ?var) )

              ((_ "aux" (?var #f) (?op ?act0 ...))
                (?op ?var ?act0 ...) )

              ((_ "aux" (?var #t) (?op ?act0 ...))
                (?op ?act0 ...) )

              ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
                ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )

              ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
                ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )

              ((_ ?op ?var <> ?arg0 ...)
                ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )

              ((_ ?op ?var ?arg0 ?arg1 ...)
                ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) ) )
        ;
        (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) ) )

(define-syntax $build-call$
  (syntax-rules (<>)

    ((_ ?op ?var)
      (?op ?var) )

    ((_ "aux" (?var #f) (?op ?act0 ...))
      (?op ?var ?act0 ...) )

    ((_ "aux" (?var #t) (?op ?act0 ...))
      (?op ?act0 ...) )

    ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
      ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )

    ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
      ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )

    ((_ ?op ?var <> ?arg0 ...)
      ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )

    ((_ ?op ?var ?arg0 ?arg1 ...)
      ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) )

(define-syntax set!/op
	(syntax-rules ()
		((_ ?var ?op ?rest ...)
		  (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) )

;;

#; ;too many ellipses
(define-syntax make-reference-let
  (syntax-rules ()
    ((_ ?name ?ref)
      (letrec-syntax (
          ;
          ($grlaux$
            (syntax-rules ()

              ;finished
              ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
                ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )

              ;
              ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
                ($grlaux$ "gen" (?loc ?item ?ref ?body)
                  (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
                  (?tup0 ...)) )

              ;all binds finished, generate
              ((_ "chk" ?cache ?tups ())
                ($grlaux$ "gen" ?cache () () ?tups) )

              ;
              ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
                ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )

              ;
              ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
                ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )

              ;
              ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
                ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )

              ;
              ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
                ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )

              ;start
              ((_ ?cache ?bnds)
                ($grlaux$ "chk" ?cache () ?bnds) ) ) ) )
        ;
        (define-syntax ?name
          (syntax-rules ::: ()
            ((_ ?item ?binds ?body0 :::)
              ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) ) )

(define-syntax $grlaux$
  (syntax-rules ()

    ;finished
    ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
      ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )

    ;
    ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
      ($grlaux$ "gen" (?loc ?item ?ref ?body)
        (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
        (?tup0 ...)) )

    ;all binds finished, generate
    ((_ "chk" ?cache ?tups ())
      ($grlaux$ "gen" ?cache () () ?tups) )

    ;
    ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )

    ;
    ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )

    ;
    ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )

    ;
    ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )

    ;start
    ((_ ?cache ?bnds)
      ($grlaux$ "chk" ?cache () ?bnds) ) ) )

(define-syntax make-reference-let
  (syntax-rules ()
    ((_ ?name ?ref)
      (define-syntax ?name
        (syntax-rules ::: ()
          ((_ ?item ?binds ?body0 :::)
            ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) )

#;
(define-syntax make-reference-let
  (er-macro-transformer
    (lambda (f r c)
      (##sys#check-syntax 'make-reference-let f '(_ symbol _))
      (let ((?name (cadr f))
            (?ref (caddr f)) )
        `(,(r 'define-syntax) ,?name
          (,(r 'syntax-rules) ()
            ((_ ?item ?binds ?body0 ...)
              (,(r '$grlaux$) (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )

#;
(define-syntax make-reference-let
  (ir-macro-transformer
    (lambda (f i c)
      (##sys#check-syntax 'make-reference-let f '(_ symbol _))
        (let ((?name (cadr f))
              (?ref (caddr f)) )
          `(define-syntax ,?name
            (syntax-rules ()
              ((_ ?item ?binds ?body0 ...)
                ($grlaux$ (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )

;;

(define-syntax warning-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
      (let ((?getnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm))
            ;
            (_lambda (rnm 'lambda))
            (_if (rnm 'if))
            (_begin (rnm 'begin))
            (_warning-argument-type (rnm 'warning-argument-type)) )
        (let ((predname (make-identifier (symbol->string ?typnam) "?")))
          `(,_lambda (obj)
            (,_if (,predname obj)
              (,_begin ,@?body obj)
              (,_begin
                (,_warning-argument-type ',?getnam obj ',?typnam)
                (,?getnam) ) ) ) ) ) ) ) )

(define-syntax checked-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
      (let ((?locnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm))
            ;
            (_lambda (rnm 'lambda)) )
        (let ((chknam (make-identifier "check-" (symbol->string ?typnam))))
          `(,_lambda (obj)
            (,chknam ',?locnam obj)
            ,@?body
            obj ) ) ) ) ) )

;;

#; ;use miscmacros
(define-syntax define-parameter
  (syntax-rules ()
    ((_ ?name ?init) (define ?name (make-parameter ?init)) )
    ((_ ?name ?init ?guard) (define ?name (make-parameter ?init ?guard)) ) ) )

(define-syntax define-warning-parameter
  (syntax-rules ()
    ((_ ?name ?init ?typnam ?body0 ...)
      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )

(define-syntax define-checked-parameter
  (syntax-rules ()
    ((_ ?name ?init ?typnam ?body0 ...)
      (define-parameter ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )

) ;module moremacros