;;; default.scm  --  Jens Axel Søgaard

(module default mzscheme
  (provide with-defaults
           define-default
           override-default)
  
  (define-for-syntax defaults '())
  
  (require-for-syntax (prefix srfi: (lib "1.ss" "srfi")))
  
  (begin-for-syntax
    (define (default-registered? name)
      (not (not (srfi:assoc name defaults module-identifier=?))))
    
    (define (register-default name val)
      (set! defaults 
            (cons (cons name val) defaults))))
  
  (define-syntax (define-default stx)
    (syntax-case stx ()
      [(define-default name val)
       (begin
         (when (default-registered? #'name)
           (raise-syntax-error #f "duplicate definition of default" stx #'name))
         #'(begin
             (begin-for-syntax
               (register-default #'name #'val))
             (define name (make-parameter val))))]))
  
  (define-syntax (override-default stx)
    (syntax-case stx ()
      [(override-default name val)
       (begin
         (unless (default-registered? #'name)
           (raise-syntax-error #f "can't override undefined default" stx #'name))
         #'(begin
             (begin-for-syntax
               (register-default #'name #'val))
             (name val)))]))
  
  (define-syntax (with-defaults stx)
    (syntax-case stx ()
      [(with-defaults body ...)
          #`(parameterize 
                (#,@(map (lambda (default)
                           #`(#,(car default) #,(cdr default)))
                         (reverse defaults)))
              body ...)])))