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

/ Cookbook.UncurryingDefine

This Web


WebHome 
WebChanges 
TOC (with recipes)
NewRecipe 
WebTopicList 
WebStatistics 

Other Webs


Chicken
Cookbook
Erlang
Know
Main
Plugins
Sandbox
Scm
TWiki  

Schematics


Schematics Home
Sourceforge Page
SchemeWiki.org
Original Cookbook
RSS

Scheme Links


Schemers.org
Scheme FAQ
R5RS
SRFIs
Scheme Cross Reference
PLT Scheme SISC
Scheme48 SCM
MIT Scheme scsh
JScheme Kawa
Chicken Guile
Bigloo Tiny
Gambit LispMe
GaucheChez

Lambda the Ultimate
TWiki.org

Syntax for explicitely uncurrying a MIT-style defined function

Problem

We may want to explicitely transform a function that uses MIT Scheme style curried form:

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

turns into:

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

but we may not want to fully expand out the syntax.

Solution

The following syntax-handling function does an explicit decurrying:

(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)))

  )

Discussion


Comments about this recipe

Contributors

-- DannyYoo - 23 Jun 2006

CookbookForm
TopicType: Recipe
ParentTopic:
TopicOrder: 999

 
 
Copyright © 2004 by the contributing authors. All material on the Schematics Cookbook web site is the property of the contributing authors.
The copyright for certain compilations of material taken from this website is held by the SchematicsEditorsGroup - see ContributorAgreement & LGPL.
Other than such compilations, this material can be redistributed and/or modified under the terms of the GNU Lesser General Public License (LGPL), version 2.1, as published by the Free Software Foundation.
Ideas, requests, problems regarding Schematics Cookbook? Send feedback.
/ You are Main.guest