suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding define-datatype to ASL

Browse Source
This commit is contained in:
Jay McCarthy 2010-07-22 11:35:30 -06:00
parent 5bb2e148de
commit 9eb053d4db
4 changed files with 171 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/lang/htdp-advanced.rkt
View File

@ -15,6 +15,7 @@
(provide (rename-out
[advanced-define define]
[advanced-define-struct define-struct]
[advanced-define-datatype define-datatype]
[advanced-lambda lambda]
[advanced-lambda λ]
[advanced-app #%app]

104
collects/lang/private/teach.rkt
View File

@ -203,6 +203,7 @@
advanced-when
advanced-unless
advanced-define-struct
advanced-define-datatype
advanced-let
advanced-recur
advanced-begin
@ -930,6 +931,109 @@
(define (intermediate-define-struct/proc stx)
(do-define-struct stx #f #f))
(define (advanced-define-datatype/proc stx)
(unless (or (ok-definition-context)
(identifier? stx))
(teach-syntax-error
'define-datatype
stx
#f
"found a definition that is not at the top level"))
(syntax-case stx ()
;; First, check for a datatype name:
[(_ name . __)
(not (identifier/non-kw? (syntax name)))
(teach-syntax-error
'define-datatype
stx
(syntax name)
"expected a datatype type name after `define-datatype', but found ~a"
(something-else/kw (syntax name)))]
[(_ name (variant field ...) ...)
(let ([find-duplicate
(λ (stxs fail-k)
(define ht (make-hash-table))
(for-each
(λ (s)
(define sym (syntax-e s))
(when (hash-table-get ht sym (λ () #f))
(fail-k s))
(hash-table-put! ht sym #t))
(syntax->list stxs)))])
(for-each
(λ (v)
(unless (identifier/non-kw? v)
(teach-syntax-error
'define-datatype
stx
v
"expected a variant name, found ~a"
(something-else/kw v))))
(syntax->list #'(variant ...)))
(find-duplicate #'(variant ...)
(λ (v-stx)
(define v (syntax-e v-stx))
(teach-syntax-error
'define-datatype
stx
v-stx
"found a variant name that was used more than once: ~a"
v)))
(for-each
(λ (vf)
(with-syntax ([(variant field ...) vf])
(for-each
(λ (f)
(unless (identifier? f)
(teach-syntax-error
'define-datatype
stx
f
"in variant `~a': expected a field name, found ~a"
(syntax-e #'variant)
(something-else f))))
(syntax->list #'(field ...)))
(find-duplicate #'(field ...)
(λ (f-stx)
(teach-syntax-error
'define-datatype
stx
f-stx
"in variant `~a': found a field name that was used more than once: ~a"
(syntax-e #'variant)
(syntax-e f-stx))))))
(syntax->list #'((variant field ...) ...))))
(with-syntax ([(name? variant? ...)
(map (lambda (stx)
(datum->syntax stx (string->symbol (format "~a?" (syntax->datum stx)))))
(syntax->list #'(name variant ...)))])
(syntax/loc stx
(begin (advanced-define (name? x)
(or (variant? x) ...))
(advanced-define-struct variant (field ...))
...)))]
[(_ name_ (variant field ...) ... something . rest)
(teach-syntax-error
'define-datatype
stx
(syntax something)
"expected a variant after the datatype type name in `define-datatype', ~
but found ~a"
(something-else (syntax something)))]
[(_)
(teach-syntax-error
'define-datatype
stx
#f
"expected a datatype type name after `define-datatype', but nothing's there")]
[_else (bad-use-error 'define-datatype stx)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; application (beginner and intermediate)

25
collects/scribblings/htdp-langs/advanced.scrbl
View File

@ -42,7 +42,7 @@
@declare-exporting[lang/htdp-advanced]
@schemegrammar*+qq[
#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet
#:literals (define define-struct define-datatype lambda λ cond else if and or empty true false require lib planet
local let let* letrec time begin begin0 set! delay shared recur when case unless
check-expect check-within check-error)
(check-expect check-within check-error require)
@ -53,7 +53,8 @@
library-require]
[definition (define (id id id ...) expr)
(define id expr)
(define-struct id (id ...))]
(define-struct id (id ...))
(define-datatype id (id id ...) ...)]
[expr (begin expr expr ...)
(begin0 expr expr ...)
(set! id expr)
@ -130,6 +131,26 @@ additional set of operations:
@; ----------------------------------------------------------------------
@section[#:tag "advanced-define-datatype"]{@scheme[define-datatype]}
@defform[(define-datatype datatypeid [variantid fieldid ...] ...)]{
A short-hand for defining a group of related structures. A @scheme[define-datatype] form
@schemeblock[
(define-datatype datatypeid
[variantid fieldid (unsyntax @schemeidfont{...})]
(unsyntax @schemeidfont{...}))
]
is equivalent to
@schemeblock[
(define ((unsyntax @scheme[datatypeid])? x)
(or ((unsyntax @scheme[variantid])? x) (unsyntax @schemeidfont{...})))
(define-struct variantid (fieldid (unsyntax @schemeidfont{...})))
(unsyntax @schemeidfont{...})
]}
@; ----------------------------------------------------------------------
@section[#:tag "advanced-lambda"]{@scheme[lambda]}
@deftogether[(

43
collects/tests/racket/advanced.rktl
View File

@ -300,6 +300,49 @@
(eval #'(set! s? 12))
(eval #'(set! set-s-x! 12)))
;; define-datatype
(htdp-syntax-test #'define-datatype #rx"define-datatype: found a use of `define-datatype' that does not follow an open parenthesis")
(htdp-syntax-test #'(define-datatype) #rx"define-datatype: expected a datatype type name after `define-datatype', but nothing's there")
(htdp-syntax-test #'(define-datatype dt 10) #rx"define-datatype: expected a variant after the datatype type name in `define-datatype', but found a number")
(htdp-syntax-test #'(define-datatype dt [v1] 10) #rx"define-datatype: expected a variant after the datatype type name in `define-datatype', but found a number")
(htdp-syntax-test #'(define-datatype dt v1) #rx"define-datatype: expected a variant after the datatype type name in `define-datatype', but found something else")
(htdp-syntax-test #'(define-datatype dt [v1 f1 f1]) #rx"define-datatype: in variant `v1': found a field name that was used more than once: f1")
(htdp-syntax-test #'(define-datatype dt [10]) #rx"define-datatype: expected a variant name, found a number")
(htdp-syntax-test #'(define-datatype dt [(v1)]) #rx"define-datatype: expected a variant name, found something else")
(htdp-syntax-test #'(define-datatype dt [v1 10]) #rx"define-datatype: in variant `v1': expected a field name, found a number")
(htdp-syntax-test #'(define-datatype dt [v1] [v1]) #rx"define-datatype: found a variant name that was used more than once: v1")
(htdp-syntax-test #'(define-datatype posn [v1]) #rx"posn\\?: this name has a built-in meaning and cannot be re-defined")
(htdp-syntax-test #'(define-datatype dt [posn]) #rx"posn: this name has a built-in meaning and cannot be re-defined")
(htdp-syntax-test #'(define-datatype lambda [v1]) #rx"define-datatype: expected a datatype type name after `define-datatype', but found a keyword")
(htdp-syntax-test #'(define-datatype dt [lambda]) #rx"define-datatype: expected a variant name, found a keyword")
(htdp-syntax-test #'(define-datatype (dt)) #rx"define-datatype: expected a datatype type name after `define-datatype', but found something else")
(htdp-syntax-test #'(+ 1 (define-datatype dt [v1])) #rx"define-datatype: found a definition that is not at the top level")
(htdp-top (define-datatype dt))
(htdp-test #f 'dt? (dt? 1))
(htdp-top-pop 1)
(htdp-top (define x 5))
(htdp-syntax-test #'(define-datatype x [v1]) #rx"x: this name was defined previously and cannot be re-defined")
(htdp-syntax-test #'(define-datatype dt [x]) #rx"x: this name was defined previously and cannot be re-defined")
(htdp-top-pop 1)
(htdp-top (define-datatype a
[a0]
[a1 b]
[a3 b c d]))
(htdp-test #t 'a0? (a0? (make-a0)))
(htdp-test #t 'a? (a? (make-a0)))
(htdp-test #t 'a1? (a1? (make-a1 1)))
(htdp-test #t 'a? (a? (make-a1 1)))
(htdp-test #t 'a3? (a3? (make-a3 1 2 3)))
(htdp-test #t 'a? (a? (make-a3 1 2 3)))
(htdp-test #f 'a1? (a1? (make-a3 1 2 3)))
(htdp-test #f 'a3? (a3? (make-a1 1)))
(htdp-test #f 'a? (a? 1))
(htdp-top-pop 1)
;; ----------------------------------------
(report-errs)