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

enabling shared in plai with some shameless copying of kernel code

Browse Source
This commit is contained in:
Jay McCarthy 2012-11-06 19:52:54 -07:00
parent c02797b121
commit b778e4e03c
3 changed files with 270 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
collects/plai/datatype.rkt
View File

@ -1,5 +1,8 @@
#lang scheme #lang racket/base
(require (for-syntax scheme/list)) (require (for-syntax racket/base
racket/list)
racket/list
racket/contract)
(provide define-type type-case) (provide define-type type-case)
@ -53,11 +56,41 @@
(require (for-syntax syntax/parse (require (for-syntax syntax/parse
racket/syntax unstable/syntax racket/syntax unstable/syntax
(only-in scheme/function curry))) (only-in racket/function curry)))
(define-for-syntax (syntax-string s) (define-for-syntax (syntax-string s)
(symbol->string (syntax-e s))) (symbol->string (syntax-e s)))
;; XXX Copied from racket/private/define-struct
(begin-for-syntax
(require racket/struct-info)
(define (transfer-srcloc orig stx)
(datum->syntax orig (syntax-e orig) stx orig))
(struct self-ctor-checked-struct-info (info renamer)
#:property prop:struct-info
(λ (i)
((self-ctor-checked-struct-info-info i)))
#:property prop:procedure
(λ (i stx)
(define orig ((self-ctor-checked-struct-info-renamer i)))
(syntax-case stx ()
[(self arg ...)
(datum->syntax
stx
(cons (syntax-property (transfer-srcloc orig #'self)
'constructor-for
(syntax-local-introduce
#'self))
(syntax-e (syntax (arg ...))))
stx
stx)]
[_ (transfer-srcloc orig stx)]))))
(define the-undefined
(letrec ([x x]) x))
(define (undefined? x)
(eq? the-undefined x))
(define-syntax (define-type stx) (define-syntax (define-type stx)
(syntax-parse (syntax-parse
stx stx
@ -65,26 +98,30 @@
[variant:id (field:id field/c:expr) ...] [variant:id (field:id field/c:expr) ...]
...) ...)
; Ensure we have at least one variant. ;; Ensure we have at least one variant.
(when (empty? (syntax->list #'(variant ...))) (when (empty? (syntax->list #'(variant ...)))
(plai-syntax-error 'define-type stx define-type:zero-variants (plai-syntax-error 'define-type stx define-type:zero-variants
(syntax-e #'datatype))) (syntax-e #'datatype)))
; Ensure variant names are unique. ;; Ensure variant names are unique.
(assert-unique #'(variant ...)) (assert-unique #'(variant ...))
; Ensure each set of fields have unique names. ;; Ensure each set of fields have unique names.
(syntax-map assert-unique #'((field ...) ...)) (syntax-map assert-unique #'((field ...) ...))
; 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 ...))))
(with-syntax (with-syntax
([(variant* ...) ([(variant* ...)
(generate-temporaries #'(variant ...))]
[(underlying-variant ...)
(generate-temporaries #'(variant ...))]) (generate-temporaries #'(variant ...))])
(with-syntax (with-syntax
([((field/c-val ...) ...) ([((field/c-val ...) ...)
(syntax-map generate-temporaries #'((field/c ...) ...))] (syntax-map generate-temporaries #'((field/c ...) ...))]
[((the-field/c ...) ...)
(syntax-map generate-temporaries #'((field/c ...) ...))]
[datatype? [datatype?
(format-id stx "~a?" #'datatype #:source #'datatype)] (format-id stx "~a?" #'datatype #:source #'datatype)]
[(variant? ...) [(variant? ...)
@ -147,34 +184,56 @@
(define (datatype? x) (define (datatype? x)
(or (variant? x) ...)) (or (variant? x) ...))
(begin (begin
; If this is commented in, then contracts will be checked early. ;; If this is commented in, then contracts will be
; However, this will disallow mutual recursion, which PLAI relies on. ;; checked early. However, this will disallow mutual
; It could be allowed if we could have module-begin cooperate and lift the define-struct to the top-level ;; recursion, which PLAI relies on. It could be
; but, that would break web which doesn't use the plai language AND would complicate going to a student-language based deployment ;; allowed if we could have module-begin cooperate
#;(define field/c-val field/c) ;; 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)
;; ...
(define (the-field/c)
(or/c undefined?
field/c))
...
(define make-variant (define make-variant
(lambda-memocontract (field ...) (lambda-memocontract (field ...)
(contract (field/c ... . -> . variant?) (contract ((the-field/c) ... . -> . variant?)
make-variant* make-variant*
'make-variant 'use 'make-variant 'use
'make-variant #'variant))) 'make-variant #'variant)))
(define variant (define underlying-variant
(lambda-memocontract (field ...) (lambda-memocontract (field ...)
(contract (field/c ... . -> . variant?) (contract ((the-field/c) ... . -> . variant?)
make-variant* make-variant*
'variant 'use 'variant 'use
'variant #'variant))) 'variant #'variant)))
(define-syntax
variant
(self-ctor-checked-struct-info
(λ ()
(list #'struct:variant*
#'make-variant*
#'variant*?
(reverse (list #'variant*-field ...))
(reverse (list #'set-variant*-field! ...))
#t))
(λ () #'underlying-variant)))
(define variant-field (define variant-field
(lambda-memocontract (v) (lambda-memocontract (v)
(contract (f:variant? . -> . field/c) (contract (f:variant? . -> . (the-field/c))
variant*-field variant*-field
'variant-field 'use 'variant-field 'use
'variant-field #'field))) 'variant-field #'field)))
... ...
(define set-variant-field! (define set-variant-field!
(lambda-memocontract (v nv) (lambda-memocontract (v nv)
(contract (f:variant? field/c . -> . void) (contract (f:variant? (the-field/c) . -> . void)
set-variant*-field! set-variant*-field!
'set-variant-field! 'use 'set-variant-field! 'use
'set-variant-field! #'field))) 'set-variant-field! #'field)))
@ -269,7 +328,7 @@
(define-syntax (type-case stx) (define-syntax (type-case stx)
(syntax-case stx (else) (syntax-case stx (else)
[(_ type-id test-expr [variant (field ...) case-expr] ... [else else-expr]) [(_ type-id test-expr [variant (field ...) case-expr] ... [else else-expr])
; Ensure that everything that should be an identifier is an identifier. ;; Ensure that everything that should be an identifier is an identifier.
(and (identifier? #'type-id) (and (identifier? #'type-id)
(andmap identifier? (syntax->list #'(variant ...))) (andmap identifier? (syntax->list #'(variant ...)))
(andmap (λ (stx) (andmap identifier? (syntax->list stx))) (andmap (λ (stx) (andmap identifier? (syntax->list stx)))
@ -279,19 +338,19 @@
[type-info (first info)] [type-info (first info)]
[type? (second info)]) [type? (second info)])
; Ensure all names are unique ;; Ensure all names are unique
(assert-unique #'(variant ...)) (assert-unique #'(variant ...))
(map assert-unique (syntax->list #'((field ...) ...))) (map assert-unique (syntax->list #'((field ...) ...)))
; Ensure variants are valid. ;; Ensure variants are valid.
(map (assert-variant type-info) (syntax->list #'(variant ...))) (map (assert-variant type-info) (syntax->list #'(variant ...)))
; Ensure field counts match. ;; Ensure field counts match.
(map (assert-field-count type-info) (map (assert-field-count type-info)
(syntax->list #'(variant ...)) (syntax->list #'(variant ...))
(syntax->list #'((field ...) ...))) (syntax->list #'((field ...) ...)))
; Ensure some variant is missing. ;; Ensure some variant is missing.
(unless (ormap (variant-missing? stx #'(variant ...)) (unless (ormap (variant-missing? stx #'(variant ...))
(map first type-info)) (map first type-info))
(plai-syntax-error 'type-case stx type-case:unreachable-else)) (plai-syntax-error 'type-case stx type-case:unreachable-else))
@ -310,7 +369,7 @@
... ...
[else else-expr]))))] [else else-expr]))))]
[(_ type-id test-expr [variant (field ...) case-expr] ...) [(_ type-id test-expr [variant (field ...) case-expr] ...)
; Ensure that everything that should be an identifier is an identifier. ;; Ensure that everything that should be an identifier is an identifier.
(and (identifier? #'type-id) (and (identifier? #'type-id)
(andmap identifier? (syntax->list #'(variant ...))) (andmap identifier? (syntax->list #'(variant ...)))
(andmap (λ (stx) (andmap identifier? (syntax->list stx))) (andmap (λ (stx) (andmap identifier? (syntax->list stx)))
@ -320,19 +379,19 @@
[type-info (first info)] [type-info (first info)]
[type? (second info)]) [type? (second info)])
; Ensure all names are unique ;; Ensure all names are unique
(assert-unique #'(variant ...)) (assert-unique #'(variant ...))
(map assert-unique (syntax->list #'((field ...) ...))) (map assert-unique (syntax->list #'((field ...) ...)))
; Ensure variants are valid. ;; Ensure variants are valid.
(map (assert-variant type-info) (syntax->list #'(variant ...))) (map (assert-variant type-info) (syntax->list #'(variant ...)))
; Ensure field counts match. ;; Ensure field counts match.
(map (assert-field-count type-info) (map (assert-field-count type-info)
(syntax->list #'(variant ...)) (syntax->list #'(variant ...))
(syntax->list #'((field ...) ...))) (syntax->list #'((field ...) ...)))
; Ensure all variants are covered ;; Ensure all variants are covered
(map (ensure-variant-present stx #'(variant ...)) (map (ensure-variant-present stx #'(variant ...))
(map first type-info)) (map first type-info))
@ -359,6 +418,3 @@
(andmap validate-clause (syntax->list #'(clauses ...))) (andmap validate-clause (syntax->list #'(clauses ...)))
(plai-syntax-error 'type-case stx "Unknown error"))] (plai-syntax-error 'type-case stx "Unknown error"))]
[_ (plai-syntax-error 'type-case stx type-case:generic)])) [_ (plai-syntax-error 'type-case stx type-case:generic)]))

4
collects/tests/plai/datatype-exports.rkt
View File

@ -11,6 +11,6 @@
(let ([exports (syntax-local-module-exports (syntax->datum #'module-name))]) (let ([exports (syntax-local-module-exports (syntax->datum #'module-name))])
#`(quote #,(cdaddr exports)))])) #`(quote #,(cdaddr exports)))]))
(test (exports-of 'ex) (test (sort (exports-of 'ex) string-ci<? #:key symbol->string)
=> =>
'(Type set-Variant-field! make-Variant Variant? Variant-field Variant Type?)) '(make-Variant set-Variant-field! Type Type? Variant Variant-field Variant?))

24
collects/tests/plai/shared.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang plai
(define-type Node
(node (data string?) (adj list?)))
(define g
(shared ([PVD (node "Providence" (list ORH BOS))]
[ORH (node "Worcester" (list PVD BOS))]
[BOS (node "Boston" (list PVD ORH))])
(list PVD ORH BOS)))
g
(define PVD (first g))
(define ORH (second g))
(define BOS (third g))
PVD
ORH
BOS
(test (node-adj PVD) (list ORH BOS))
(test (node-adj ORH) (list PVD BOS))
(test (node-adj BOS) (list PVD ORH))