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

Fix PR 14614

Browse Source
This commit is contained in:
Jay McCarthy 2014-07-17 16:34:11 -04:00
parent 7f0f5f029b
commit 6df9cd29dd
1 changed files with 134 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

209
pkgs/plai/datatype.rkt
View File

@ -56,11 +56,62 @@
(plai-syntax-error 'type-case stx-loc type-case:not-a-type))) (plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
(require (for-syntax syntax/parse (require (for-syntax syntax/parse
racket/syntax syntax/stx syntax/stx
racket/string
racket/match
(only-in racket/function curry))) (only-in racket/function curry)))
(define-for-syntax (syntax-string s) (begin-for-syntax
(symbol->string (syntax-e s))) (define SRBS null)
(define (CLEAR-SRBS!)
(set! SRBS null))
(define (GRAB-SRBS)
SRBS)
(define (format-id lctx fmt #:source src . v)
(define-values
(fmt+vs-strs final-make-srbs)
(let loop ([l (string->list fmt)]
[v v]
[here 0]
[ss empty]
[make-srbs (λ () null)])
(match l
[(list* #\~ #\a more)
(define first-v (first v))
(define first-s (format "~a" (syntax->datum first-v)))
(define first-len (string-length first-s))
(loop more (rest v) (+ here first-len)
(cons first-s ss)
(if (syntax-source first-v)
(λ ()
(cons (vector (syntax-local-introduce this-id)
here first-len
(syntax-local-introduce first-v)
0 first-len)
(make-srbs)))
make-srbs))]
[(list* other more)
(loop more v (+ here 1)
(cons (string other) ss)
make-srbs)]
[(list)
(values (reverse ss) make-srbs)])))
(define fmt+vs-str
(string-append* fmt+vs-strs))
(define fmt+vs-sym
(string->symbol fmt+vs-str))
(define this-id
(datum->syntax lctx fmt+vs-sym src))
(define srbs
(final-make-srbs))
(printf "~v -> ~v\n"
this-id srbs)
(set! SRBS (cons srbs SRBS))
this-id)
(define (syntax-string s)
(symbol->string (syntax-e s))))
;; XXX Copied from racket/private/define-struct ;; XXX Copied from racket/private/define-struct
(begin-for-syntax (begin-for-syntax
@ -110,6 +161,9 @@
;; Ensure type and variant names are unbound ;; Ensure type and variant names are unbound
(map (assert-unbound 'define-type) (map (assert-unbound 'define-type)
(cons #'datatype? (syntax->list #'(variant ...)))) (cons #'datatype? (syntax->list #'(variant ...))))
(CLEAR-SRBS!)
(with-syntax (with-syntax
([(variant* ...) ([(variant* ...)
(generate-temporaries #'(variant ...))] (generate-temporaries #'(variant ...))]
@ -164,81 +218,86 @@
#'(variant* ...) #'(variant* ...)
#'((field ...) ...))]) #'((field ...) ...))])
(syntax/loc stx (define srbs (GRAB-SRBS))
(begin
(define-syntax datatype
(list type-symbol
(list (list #'variant (list #'variant-field ...) #'variant?)
...)
#'datatype?))
(define-struct variant* (field ...)
#:transparent
#:omit-define-syntaxes
#:mutable
#:reflection-name 'variant)
...
(define variant?
variant*?)
...
(define (datatype? x)
(or (variant? x) ...))
(begin
;; If this is commented in, then contracts will be
;; checked early. However, this will disallow mutual
;; recursion, which PLAI relies on. It could be
;; allowed if we could have module-begin cooperate
;; and lift the define-struct to the top-level but,
;; that would break web which doesn't use the plai
;; language AND would complicate going to a
;; student-language based deployment
;; (define field/c-val field/c) (syntax-property
;; ... (syntax/loc stx
(begin
(define-syntax datatype
(list type-symbol
(list (list #'variant (list #'variant-field ...) #'variant?)
...)
#'datatype?))
(define-struct variant* (field ...)
#:transparent
#:omit-define-syntaxes
#:mutable
#:reflection-name 'variant)
...
(define variant?
variant*?)
...
(define (datatype? x)
(or (variant? x) ...))
(begin
;; If this is commented in, then contracts will be
;; checked early. However, this will disallow mutual
;; recursion, which PLAI relies on. It could be
;; allowed if we could have module-begin cooperate
;; and lift the define-struct to the top-level but,
;; that would break web which doesn't use the plai
;; language AND would complicate going to a
;; student-language based deployment
(define (the-field/c) ;; (define field/c-val field/c)
(or/c undefined? ;; ...
field/c))
...
(define make-variant (define (the-field/c)
(lambda-memocontract (field ...) (or/c undefined?
(contract ((the-field/c) ... . -> . variant?) field/c))
make-variant* ...
'make-variant 'use
'make-variant #'variant))) (define make-variant
(define underlying-variant (lambda-memocontract (field ...)
(lambda-memocontract (field ...) (contract ((the-field/c) ... . -> . variant?)
(contract ((the-field/c) ... . -> . variant?) make-variant*
make-variant* 'make-variant 'use
'variant 'use 'make-variant #'variant)))
'variant #'variant))) (define underlying-variant
(define-syntax (lambda-memocontract (field ...)
variant (contract ((the-field/c) ... . -> . variant?)
(self-ctor-checked-struct-info make-variant*
(λ () 'variant 'use
(list #'struct:variant* 'variant #'variant)))
#'make-variant* (define-syntax
#'variant*? variant
(reverse (list #'variant*-field ...)) (self-ctor-checked-struct-info
(reverse (list #'set-variant*-field! ...)) (λ ()
#t)) (list #'struct:variant*
(λ () #'underlying-variant))) #'make-variant*
(define variant-field #'variant*?
(lambda-memocontract (v) (reverse (list #'variant*-field ...))
(contract (f:variant? . -> . (the-field/c)) (reverse (list #'set-variant*-field! ...))
variant*-field #t))
'variant-field 'use (λ () #'underlying-variant)))
'variant-field #'field))) (define variant-field
... (lambda-memocontract (v)
(define set-variant-field! (contract (f:variant? . -> . (the-field/c))
(lambda-memocontract (v nv) variant*-field
(contract (f:variant? (the-field/c) . -> . void) 'variant-field 'use
set-variant*-field! 'variant-field #'field)))
'set-variant-field! 'use ...
'set-variant-field! #'field))) (define set-variant-field!
... (lambda-memocontract (v nv)
) (contract (f:variant? (the-field/c) . -> . void)
...)))))])) set-variant*-field!
'set-variant-field! 'use
'set-variant-field! #'field)))
...
)
...))
'sub-range-binders
srbs))))]))
(define-syntax-rule (lambda-memocontract (field ...) c-expr) (define-syntax-rule (lambda-memocontract (field ...) c-expr)
(let ([cd #f]) (let ([cd #f])