;;;; dsssl-utils.scm
;;;; Kon Lovett, Aug '10
;;;; Kon Lovett, Feb '18

(module dsssl-utils

(;export
  dsssl-fixup
  fixup-dsssl-lambda-list
  delete-keyword-arguments ensure-keyword-list
  ;deprecated
  scrub-dsssl-keys )

(import scheme chicken)
(use
  (only srfi-1 append! reverse!)
  (only symbol-utils symbol->keyword))

;; DSSSL Extended Lambda List fixup
;;
;; Compensates for the #!rest #!key order; should be #!key #!rest.

;(: dsssl-fixup (list list list --> list))
;
(define-syntax dsssl-fixup
  (syntax-rules ()
    ;
    ((_ "aux" (?opts ...) ((?ovar ?odef)) ?keep)
      (dsssl-fixup "aux" (?opts ... (?ovar ?odef)) () ?keep) )
    ;
    ((_ "aux" (?opts ...) (?ovar) ?keep)
      (dsssl-fixup "aux" (?opts ... (?ovar #f)) () ?keep) )
    ;
    ((_ "aux" (?opts ...) ((?ovar ?odef) ?opt ...) ?keep)
      (dsssl-fixup "aux" (?opts ... (?ovar ?odef)) (?opt ...) ?keep) )
    ;
    ((_ "aux" (?opts ...) (?ovar ?opt ...) ?keep)
      (dsssl-fixup "aux" (?opts ... (?ovar #f)) (?opt ...) ?keep) )
    ;
    ((_ "aux" ((?optvar0 ?optdef0) ...) () (((?key0 ?keyvar0) ...) ?rest ?body ...))
      (let-values (
        ((?rest opts keys)
          (fixup-dsssl-lambda-list
            (list (cons ?optvar0 ?optdef0) ...)
            (list (cons ?key0 ?keyvar0) ...)
            ?rest) ) )
        (let-values (
          ((?optvar0 ...) (apply values opts))
          ((?keyvar0 ...) (apply values keys)) )
          ?body ... ) ) )
    ;
    ((_ ((?key0 ?keyvar0) ...) ?rest ?body ...)
      (dsssl-fixup () (((?key0 ?keyvar0) ...) ?rest ?body ...)) )
    ;
    ((_ ?opt ((?key0 ?keyvar0) ...) ?rest ?body ...)
      (dsssl-fixup "aux" () ?opt (((?key0 ?keyvar0) ...) ?rest ?body ...)) ) ) )

;; Returns "correct" rest optionals keys values

;This is ridiculous. Better to just supply own define & lambda.

(: fixup-dsssl-lambda-list (list list list --> list list list))
;
(define (fixup-dsssl-lambda-list opts keys rest)
  ;
  (define (undo-damage)
    (let loop ((opts opts) (pref '()))
      (if (null? opts)
        (append! (reverse! pref) rest)
        (let (
          (opt (car opts))
          (nxtopts (cdr opts)) )
          (let ((val (car opt)) )
            (cond
              ((assq val keys)
                (if (null? nxtopts)
                  (loop '() (cons val pref))
                  (loop (cdr nxtopts) (cons (caar nxtopts) (cons val pref))) ) )
              (else
                (loop nxtopts (cons val pref)) ) ) ) ) ) ) )
  ;
  (define (default-optionals opts optionals)
    (if (null? opts)
      optionals
      (default-optionals (cdr opts) (cons (cdar opts) optionals)) ) )
  ;
  (let loop ((opts opts) (args (undo-damage)) (optionals '()) (rest '()))
    (cond
      ((null? args)
        (cond
          ; we done
          ((null? opts)
            (values (reverse! rest) (reverse! optionals) (map cdr keys)) )
          ; remaining opts are defaulted
          (else
            (loop '() '() (default-optionals opts optionals) rest) ) ) )
      (else
        (let (
          (arg (car args))
          (nxt (cdr args)) )
          (let ((key? (assq arg keys)))
            (cond
              ; scrub key+val
              (key?
                (if (null? nxt)
                  (error 'fixup-dsssl-lambda-list "missing value for keyword" (car key?))
                  (begin
                    (set-cdr! key? (car nxt))
                    (loop opts (cdr nxt) optionals rest) ) ) )
              ; no opts so rest arg
              ((null? opts)
                (loop '() nxt optionals (cons arg rest)) )
              ; opt given a key by mistake
              ((assq (caar opts) keys)
                (let (
                  (optionals (cons arg optionals))
                  (nxtopts (cdr opts)) )
                  (cond
                    ; just this opt
                    ((null? nxtopts)
                      (loop '() nxt optionals rest) )
                    ; next opt given val of key+val by mistake as well
                    (else
                      (if (null? nxt)
                        (loop (cdr nxtopts) '() (cons (cdar nxtopts) optionals) rest)
                        (loop (cdr nxtopts) (cdr nxt) (cons (cadr args) optionals) rest) ) ) ) ) )
              ; assign opt
              (else
                (loop (cdr opts) nxt (cons arg optionals) rest) ) ) ) ) ) ) ) )

;; Returns the argument list w/o key+val pairs

;(define keyword->symbol (o string->symbol keyword->string))
;(define keyword->uninterned-symbol (o string->uninterned-symbol keyword->string))

(: ensure-keyword-list ((list-of symbol) --> (list-of symbol)))
;
(define (ensure-keyword-list kwds)
  (foldl
    (lambda (a x)
      (if (and (symbol? x) (not (keyword? x)))
        (cons (symbol->keyword x) a)
        a ) )
    '()
    kwds) )

(: delete-keyword-arguments ((list-of symbol) list --> list))
;
; kwds = (list-of (or keyword symbol))
(define (delete-keyword-arguments kwds rest)
  (let ((kwds (ensure-keyword-list kwds)))
    (let loop ((args rest) (rest '()))
      (if (null? args)
        (reverse! rest)
        (let (
          (arg (car args))
          (nxt (cdr args)) )
          (if (memq arg kwds)
            (if (not (null? nxt))
              (loop (cdr nxt) rest)
              (error 'delete-keyword-arguments "premature end-of-list" arg rest kwds) )
            (loop nxt (cons arg rest)) ) ) ) ) ) )

(: scrub-dsssl-keys deprecated)
(define scrub-dsssl-keys delete-keyword-arguments)

) ;module dsssl-utils