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

368
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)
@ -48,139 +51,195 @@
(define-for-syntax (validate-and-remove-type-symbol stx-loc lst) (define-for-syntax (validate-and-remove-type-symbol stx-loc lst)
(if (and (list? lst) (eq? type-symbol (first lst))) (if (and (list? lst) (eq? type-symbol (first lst)))
(rest lst) (rest lst)
(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 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
[(_ datatype:id [(_ datatype:id
[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 ...))]) (generate-temporaries #'(variant ...))]
[(underlying-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 ...) ...))]
[datatype? [((the-field/c ...) ...)
(format-id stx "~a?" #'datatype #:source #'datatype)] (syntax-map generate-temporaries #'((field/c ...) ...))]
[(variant? ...) [datatype?
(syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))] (format-id stx "~a?" #'datatype #:source #'datatype)]
[(variant*? ...) [(variant? ...)
(syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))] (syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))]
[(make-variant ...) [(variant*? ...)
(syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))] (syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))]
[(make-variant* ...) [(make-variant ...)
(syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))]) (syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))]
[(make-variant* ...)
(syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))])
(with-syntax (with-syntax
([((f:variant? ...) ...) ([((f:variant? ...) ...)
(syntax-map (lambda (v? fs) (syntax-map (lambda (v? fs)
(syntax-map (lambda (f) v?) fs)) (syntax-map (lambda (f) v?) fs))
#'(variant? ...) #'(variant? ...)
#'((field ...) ...))] #'((field ...) ...))]
[((variant-field ...) ...) [((variant-field ...) ...)
(syntax-map (lambda (variant fields) (syntax-map (lambda (variant fields)
(syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f)) (syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f))
fields)) fields))
#'(variant ...) #'(variant ...)
#'((field ...) ...))] #'((field ...) ...))]
[((variant*-field ...) ...) [((variant*-field ...) ...)
(syntax-map (lambda (variant fields) (syntax-map (lambda (variant fields)
(syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f)) (syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f))
fields)) fields))
#'(variant* ...) #'(variant* ...)
#'((field ...) ...))] #'((field ...) ...))]
[((set-variant-field! ...) ...) [((set-variant-field! ...) ...)
(syntax-map (lambda (variant fields) (syntax-map (lambda (variant fields)
(syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f)) (syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f))
fields)) fields))
#'(variant ...) #'(variant ...)
#'((field ...) ...))] #'((field ...) ...))]
[((set-variant*-field! ...) ...) [((set-variant*-field! ...) ...)
(syntax-map (lambda (variant fields) (syntax-map (lambda (variant fields)
(syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f)) (syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f))
fields)) fields))
#'(variant* ...) #'(variant* ...)
#'((field ...) ...))]) #'((field ...) ...))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-syntax datatype (define-syntax datatype
(list type-symbol (list type-symbol
(list (list #'variant (list #'variant-field ...) #'variant?) (list (list #'variant (list #'variant-field ...) #'variant?)
...) ...)
#'datatype?)) #'datatype?))
(define-struct variant* (field ...) (define-struct variant* (field ...)
#:transparent #:transparent
#:omit-define-syntaxes #:omit-define-syntaxes
#:mutable #:mutable
#:reflection-name 'variant) #:reflection-name 'variant)
... ...
(define variant? (define variant?
variant*?) variant*?)
... ...
(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
(define make-variant ;; language AND would complicate going to a
(lambda-memocontract (field ...) ;; student-language based deployment
(contract (field/c ... . -> . variant?)
make-variant* ;; (define field/c-val field/c)
'make-variant 'use ;; ...
'make-variant #'variant)))
(define variant (define (the-field/c)
(lambda-memocontract (field ...) (or/c undefined?
(contract (field/c ... . -> . variant?) field/c))
make-variant* ...
'variant 'use
'variant #'variant))) (define make-variant
(define variant-field (lambda-memocontract (field ...)
(lambda-memocontract (v) (contract ((the-field/c) ... . -> . variant?)
(contract (f:variant? . -> . field/c) make-variant*
variant*-field 'make-variant 'use
'variant-field 'use 'make-variant #'variant)))
'variant-field #'field))) (define underlying-variant
... (lambda-memocontract (field ...)
(define set-variant-field! (contract ((the-field/c) ... . -> . variant?)
(lambda-memocontract (v nv) make-variant*
(contract (f:variant? field/c . -> . void) 'variant 'use
set-variant*-field! 'variant #'variant)))
'set-variant-field! 'use (define-syntax
'set-variant-field! #'field))) 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
(lambda-memocontract (v)
(contract (f:variant? . -> . (the-field/c))
variant*-field
'variant-field 'use
'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)))
...
)
...)))))]))
(define-syntax-rule (lambda-memocontract (field ...) c-expr) (define-syntax-rule (lambda-memocontract (field ...) c-expr)
(let ([cd #f]) (let ([cd #f])
@ -261,15 +320,15 @@
(syntax-case stx () (syntax-case stx ()
[(_ (binding-name ...) case-variant-id ((variant-id (selector-id ...) ___) . rest) value-id body-expr) [(_ (binding-name ...) case-variant-id ((variant-id (selector-id ...) ___) . rest) value-id body-expr)
(if (free-identifier=? #'case-variant-id #'variant-id) (if (free-identifier=? #'case-variant-id #'variant-id)
#'(let ([binding-name (selector-id value-id)] #'(let ([binding-name (selector-id value-id)]
...) ...)
body-expr) body-expr)
#'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))])) #'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))]))
(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))
@ -299,18 +358,18 @@
#`(let ([expr test-expr]) #`(let ([expr test-expr])
(if (not (#,type? expr)) (if (not (#,type? expr))
#,(syntax/loc #'test-expr #,(syntax/loc #'test-expr
(error 'type-case "expected a value from type ~a, got: ~a" (error 'type-case "expected a value from type ~a, got: ~a"
'type-id 'type-id
expr)) expr))
(cond (cond
[(let ([variant-info (lookup-variant variant #,type-info)]) [(let ([variant-info (lookup-variant variant #,type-info)])
((second variant-info) expr)) ((second variant-info) expr))
(bind-fields-in (field ...) variant #,type-info expr case-expr)] (bind-fields-in (field ...) variant #,type-info expr case-expr)]
... ...
[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,34 +379,34 @@
[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))
#`(let ([expr test-expr]) #`(let ([expr test-expr])
(if (not (#,type? expr)) (if (not (#,type? expr))
#,(syntax/loc #'test-expr #,(syntax/loc #'test-expr
(error 'type-case "expected a value from type ~a, got: ~a" (error 'type-case "expected a value from type ~a, got: ~a"
'type-id 'type-id
expr)) expr))
(cond (cond
[(let ([variant-info (lookup-variant variant #,type-info)]) [(let ([variant-info (lookup-variant variant #,type-info)])
((second variant-info) expr)) ((second variant-info) expr))
(bind-fields-in (field ...) variant #,type-info expr case-expr)] (bind-fields-in (field ...) variant #,type-info expr case-expr)]
... ...
[else (error 'type-case bug:fallthru-no-else)]))))] [else (error 'type-case bug:fallthru-no-else)]))))]
;;; The remaining clauses are for error reporting only. If we got this ;;; The remaining clauses are for error reporting only. If we got this
;;; far, either the clauses are malformed or the error is completely ;;; far, either the clauses are malformed or the error is completely
;;; unintelligible. ;;; unintelligible.
@ -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))