Skip to content

Commit

Permalink
Adding define-datatype to ASL
Browse files Browse the repository at this point in the history
  • Loading branch information
@jeapostrophe
jeapostrophe committed Jul 22, 2010
1 parent 5bb2e14 commit 9eb053d
Show file tree
Hide file tree
Showing 4 changed files with 171 additions and 2 deletions.
1 change: 1 addition & 0 deletions collects/lang/htdp-advanced.rkt
View file
Expand Up @@ -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]
Expand Down
104 changes: 104 additions & 0 deletions collects/lang/private/teach.rkt
View file
Expand Up @@ -203,6 +203,7 @@
advanced-when
advanced-unless
advanced-define-struct
advanced-define-datatype
advanced-let
advanced-recur
advanced-begin
Expand Down Expand Up @@ -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)
Expand Down
25 changes: 23 additions & 2 deletions collects/scribblings/htdp-langs/advanced.scrbl
View file
Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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[(
Expand Down
43 changes: 43 additions & 0 deletions collects/tests/racket/advanced.rktl
View file
Expand Up @@ -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)

0 comments on commit 9eb053d

Please sign in to comment.