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

(module moremacros

(;export
  __date__ __time__
  __line__ __file__
  switch
  ->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)
(import (chicken base))
(import (chicken syntax))
(import (only (chicken string) ->string))
(import (only miscmacros repeat define-parameter))

;;; Helpers

(import-for-syntax (only (chicken base) symbol-append))
(import-for-syntax (only (chicken string) string-split))
(import-for-syntax (only (chicken time posix) seconds->local-time time->string))

;;;

;inspired by Kooda on #chicken irc Mar 7 23:39

(define-syntax __date__
  (er-macro-transformer
    (lambda (e r c)
      (time->string (seconds->local-time) "%v" #;"%b %e %Y") ) ) )

(define-syntax __time__
  (er-macro-transformer
    (lambda (e r c)
      (time->string (seconds->local-time) "%T") ) ) )

(define-for-syntax (line-info-values e)
  (let ((v (get-line-number e)))
    (if (string? v)
      (apply values (string-split v ":" #t))
      (values v #f) ) ) )

(define-syntax __line__
  (er-macro-transformer
    (lambda (e r c)
      (let-values (((f l) (line-info-values e)))
        (and l (string->number l)) ) ) ) )

(define-syntax __file__
  (er-macro-transformer
    (lambda (e r c)
      (let-values (((f l) (line-info-values e)))
        f ) ) ) )

;;;

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

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