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

(module moremacros

  (;export
    ->boolean
    assure
    whennot
    type-case type-case*
    swap-set!
    fluid-set!
    stiff-set!
    set!/op
    make-reference-let)

  (import scheme chicken)

  (import-for-syntax
    (only miscmacros repeat)
    (only data-structures conc))

  (require-library type-checks type-errors)

;;; Helpers

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

;;;

;; 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 ?arg0 ?arg1 ...)
      (or ?expr
          (error ?arg0 ?arg1 ...)) ) ) )

;;

#;
(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>

; had a problem w/ `let-syntax' version of below:
; Error: during expansion of (syntax-rules ...) - too many ellipses: (?act1 ...)

(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 ...)) ) ) )

;;

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

    ;finished
    ((_ "gen" (?loc ?ref (?body ...)) (?var ...) (?exp ...) ())
      ((lambda (?var ...) ?body ...) ?exp ...) )

    ;binding for this table finished, switch to next set
    ((_ "gen" ?cache ?vars ?exps ((() ?table0) ?table-binding1 ...))
      ($grlaux "gen" ?cache ?vars ?exps (?table-binding1 ...)) )

    ;generate lambda binding & table reference expression for this table binding
    ((_ "gen" (?loc ?ref ?body) (?var0 ...) (?exp0 ...) ((((?var ?key ?def) ?binding1 ...) ?table0) ?table-binding1 ...))
      ($grlaux "gen" (?loc ?ref ?body)
        (?var ?var0 ...)
        ((?ref ?table0 ?key ?def) ?exp0 ...)
        (((?binding1 ...) ?table0) ?table-binding1 ...)) )

    ;all tables finished, generate
    ((_ "chk" ?cache ?checked ((() ?table0)))
      ($grlaux "gen" ?cache () () ?checked) )

    ;bindings for this table finished, switch to next set
    ((_ "chk" ?cache (?ckd0 ...) ((() ?table0) (?bindings1 ?table1) ?table-binding2 ...))
      ($grlaux "chk" ?cache
        ((() ?table1) ?ckd0 ...)
        ((?bindings1 ?table1) ?table-binding2 ...)) )

    ;(var) binding form for this table
    ((_ "chk" ?cache (((?0binding ...) ?0table) ?ckd0 ...) ((((?var0) ?binding0 ...) ?table0) ?table-binding1 ...))
      ($grlaux "chk" ?cache
        ((((?var0 '?var0 #f) ?0binding ...) ?0table) ?ckd0 ...)
        (((?binding0 ...) ?table0) ?table-binding1 ...)) )

    ;(var key) binding form for this table
    ((_ "chk" ?cache (((?0binding ...) ?0table) ?ckd0 ...) ((((?var0 ?key0) ?binding0 ...) ?table0) ?table-binding1 ...))
      ($grlaux "chk" ?cache
        ((((?var0 ?key0 #f) ?0binding ...) ?0table) ?ckd0 ...)
        (((?binding0 ...) ?table0) ?table-binding1 ...)) )

    ;(var key def) binding form for this table
    ((_ "chk" ?cache (((?0binding ...) ?0table) ?ckd0 ...) ((((?var0 ?key0 ?def0) ?binding0 ...) ?table0) ?table-binding1 ...))
      ($grlaux "chk" ?cache
        ((((?var0 ?key0 ?def0) ?0binding ...) ?0table) ?ckd0 ...)
        (((?binding0 ...) ?table0) ?table-binding1 ...)) )

    ; anything else is an error
    ((_ "chk" (?loc ?ref ?body) ?chkd ((((?var0 ?key0 ?def0 ?obj0 ...) ?binding0 ...) ?table0) ?table-binding1 ...))
      (syntax-error '?loc
        "invalid binding form" (list '?var0 '?key0 '?def0 '?obj0 ...)) )

    ;"naked" var binding form for this table
    ;must be here so does not match any `(...)' binding forms
    ((_ "chk" ?cache (((?0binding ...) ?0table) ?ckd0 ...) (((?var0 ?binding0 ...) ?table0) ?table-binding1 ...))
      ($grlaux "chk" ?cache
        ((((?var0 '?var0 #f) ?0binding ...) ?0table) ?ckd0 ...)
        (((?binding0 ...) ?table0) ?table-binding1 ...)) )

    ;start with the first set of table bindings
    ((_ "chk" ?cache () (((?binding0 ...) ?table0) ?table-binding1 ...))
      ($grlaux "chk" ?cache ((() ?table0)) (((?binding0 ...) ?table0) ?table-binding1 ...)) ) ) )

#;
(define-syntax make-reference-let
  (syntax-rules ()
    ((_ ?name ?ref)
      (define-syntax ?name
        (syntax-rules ()
          ((_ ?bindings ?body0 ...)
            ($grlaux "chk" (?name ?ref (?body ...)) () ?bindings)) ) ) ) ) )

(define-syntax (make-reference-let 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) ()
        ((_ ?bindings ?body ...)
          (,(r '$grlaux) "chk" (,?name ,?ref (?body ...)) () ?bindings)) ) ) ) )

#| ;this would be a waste of time since nested reference-let works fine
(make-reference-let NAME table-predicate table-reference ...)

(let ((_tbldef
        (lambda (tbl)
          (cond
            ((table-predicate tbl) table-reference)
            ... ) ) ) )
  ((lambda (a b c ...) ...)
    ((_tbldef tbl-a) key-a def-a)
    ((_tbldef tbl-b) key-b def-b)
    ((_tbldef tbl-c) key-c def-c)
     ...))
|#

) ;module moremacros