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

(module moremacros

  (;export
    assure
    define-variable
    make-variable
    whennot
    type-case type-case*
    swap-set!
    fluid-set!
    stiff-set!
    set!/op)

  (import
    scheme
    chicken
    (only type-checks check-procedure check-symbol)
    (only type-errors warning-argument-type))

  (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 (symbolize . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

;;;

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

;;

; not too proud of the name `variable' but ...

; doesn't belong here
(define (make-variable init #!optional guard typnam)
  (if guard
    (begin
      (check-procedure 'make-variable guard 'guard)
      (let* ((typnam
              (if typnam (check-symbol 'make-variable typnam 'type-name)
                "acceptable object" ) )
             (warn (lambda (arg) (warning-argument-type #f init typnam)) ) )
        (unless (guard init) (warn init))
        (let ((varval init))
          (lambda args
            (if (null? args) varval
              (let ((arg (car args)))
                (if (guard arg) (set! varval arg)
                  (warn arg) )
                (void) ) ) ) ) ) )
    (let ((varval init))
      (lambda args
        (if (null? args) varval
          (begin
            (set! varval (car args))
            (void) ) ) ) ) ) )

(define-syntax define-variable
  (syntax-rules ()

    ((_ name init)
      (define-variable name init #f #f) )

    ((_ name init guard typnam)
      (define name (make-variable init guard typnam)) ) ) )

;; `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)
        `(,(symbolize 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 ...)) ) ) )

) ;module moremacros