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

Correcting bug discovered by Arjun

Browse Source
This commit is contained in:
Jay McCarthy 2010-09-02 07:03:50 -06:00
parent 3097bb85b7
commit f272acec5f
2 changed files with 26 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/plai/datatype.rkt
View File

@ -59,8 +59,6 @@
(symbol->string (syntax-e s)))
(define-syntax (define-type stx)
(define (format-id/std fmt x)
(format-id stx fmt #:source x x))
(syntax-parse
stx
[(_ datatype:id
@ -82,23 +80,21 @@
(cons #'datatype? (syntax->list #'(variant ...))))
(with-syntax
([(variant* ...)
(map (lambda (s)
(datum->syntax stx (syntax->datum s)))
(generate-temporaries #'(variant ...)))])
(generate-temporaries #'(variant ...))])
(with-syntax
([((field/c-val ...) ...)
(syntax-map generate-temporaries #'((field/c ...) ...))]
[datatype?
(format-id/std "~a?" #'datatype)]
(format-id stx "~a?" #'datatype #:source #'datatype)]
[(variant? ...)
(syntax-map (curry format-id/std "~a?") #'(variant ...))]
(syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))]
[(variant*? ...)
(syntax-map (curry format-id/std "~a?") #'(variant* ...))]
(syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))]
[(make-variant ...)
(syntax-map (curry format-id/std "make-~a") #'(variant ...))]
(syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))]
[(make-variant* ...)
(syntax-map (curry format-id/std "make-~a") #'(variant* ...))])
(syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))])
(with-syntax
([((f:variant? ...) ...)
@ -108,26 +104,26 @@
#'((field ...) ...))]
[((variant-field ...) ...)
(syntax-map (lambda (variant fields)
(syntax-map (curry format-id/std (string-append (syntax-string variant) "-~a"))
(syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f))
fields))
#'(variant ...)
#'((field ...) ...))]
[((variant*-field ...) ...)
(syntax-map (lambda (variant fields)
(syntax-map (curry format-id/std (string-append (syntax-string variant) "-~a"))
(syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f))
fields))
#'(variant* ...)
#'((field ...) ...))]
[((set-variant-field! ...) ...)
(syntax-map (lambda (variant fields)
(syntax-map (curry format-id/std (string-append "set-" (syntax-string variant) "-~a!"))
(syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f))
fields))
#'(variant ...)
#'((field ...) ...))]
[((set-variant*-field! ...) ...)
(syntax-map (lambda (variant fields)
(syntax-map (curry format-id/std (string-append "set-" (syntax-string variant) "-~a!"))
(syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f))
fields))
#'(variant* ...)
#'((field ...) ...))])

16
collects/tests/plai/datatype-exports.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/load
(require tests/eli-tester)
(module ex plai
(define-type Type
[Variant (field number?)]))
(define-syntax (exports-of stx)
(syntax-case stx ()
[(_ module-name)
(let ([exports (syntax-local-module-exports (syntax->datum #'module-name))])
#`(quote #,(cdaddr exports)))]))
(test (exports-of 'ex)
=>
'(Type set-Variant-field! make-Variant Variant? Variant-field Variant Type?))