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

(module moremacros

(;export
  true false
  true? false?
  switch
  ->boolean
  assure
  whennot
  type-case type-case*
  swap!
  set!-op
  define-reference-let
  (warning-guard warning-argument-type)
  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 base)
  (chicken module)
  (only (chicken string) ->string)
  (only miscmacros repeat define-parameter)
  (only type-errors warning-argument-type))

(import cpp-macros)
(reexport cpp-macros)

;;; Helpers

(import-for-syntax (only (chicken base) symbol-append))

;;;

(define-syntax true
  (syntax-rules ()
    ((true)
      #t )
    ((true ?body ...)
      (begin ?body ... #t) ) ) )

(define-syntax false
  (syntax-rules ()
    ((false)
      #f )
    ((false ?body ...)
      (begin ?body ... #f) ) ) )

(define-syntax true?
  (syntax-rules ()
    ((true? ?x)
      (let ((_x ?x)) (and (boolean? _x) _x)) ) ) )

(define-syntax false?
  (syntax-rules ()
    ((false? ?x)
      (not ?x) ) ) )

;; (from moremacros select)

(define-syntax switch
  (er-macro-transformer
    (lambda (frm ren cmp)
      (##sys#check-syntax 'switch frm '(_ _ . _))
      (let ((exp (cadr frm))
            (body (cddr frm))
            (_tmp (ren 'tmp))
            (_else (ren 'else))
            (_or (ren 'or)) )
        `(let ((,_tmp ,exp))
          ,(let expd-form ((clauses body) (seen-else #f))
            (cond
              ((null? clauses)
                '(void) )
              ((not (pair? clauses))
                (syntax-error 'switch "invalid syntax" clauses) )
              (else
                (let ((clause (car clauses))
                      (rclauses (cdr clauses)) )
                  (##sys#check-syntax 'switch clause '#(_ 1))
                  (cond
                    ((cmp _else (car clause))
                      (expd-form rclauses #t)
                      `(begin ,@(cdr clause)) )
                    (seen-else
                      (##sys#notice
                        "non-`else' clause following `else' clause in `switch'"
                        (strip-syntax clause))
                      (expd-form rclauses #t)
                      '(begin) )
                  (else
                    `(if
                      (,_or
                        ,@(map (lambda (x) `(equal? ,_tmp ,x))
                        (car clause)))
                      (##core#begin
                        ,@(cdr clause))
                        ,(expd-form rclauses #f) ) ) ) ) ) ) ) ) ) ) ) )

;; 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)
            `(,(symbol-append (strip-syntax 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! ?a ?b)
      (let ((_tmp ?a))
        (set! ?a ?b)
        (set! ?b _tmp)) ) ) )

;; 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 works in csi but not in hash-let compiled
(define-syntax define-reference-let
  (syntax-rules ()
    ((define-reference-let ?name ?ref)
      (letrec-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 ?name
          (syntax-rules |:::| ()
            ((?name ?item ?binds ?body0 |:::|)
              ($grlaux$ (?name ?item ?ref (?body0 |:::|)) ?binds)) ) ) ) ) ) )

;;

;FIXME These inject 'obj'

(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 (symbol-append (strip-syntax ?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 (symbol-append 'check- (strip-syntax ?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