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

(module dsssl-utils

  (;export
    dsssl-fixup
    fixup-dsssl-lambda-list
    scrub-dsssl-keys)

  (import
    scheme
    chicken
    (only srfi-1
      append! reverse!))

  (require-library srfi-1)

;;

#| ;These "push" visibly into the background

(define-syntax λ
  (syntax-rules ()
    ((_ ?arg0 ...) (lambda+ ?arg0 ...))))

(define-syntax ^
  (syntax-rules ()
    ((_ ?arg0 ...) (lambda+ ?arg0 ...))))
|#

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

(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)))
          (let-values (((?keyvar0 ...) (apply values keys)))
            ?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.

(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

; keys = (keyed...)
(define (scrub-dsssl-keys keys rest)
  (let loop ((args rest) (rest '()))
    (if (null? args) (reverse! rest)
      (let ((arg (car args))
            (nxt (cdr args)) )
        (if (memq arg keys)
          (if (not (null? nxt)) (loop (cdr nxt) rest)
            (error 'scrub-dsssl-keys "missing value for keyword" arg) )
          (loop nxt (cons arg rest)) ) ) ) ) )

) ;module dsssl-utils