;;> Syntax to support optional and named keyword arguments.
;;> \scheme{let-optionals[*]} is originally from SCSH, and
;;> \scheme{let-keywords[*]} derived from Gauche.

;; Wrap bindings in temp variables to convert a let* definition to a
;; let definition.

(define-syntax let*-to-let
  (syntax-rules ()
    ((let*-to-let letstar ls (vars ...) ((v . d) . rest) . body)
     (let*-to-let letstar ls (vars ... (v tmp . d)) rest . body))
    ((let*-to-let letstar ls ((var tmp . d) ...) rest . body)
     (letstar ls ((tmp . d) ... . rest)
       (let ((var tmp) ...) . body)))))

;;> \macro{(let-optionals ls ((var default) ... [rest]) body ...)}
;;>
;;> Binding construct similar to \scheme{let}.  The \var{var}s are
;;> bound to fresh locations holding values taken in order from the
;;> list \var{ls}, \var{body} is evaluated in the resulting
;;> environment, and the value(s) of the last expression of \var{body}
;;> returned.  If the length of \var{ls} is shorter than the number of
;;> \var{var}s, then the remaining \var{var}s taken their values from
;;> their corresponding \var{default}s, evaluated in an unspecified
;;> order.  Unused \var{default}s are not evaluated.  If a final
;;> \var{rest} var is specified, then it is bound to any remaining
;;> elements of \var{ls} beyond the length of \var{ls}, otherwise any
;;> extra values are unused.
;;>
;;> Typically used on the dotted rest list at the start of a lambda,
;;> \scheme{let-optionals} is more concise and more efficient than
;;> \scheme{case-lambda} for simple optional argument uses.
;;>
;;> \emph{Example:}
;;> \schemeblock{
;;> (define (copy-port . o)
;;>   (let-optionals o ((in (current-input-port))
;;>                     (out (current-output-port))
;;>                     (n-bytes #f))
;;>     (do ((i 0 (+ i 1))
;;>          (n (read-u8 in) (read-u8 in)))
;;>         ((or (and n-bytes (>= i n-bytes))
;;>              (eof-object? b)))
;;>       (write-u8 b out)))}
;;>
;;> \emph{Example:}
;;> \example{
;;> (let-optionals '(0) ((a 10) (b 11) (c 12))
;;>   (list a b c))}

(define-syntax let-optionals
  (syntax-rules ()
    ((let-optionals ls ((var default) ... . rest) body ...)
     (let*-to-let let-optionals* ls () ((var default) ... . rest) body ...))))

;;> \macro{(let-optionals* ls ((var default) ... [rest]) body ...)}
;;>
;;> \scheme{let*} equivalent to \scheme{let-optionals}.  Any required
;;> \var{default} values are evaluated in left-to-right order, with
;;> all preceding \var{var}s in scope.

;;> \macro{(opt-lambda ((var default) ... [rest]) body ...)}
;;>
;;> Shorthand for
;;> \schemeblock{
;;> (lambda (required ... . o)
;;>   (let-optionals o ((var default) ... [rest])
;;>      body ...))}

(define-syntax opt-lambda
  (syntax-rules ()
    ((opt-lambda vars . body)
     (opt-lambda/aux () vars . body))))

(define-syntax opt-lambda/aux
  (syntax-rules ()
    ((opt-lambda/aux (args ...) ((var . default) . vars) . body)
     (lambda (args ... . o)
       (let-optionals o ((var . default) . vars) . body)))
    ((opt-lambda/aux (args ...) (var . vars) . body)
     (opt-lambda/aux (args ... var) vars . body))
    ((opt-lambda/aux (args ...) () . body)
     (lambda (args ... . o)
       . body))))

;;> \macro{(define-opt (name (var default) ... [rest]) body ...)}
;;>
;;> Shorthand for
;;> \schemeblock{
;;> (define name (opt-lambda (var default) ... [rest]) body ...)}

(define-syntax define-opt
  (syntax-rules ()
    ((define-opt (name . vars) . body)
     (define name (opt-lambda vars . body)))))

;;> \procedure{(keyword-ref ls key [default])}
;;>
;;> Search for the identifier \var{key} in the list \var{ls}, treating
;;> it as a property list of the form \scheme{(key1 val1 key2 val2
;;> ...)}, and return the associated \var{val}.  If not found, return
;;> \var{default}, or \scheme{#f}.

(define (keyword-ref ls key . o)
  (let lp ((ls ls))
    (if (and (pair? ls) (pair? (cdr ls)))
        (if (eq? key (car ls))
            (cadr ls)
            (lp (cddr ls)))
        (and (pair? o) (car o)))))

;;> \macro{(keyword-ref* ls key default)}
;;>
;;> Macro equivalent of \scheme{keyword-ref}, where \var{default} is
;;> only evaluated if \var{key} is not found.

(define-syntax keyword-ref*
  (syntax-rules ()
    ((keyword-ref* ls key default)
     (cond ((memq key ls) => cadr) (else default)))))

(define (symbol->keyword sym)
  (string->symbol (string-append (symbol->string sym) ":")))

(define-syntax let-key*-to-let
  (syntax-rules ()
    ((let-key*-to-let ls (vars ...) ((v d) . rest) . body)
     (let-key*-to-let ls (vars ... (v tmp ,(symbol->keyword 'v) d)) rest
                      . body))
    ((let-key*-to-let ls (vars ...) ((v k d) . rest) . body)
     (let-key*-to-let ls (vars ... (v tmp k d)) rest . body))
    ((let-key*-to-let ls ((var tmp k d) ...) rest . body)
     (let-keywords* ls ((tmp k d) ... . rest)
       (let ((var tmp) ...) . body)))))

;;> \macro{(let-keywords ls ((var [keyword] default) ... [rest]) body ...)}
;;>
;;> Analogous to \scheme{let-optionals}, except instead of binding the
;;> \var{var}s by position they are bound by name, by searching in
;;> \var{ls} with \scheme{keyword-ref*}.  If an optional \var{keyword}
;;> argument is provided it must be an identifier to use as the name,
;;> otherwise \var{var} is used, appending a ":" (colon).  If the name
;;> is not found, \var{var} is bound to \var{default}, even if unused
;;> names remain in \var{ls}.
;;>
;;> If an optional trailing identifier \var{rest} is provided, it is
;;> bound to the list of unused arguments not bound to any \var{var}.
;;>
;;> Note R7RS does not have a disjoint keyword type or auto-quoting
;;> syntax for keywords - they are simply identifiers.  Thus when
;;> passing keyword arguments they must be quoted (or otherwise
;;> dynamically evaluated).
;;>
;;> \emph{Example:}
;;> \example{
;;> (define (make-person . o)
;;>   (let-keywords o ((name "John Doe")
;;>                    (age 0)
;;>                    (occupation job: 'unemployed))
;;>     (vector name age occupation)))
;;>
;;> (list (make-person)
;;>       (make-person 'name: "Methuselah" 'age: 969)
;;>       (make-person 'name: "Dr. Who" 'job: 'time-lord 'age: 1500))
;;> }
;;>
;;> \emph{Example:}
;;> \example{
;;> (let-keywords '(b: 2 a: 1 other: 9)
;;>     ((a 0) (b 0) (c 0) rest)
;;>   (list a b c rest))
;;> }

(define-syntax let-keywords
  (syntax-rules ()
    ((let-keywords ls vars . body)
     (let-key*-to-let ls () vars . body))))

(define (remove-keywords ls keywords)
  (let lp ((ls ls) (res '()))
    (if (and (pair? ls) (pair? (cdr ls)))
        (if (memq (car ls) keywords)
            (lp (cddr ls) res)
            (lp (cddr ls) (cons (cadr ls) (cons (car ls) res))))
        (reverse res))))

(define-syntax remove-keywords*
  (syntax-rules ()
    ((remove-keywords* opt-ls (keys ...) ((var key default) . rest))
     (remove-keywords* opt-ls (keys ... key) rest))
    ((remove-keywords* opt-ls (keys ...) ((var default) . rest))
     (remove-keywords* opt-ls (keys ... ,(symbol->keyword* 'var)) rest))
    ((remove-keywords* opt-ls (keys ...) ())
     (remove-keywords opt-ls `(keys ...)))))

;;> \macro{(let-keywords* ls ((var [keyword] default) ... [rest]) body ...)}
;;>
;;> \scheme{let*} equivalent to \scheme{let-keywords*}.  Any required
;;> \var{default} values are evaluated in left-to-right order, with
;;> all preceding \var{var}s in scope.
;;>
;;> \emph{Example:}
;;> \example{
;;> (let-keywords* '(b: 5)
;;>     ((a 1) (b (* a 2)) (c (* b 3)))
;;>   (list a b c))
;;> }

(define-syntax let-keywords*
  (syntax-rules ()
    ((let-keywords* opt-ls () . body)
     (begin . body))
    ((let-keywords* (op . args) vars . body)
     (let ((tmp (op . args)))
       (let-keywords* tmp vars . body)))
    ((let-keywords* opt-ls ((var) (vars . x) ...) . body)
     (let-keywords* opt-ls ((var #f) (vars . x) ...) . body))
    ((let-keywords* opt-ls ((var default) (vars . x) ...) . body)
     (let ((var (keyword-ref* opt-ls (symbol->keyword* 'var) default)))
       (let-keywords* opt-ls ((vars . x) ...) . body)))
    ((let-keywords* opt-ls ((var key default) (vars . x) ...) . body)
     (let ((var (keyword-ref* opt-ls `key default)))
       (let-keywords* opt-ls ((vars . x) ...) . body)))
    ((let-keywords* opt-ls ((vars . x) ... tail) . body)
     (let ((tail (remove-keywords* opt-ls () ((vars . x) ...))))
       (let-keywords* opt-ls ((vars . x) ...) . body)))))