[racket] An easy route to define-datatype in BSL?

At Sun, 04 Nov 2012 16:59:26 -0500, Prabhakar Ragde wrote:
> I'm debating trying to use something like define-datatype, as used in 
> EOPL and PLAI (and available in the Racket languages that support those 
> books) early in my first-year undergraduate class. (Opinions on the 
> wisdom of this, or on my sanity in general, by direct e-mail, please.)
> 
> In a teaching-language program, just using `require' to include 
> define-datatype and type-case or 'cases' from plai/datatype.rkt or 
> eopl/datatype.rkt appears to work so long as the teaching language is 
> ISL or higher. In BSL or BSL+, I seem to be running into a thicket of 
> rules designed to protect students. I'm using as my exploratory example 
> the trivial arithmetic expression evaluator from the beginning of PLAI 
> (2007 edition). Using plai/datatype.rkt generates an error because a use 
> of define-datatype involves function names in expression positions (as 
> contracts for field names). If I wrap these in applications of 
> first-order->higher-order from lang/prim, which seems to be designed for 
> this task, I get an error the first time I try to use a variant 
> constructor (in the PLAI example, in 'parse'). The constructors seem to 
> be defined, but also seem to be regarded as variables instead of 
> functions. This is also what happens with eopl/datatype.rkt (the other 
> error does not seem to arise).
> 
> Do I have a hope of pulling this off, and if so, how? Many thanks. --PR

Here's a first cut at a module that you can import into BSL programs.

The least obvious part is defining a new `define-type' and `type-case'
that invents hidden names for the variants and them maps between them
while expanding to the original forms.

----------------------------------------
#lang racket/base
(require plai/datatype
         lang/prim
         (prefix-in beginner: lang/htdp-beginner)
         (for-syntax racket/base
                     syntax/boundmap))
(provide (rename-out
          [my-define-type define-type]
          [my-type-case type-case]))

(define-for-syntax variants (make-free-identifier-mapping))
(define-for-syntax (record-variants! vars x-vars)
  (for ([var (in-list vars)]
        [x-var (in-list x-vars)])
    (free-identifier-mapping-put! variants var x-var)))

(define-syntax (my-define-type stx)
  (syntax-case stx ()
    [(_ ty [var (fld ctc) ...] ...)
     (with-syntax ([(x-var ...)
                    (map (lambda (s)
                           (datum->syntax
                            s
                            (string->uninterned-symbol
                             (symbol->string (syntax-e s)))
                            s
                            s))
                         (syntax->list #'(var ...)))])
       (define (adjust new-stx)
         ;; `define-type' seems to use the context of the
         ;; form for `ty?', so copy over old context
         (datum->syntax stx (syntax-e new-stx) stx stx))
       #`(begin
           #,(adjust
              #'(define-type ty
                  [x-var (fld (first-order->higher-order ctc)) ...]
                  ...))
           (beginner:define (var fld ...)
                            (x-var fld ...))
           ...
           (begin-for-syntax
            (record-variants! (list #'var ...) (list #'x-var ...)))))]))

(define-syntax (my-type-case stx)
  (syntax-case stx ()
    [(_ Ty e [var (id ...) rhs] ...)
     (with-syntax ([(x-var ...)
                    (map (lambda (var)
                           (or (free-identifier-mapping-get
                                variants
                                var
                                (lambda ()
                                  (raise-syntax-error
                                   #f
                                   "not a variant name"
                                   stx
                                   var)))))
                         (syntax->list #'(var ...)))])
       #`(type-case Ty e [x-var (id ...) rhs] ...))]))