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

(module moremacros

(;export
  ->boolean
  assure
  whennot
  type-case type-case*
  swap!
  set!-op
  define-reference-let
  warning-guard
  checked-guard
  ;define-parameter
  define-warning-parameter
  define-checked-parameter
  ;must export helper macro: "hangs" during expansion of generated macro
  $grlaux$ )

(import scheme
  (chicken base)
  (chicken syntax)
  ;(only (chicken string) conc)
  (only miscmacros repeat define-parameter))

;;; Helpers

(import-for-syntax (only (chicken string) conc))

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

;;;

;; Returns expression as #t or #f

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

;; Returns expression value or error

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

;; `Unless' synonym

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

;;

(define-syntax $type-case$
  (er-macro-transformer
    (lambda (exp ren cmp)
      (let (
        (?loc (cadr exp))
        (?expr (caddr exp))
        (?forms (cdddr exp)) )
        (let ((var (if (cmp (ren 'type-case*) ?loc) 'it (gensym))))
          ;
          (define (make-type-pred typnam)
            `(,(make-identifier typnam #\?) ,var) )
          ;
          `(,(ren 'let) ((,var ,?expr))
             (,(ren 'cond)
               ,@(let loop (
                  (forms ?forms)
                  (lst '()) )
                  (if (null? forms) (reverse lst)
                    (let* (
                      (tcase (car forms))
                      (typnam (car tcase))
                      (next (cdr forms)) )
                      (if (cmp (ren 'else) typnam)
                        (if (null? next)
                          (loop '() (cons (cons (ren '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 ()
    ((type-case ?expr (typ0 exp0 ...) ...)
      ($type-case$ type-case ?expr (typ0 exp0 ...) ...) ) ) )

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

;; Exchange bindings of two variables

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

;; Parallel chained set

#;
(define-syntax fluid-set!
  (syntax-rules ()
    ;
    ((fluid-set! (begin body0 ...))
      (begin body0 ...) )
    ;
    ((fluid-set! ?var ?val ?rest ...)
      (let (
        (val ?val)
        (tmp ?var) )
        (set! ?var val)
        (fluid-set! ?rest ...)
        (set! ?var tmp) ) ) ) )

;; Serial chained set (CL SETQ like)

#;
(define-syntax stiff-set!
  (syntax-rules ()
    ;
    ((stiff-set! ?var ?val)
      (set! ?var ?val) )
    ;
    ((stiff-set! ?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>

(define-syntax set!-op
  (syntax-rules |:::| ()
    ((set!-op ?var ?op ?rest |:::|)
      (letrec-syntax (
          (build-call-aux
            (syntax-rules (<>)
              ((build-call-aux (?var #f) (?op ?act0 ...))
                (?op ?var ?act0 ...) )
              ;
              ((build-call-aux (?var #t) (?op ?act0 ...))
                (?op ?act0 ...) )
              ;
              ((build-call-aux (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
                (build-call-aux (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )
              ;
              ((build-call-aux (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
                (build-call-aux (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) ) ) )

          (build-call
            (syntax-rules (<>)
              ;
              ((build-call ?op ?var)
                (?op ?var) )
              ;
              ((build-call ?op ?var <> ?arg0 ...)
                (build-call-aux (?var #t) (?op ?var) ?arg0 ...) )
              ;
              ((build-call ?op ?var ?arg0 ?arg1 ...)
                (build-call-aux (?var #f) (?op ?arg0) ?arg1 ...) ) ) ) )
        ;
        (set! ?var (build-call ?op ?var ?rest |:::|)) ) ) ) )

;;

(define-syntax $grlaux$
  (syntax-rules ()
    ;finished
    (($grlaux$ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
      ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )
    ;
    (($grlaux$ "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
    (($grlaux$ "chk" ?cache ?tups ())
      ($grlaux$ "gen" ?cache () () ?tups) )
    ;
    (($grlaux$ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )
    ;
    (($grlaux$ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )
    ;
    (($grlaux$ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
    ;
    (($grlaux$ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
    ;start
    (($grlaux$ ?cache ?bnds)
      ($grlaux$ "chk" ?cache () ?bnds) ) ) )

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

;;

;FIXME These inject 'obj'
;FIXME Must import type-errors warning-argument-type

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

;;

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

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

) ;module moremacros