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

(module moremacros

(;export
  true false
  true? false?
  ->boolean
  always
  case-with select-with
  switch
  assure
  whennot
  type-case type-case*
  swap!
  set!-op
  define-reference-let
  (warning-guard *warning-argument-type)
  checked-guard
  define-warning-parameter
  define-checked-parameter
  #; ;very not ready
  lets
  ;must export helper macro: "hangs" during expansion of generated macro
  $grlaux$)

(import scheme
  (chicken base)
  (chicken base)
  (chicken module)
  (chicken syntax)
  (only (chicken string) ->string)
  (only miscmacros repeat define-parameter)
  (only type-errors-basic 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) ) ) )

;; Returns expression as #t or #f

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

;;

(define-syntax always
  (syntax-rules ()
    ((always ?body0 ...)
      (lambda _ ?body0 ...) ) ) )

;; (like moremacros select)

(define-syntax case-with
  (er-macro-transformer
    (lambda (frm ren cmp)
      (##sys#check-syntax 'case-with frm '(_ _ _ . _))
      (let ((pred (cadr frm))
            (expr (caddr frm))
            (body (cdddr frm))
            (_tmp0 (ren 'tmp0))
            (_eql? (ren 'eql?))
            (_begin (ren 'begin))
            (_void (ren 'void))
            (_if (ren 'if))
            (_let (ren 'let))
            (_else (ren 'else))
            (_or (ren 'or)) )
        `(,_let ((,_eql? ,pred) (,_tmp0 ,expr))
          ,(let expd-form ((clauses body) (seen-else #f))
            (cond ((null? clauses)
                    `(,_void) )
                  ((not (pair? clauses))
                    (syntax-error 'case-with "invalid syntax" clauses) )
                  (else
                    (let ((clause (car clauses))
                          (rclauses (cdr clauses)) )
                      (##sys#check-syntax 'case-with 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 `case-with'"
                                (strip-syntax clause))
                              (expd-form rclauses #t)
                              `(,_begin) )
                            (else
                              `(,_if (,_or ,@(map (lambda (x) `(,_eql? ,_tmp0 ',x))
                                            (car clause)))
                                     (,_begin ,@(cdr clause))
                                     ,(expd-form rclauses #f)) ) ) ) ) ) ) ) ) ) ) )

(define-syntax select-with
  (er-macro-transformer
    (lambda (frm ren cmp)
      (##sys#check-syntax 'select-with frm '(_ _ _ . _))
      (let ((pred (cadr frm))
            (expr (caddr frm))
            (body (cdddr frm))
            (_tmp0 (ren 'tmp0))
            (_eql? (ren 'eql?))
            (_begin (ren 'begin))
            (_void (ren 'void))
            (_if (ren 'if))
            (_let (ren 'let))
            (_else (ren 'else))
            (_or (ren 'or)) )
        `(,_let ((,_eql? ,pred) (,_tmp0 ,expr))
          ,(let expd-form ((clauses body) (seen-else #f))
            (cond ((null? clauses)
                    `(,_void) )
                  ((not (pair? clauses))
                    (syntax-error 'select-with "invalid syntax" clauses) )
                  (else
                    (let ((clause (car clauses))
                          (rclauses (cdr clauses)) )
                      (##sys#check-syntax 'select-with 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 `select-with'"
                                (strip-syntax clause))
                              (expd-form rclauses #t)
                              `(,_begin) )
                            (else
                              `(,_if (,_or ,@(map (lambda (x) `(,_eql? ,_tmp0 ,x))
                                            (car clause)))
                                     (,_begin ,@(cdr clause))
                                     ,(expd-form rclauses #f)) ) ) ) ) ) ) ) ) ) ) )

(define-syntax switch
  (syntax-rules ()
    ((switch ?expr ?body0 ...)
      (select-with equal? ?expr ?body0 ...) ) ) )

;; Returns expression value or error

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

;; `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))
            (_or (ren 'or))
            (_else (ren 'else))
            (_cond (ren 'cond))
            (_type-case* (ren 'type-case*))
            (_let (ren 'let)) )
        (let ((var (if (cmp _type-case* ?loc) 'it (gensym))))
          (define (make-type-pred typnam)
            `(,(symbol-append (strip-syntax typnam) '?) ,var) )
          `(,_let ((,var ,?expr))
             (,_cond
               ,@(let loop ((forms ?forms)
                            (lst '()) )
                  (if (null? forms)
                      (reverse lst)
                      (let* ((tcase (car forms))
                             (typnam (car tcase))
                             (next (cdr forms)) )
                        (if (cmp _else typnam)
                            (if (null? next)
                                (loop '() (cons (cons _else (cdr tcase)) lst))
                                (syntax-error ?loc "else form out of position" tcase) )
                            (loop (cdr forms)
                                  `((,(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)
      (set! ?var (?op ?var)) )
    ;
    ((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)) ) ) ) ) ) )

;;

;{{warning-argument-type}} is syntax!
(define (*warning-argument-type loc obj nam) (warning-argument-type loc obj nam))

;NOTE {{[warning|error]-guards}} open {{obj}} to {{@body}}

(define-syntax warning-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
      (let ((_lambda (rnm 'lambda))
            (_if (rnm 'if))
            (_let (rnm 'let))
            (_begin (rnm 'begin))
            (_*warning-argument-type (rnm '*warning-argument-type))
            (_arg (rnm 'arg))
            (?getnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm)) )
        (let ((predname (symbol-append (strip-syntax ?typnam) '?))) ;inject
          `(,_lambda (,_arg)
            (,_if (,predname ,_arg)
                  (,_let ((obj ,_arg))
                    ,@?body
                    obj )
                  (,_begin
                    (,_*warning-argument-type ',?getnam ,_arg ',?typnam)
                    (,?getnam) ) ) ) ) ) ) ) )

(define-syntax checked-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
      (let ((_lambda (rnm 'lambda))
            (_let (rnm 'let))
            (_arg (rnm 'arg))
            (?locnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm)) )
        (let ((chknam (symbol-append 'check- (strip-syntax ?typnam)))) ;inject
          `(,_lambda (,_arg)
            (,chknam ',?locnam ,_arg)
            (,_let ((obj ,_arg))
              ,@?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 ...)) ) ) )

;;

#; ;plist version of letrec*
(define-syntax lets
  (syntax-rules ()
    ; empty case
    ((lets () ?body0 ...)
      (let () ?body0 ...))
    ; otherwise
    ((lets (?i ?v ?as ...) ?body0 ...)
      (lets "pair-args" (?as ...) ((?i ?v)) (?body0 ...)))
    ; collection phase
    ((lets "pair-args" (?i ?v ?as ...) (?als ...) ?body)
      (lets "pair-args" (?as ...) (?als ... (?i ?v)) ?body))
    ; last args?
    ((lets "pair-args" (?i ?v) (?als ...) ?body)
      (lets "pair-args" () (?als ... (?i ?v)) ?body))
    ; last arg? (do not treat as error)
    ((lets "pair-args" (?i) (?als ...) ?body)
      ;"default" value for unpaired (assumed) identifier
      (lets "pair-args" () (?als ... (?i (void))) ?body))
    ; finish!
    ((lets "pair-args" () (?als ...) (?body0 ...))
      (letrec* (?als ...) ?body0 ...)) ) )

) ;module moremacros