s c h e m a t i c s : c o o k b o o k

(define ((add x) y)
  (+ x y))

(define add
  (lambda (x)
    (lambda (y)
      (+ x y))))  

(module desugar-define mzscheme

  ;; This module helps transform define's defun syntax of the form
  ;;
  ;; ((function-name arg1 arg2 ... argn) body)
  ;;
  ;; into a stx-list of two syntaxes
  ;; (function-name (lambda (arg1 arg2 ... argn) body))
  ;;
  ;; It's also supposed to handle curried-defun forms and the implicit
  ;; begins.
  
  ;; (define (f x) value) --> (define f (lambda (x) value))
  ;; (define (f x y z) value) --> (define f (lambda (x y z) value))
  ;; (define ((f x) y) value) --> (define f (lambda (x) (lambda (y) value)))
  
 
  (provide (all-defined))
  
  ;; desugar-define: (case-> (syntax syntax syntax syntax -> syntax)
  ;;                         (syntax -> syntax))
  ;; Converts defun forms into more primitive define forms.  Handles
  ;; implicit begin and curried parameters.
  ;;
  ;; Parameterized to allow us to handle slightly different languages.  For
  ;; example:
  ;;
  ;; (desugar-define #'(def ((f x) y) (printf "adding: ~a ~a~n" x y) (+ x y))
  ;;                 #'def #'fun #'progn)
  ;;
  ;; returns a syntax that looks like:
  ;;
  ;; #'(def f (fun (x) (fun (y) (progn (printf "adding: ~a ~a~n" x y) (+ x y)))))
  ;;
  (define desugar-define
    (case-lambda
      [(stx)
       (desugar-define stx #'define #'lambda #'begin)]
      
      [(stx define-kw-stx lambda-kw-stx begin-kw-stx)
       (syntax-case stx ()
         
         ;; Either: force all multi-expr bodies to be embedded in a begin, and recurse.
         [(define name-or-curried body-1 body-2 body-rest ...) 
          (desugar-define #`(define name-or-curried 
                              (#,begin-kw-stx body-1 body-2 body-rest ...))
                          define-kw-stx lambda-kw-stx begin-kw-stx)]
         
         ;; or handle the expected case:
         [(define name-or-curried body)
          (module-identifier=? #'define define-kw-stx)
          (with-syntax ([(name value)
                         (desugar-define/name-value 
                          #'(name-or-curried body)
                          lambda-kw-stx)])
            #`(define name value))]
         
         ;; or check for simple syntax errors:
         [(define name-or-curried body)
          (not (module-identifier=? #'define define-kw-stx))
          (raise-syntax-error 
           #f "does not match define-kw-stx" stx #'define)])]))
  
  
  (define (desugar-define/name-value stx lambda-kw-stx)
    (syntax-case stx ()
      [(name value)
       (identifier? #'name)
       stx]
  
      [((curried-form ...) value)
       (let-values ([(name body) 
                     (unravel-curried-form #'(curried-form ...) 
                                           #'value 
                                           lambda-kw-stx)])
         #`(#,name #,body))]))
  
  
  ;; unravel-curried-form: syntax stx stx -> syntax
  ;; Digs into the defun form and returns a list of two values: the
  ;; name of the defun-ed function, and its corresponding value.
  (define (unravel-curried-form stx body-stx lambda-kw-stx)
    (let loop ([stx stx]
               [body-stx body-stx])
      (syntax-case stx ()

        [(name args ...)
         (identifier? #'name)
         (values #'name
                 #`(#,lambda-kw-stx (args ...) #,body-stx))]

        [((curried-form ...) args ...)
         (loop #'(curried-form ...)
               #`(#,lambda-kw-stx (args ...) #,body-stx))])))


  
  ;; Just playing around with eval
  #;(define (test-make-add)
    (define add
      (parameterize ([current-namespace (make-namespace)])
        (eval-syntax #`(module a mzscheme
                         (provide (all-defined))
                         #,(desugar-define #'(define ((add x) y) (+ x y)))))
        (eval-syntax #'(require a))
        (namespace-variable-value 'add (module->namespace 'a))))
    (printf "~a~n" ((add 3) 4)))

  )