From b778e4e03cfbc9384db1c84ba6bab51be5a772f8 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Tue, 6 Nov 2012 19:52:54 -0700
Subject: [PATCH] enabling shared in plai with some shameless copying of kernel
 code

---
 collects/plai/datatype.rkt               | 432 +++++++++++++----------
 collects/tests/plai/datatype-exports.rkt |   4 +-
 collects/tests/plai/shared.rkt           |  24 ++
 3 files changed, 270 insertions(+), 190 deletions(-)
 create mode 100644 collects/tests/plai/shared.rkt

diff --git a/collects/plai/datatype.rkt b/collects/plai/datatype.rkt
index f8a0eb9cbe..1c0a604c65 100644
--- a/collects/plai/datatype.rkt
+++ b/collects/plai/datatype.rkt
@@ -1,14 +1,17 @@
-#lang scheme
-(require (for-syntax scheme/list))
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/list)
+         racket/list
+         racket/contract)
 
 (provide define-type type-case)
 
 (define-for-syntax (plai-syntax-error id stx-loc format-string . args)
-  (raise-syntax-error 
+  (raise-syntax-error
    id (apply format (cons format-string args)) stx-loc))
 
 (define bug:fallthru-no-else
-  (string-append 
+  (string-append
    "You have encountered a bug in the PLAI code.  (Error: type-case "
    "fallthru on cond without an else clause.)"))
 (define-for-syntax bound-id
@@ -41,146 +44,202 @@
 (define-for-syntax (assert-unique variant-stx)
   (let ([dup-id (check-duplicate-identifier (syntax->list variant-stx))])
     (when dup-id
-      (plai-syntax-error 'define-type dup-id 
+      (plai-syntax-error 'define-type dup-id
                          define-type:duplicate-variant))))
 
 (define-for-syntax type-symbol (gensym))
 
 (define-for-syntax (validate-and-remove-type-symbol stx-loc lst)
   (if (and (list? lst) (eq? type-symbol (first lst)))
-      (rest lst)
-      (plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
+    (rest lst)
+    (plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
 
 (require (for-syntax syntax/parse
                      racket/syntax unstable/syntax
-                     (only-in scheme/function curry)))
+                     (only-in racket/function curry)))
 
 (define-for-syntax (syntax-string 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)
   (syntax-parse
-   stx
-   [(_ datatype:id
-       [variant:id (field:id field/c:expr) ...]
-       ...)
-    
-    ; Ensure we have at least one variant.
-    (when (empty? (syntax->list #'(variant ...)))
-      (plai-syntax-error 'define-type stx define-type:zero-variants
-                         (syntax-e #'datatype)))
-    
-    ; Ensure variant names are unique.
-    (assert-unique #'(variant ...))
-    ; Ensure each set of fields have unique names.
-    (syntax-map assert-unique #'((field ...) ...))
-    
-    ; Ensure type and variant names are unbound
-    (map (assert-unbound 'define-type)
-         (cons #'datatype? (syntax->list #'(variant ...))))
-    (with-syntax
-        ([(variant* ...) 
-          (generate-temporaries #'(variant ...))])
-      
-      (with-syntax
-          ([((field/c-val ...) ...)
-            (syntax-map generate-temporaries #'((field/c ...) ...))]
-           [datatype?
-            (format-id stx "~a?" #'datatype #:source #'datatype)]
-           [(variant? ...)
-            (syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))]
-           [(variant*? ...)
-            (syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))]
-           [(make-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
-            ([((f:variant? ...) ...)
-              (syntax-map (lambda (v? fs)
-                            (syntax-map (lambda (f) v?) fs))
-                          #'(variant? ...)
-                          #'((field ...) ...))]
-             [((variant-field ...) ...)
-              (syntax-map (lambda (variant fields)
-                            (syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f))
-                                        fields))
-                          #'(variant ...)
-                          #'((field ...) ...))]
-             [((variant*-field ...) ...)
-              (syntax-map (lambda (variant fields)
-                            (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 (λ (f) (format-id stx "set-~a-~a!" variant f #:source f))
-                                        fields))
-                          #'(variant ...)
-                          #'((field ...) ...))]
-             [((set-variant*-field! ...) ...)
-              (syntax-map (lambda (variant fields)
-                            (syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f))
-                                        fields))
-                          #'(variant* ...)
-                          #'((field ...) ...))])
-          
-          (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 field/c-val field/c)
-                ;...
-                (define make-variant
-                  (lambda-memocontract (field ...)
-                                       (contract (field/c ... . -> . variant?)
-                                                 make-variant*
-                                                 'make-variant 'use
-                                                 'make-variant #'variant)))
-                (define variant
-                  (lambda-memocontract (field ...)
-                                       (contract (field/c ... . -> . variant?)
-                                                 make-variant*
-                                                 'variant 'use
-                                                 'variant #'variant)))
-                (define variant-field
-                  (lambda-memocontract (v)
-                                       (contract (f:variant? . -> . field/c)
-                                                 variant*-field
-                                                 'variant-field 'use
-                                                 'variant-field #'field)))
-                ...
-                (define set-variant-field!
-                  (lambda-memocontract (v nv)
-                                       (contract (f:variant? field/c . -> . void)
-                                                 set-variant*-field!
-                                                 'set-variant-field! 'use
-                                                 'set-variant-field! #'field)))
-                ...
-                )
-              ...)))))]))
+      stx
+    [(_ datatype:id
+        [variant:id (field:id field/c:expr) ...]
+        ...)
+
+     ;; Ensure we have at least one variant.
+     (when (empty? (syntax->list #'(variant ...)))
+       (plai-syntax-error 'define-type stx define-type:zero-variants
+                          (syntax-e #'datatype)))
+
+     ;; Ensure variant names are unique.
+     (assert-unique #'(variant ...))
+     ;; Ensure each set of fields have unique names.
+     (syntax-map assert-unique #'((field ...) ...))
+
+     ;; Ensure type and variant names are unbound
+     (map (assert-unbound 'define-type)
+          (cons #'datatype? (syntax->list #'(variant ...))))
+     (with-syntax
+         ([(variant* ...)
+           (generate-temporaries #'(variant ...))]
+          [(underlying-variant ...)
+           (generate-temporaries #'(variant ...))])
+
+       (with-syntax
+           ([((field/c-val ...) ...)
+             (syntax-map generate-temporaries #'((field/c ...) ...))]
+            [((the-field/c ...) ...)
+             (syntax-map generate-temporaries #'((field/c ...) ...))]
+            [datatype?
+             (format-id stx "~a?" #'datatype #:source #'datatype)]
+            [(variant? ...)
+             (syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))]
+            [(variant*? ...)
+             (syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))]
+            [(make-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
+             ([((f:variant? ...) ...)
+               (syntax-map (lambda (v? fs)
+                             (syntax-map (lambda (f) v?) fs))
+                           #'(variant? ...)
+                           #'((field ...) ...))]
+              [((variant-field ...) ...)
+               (syntax-map (lambda (variant fields)
+                             (syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f))
+                                         fields))
+                           #'(variant ...)
+                           #'((field ...) ...))]
+              [((variant*-field ...) ...)
+               (syntax-map (lambda (variant fields)
+                             (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 (λ (f) (format-id stx "set-~a-~a!" variant f #:source f))
+                                         fields))
+                           #'(variant ...)
+                           #'((field ...) ...))]
+              [((set-variant*-field! ...) ...)
+               (syntax-map (lambda (variant fields)
+                             (syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f))
+                                         fields))
+                           #'(variant* ...)
+                           #'((field ...) ...))])
+
+           (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 field/c-val field/c)
+                 ;; ...
+
+                 (define (the-field/c)
+                   (or/c undefined?
+                         field/c))
+                 ...
+
+                 (define make-variant
+                   (lambda-memocontract (field ...)
+                                        (contract ((the-field/c) ... . -> . variant?)
+                                                  make-variant*
+                                                  'make-variant 'use
+                                                  'make-variant #'variant)))
+                 (define underlying-variant
+                   (lambda-memocontract (field ...)
+                                        (contract ((the-field/c) ... . -> . variant?)
+                                                  make-variant*
+                                                  'variant 'use
+                                                  '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
+                   (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)
   (let ([cd #f])
@@ -189,10 +248,10 @@
         (set! cd c-expr))
       (cd field ...))))
 
-;;; Asserts that variant-id-stx is a variant of the type described by 
+;;; Asserts that variant-id-stx is a variant of the type described by
 ;;; type-stx.
 (define-for-syntax ((assert-variant type-info) variant-id-stx)
-  (unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx)) 
+  (unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx))
                  (map first type-info))
     (plai-syntax-error 'type-case variant-id-stx type-case:not-a-variant)))
 
@@ -204,13 +263,13 @@
                        (length (second type))))
                 type-info)])
     (unless (= field-count (length (syntax->list field-stx)))
-      (plai-syntax-error 'type-case variant-id-stx type-case:argument-count 
+      (plai-syntax-error 'type-case variant-id-stx type-case:argument-count
                          field-count (length (syntax->list field-stx))))))
 
 (define-for-syntax ((ensure-variant-present stx-loc variants) variant)
   (unless (ormap (λ (id-stx) (free-identifier=? variant id-stx))
                  (syntax->list variants))
-    (plai-syntax-error 'type-case stx-loc type-case:missing-variant 
+    (plai-syntax-error 'type-case stx-loc type-case:missing-variant
                        (syntax->datum variant))))
 
 (define-for-syntax ((variant-missing? stx-loc variants) variant)
@@ -234,14 +293,14 @@
        [(not (identifier? #'variant))
         (plai-syntax-error 'type-case #'variant
                            "this must be the name of a variant")]
-       [(ormap (λ (stx) 
+       [(ormap (λ (stx)
                  (and (not (identifier? stx)) stx)) (syntax->list #'(field ...)))
         => (λ (malformed-field)
              (plai-syntax-error
               'type-case malformed-field
               "this must be an identifier that names the value of a field"))]
        [(not (= (length (syntax->list #'(body ...))) 1))
-        (plai-syntax-error 
+        (plai-syntax-error
          'type-case clause-stx
          (string-append
           "there must be just one body expression in a clause, but you "
@@ -252,7 +311,7 @@
      (plai-syntax-error
       'type-case clause-stx
       "this case is missing a body expression")]
-    [_ 
+    [_
      (plai-syntax-error
       'type-case clause-stx
       "this case is missing a field list (possibly an empty field list)")]))
@@ -261,15 +320,15 @@
   (syntax-case stx ()
     [(_ (binding-name ...) case-variant-id ((variant-id (selector-id ...) ___) . rest) value-id body-expr)
      (if (free-identifier=? #'case-variant-id #'variant-id)
-         #'(let ([binding-name (selector-id value-id)]
-                 ...)
-             body-expr)
-         #'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))]))
+       #'(let ([binding-name (selector-id value-id)]
+               ...)
+           body-expr)
+       #'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))]))
 
 (define-syntax (type-case stx)
   (syntax-case stx (else)
     [(_ 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)
           (andmap identifier? (syntax->list #'(variant ...)))
           (andmap (λ (stx) (andmap identifier? (syntax->list stx)))
@@ -278,76 +337,76 @@
                    #'type-id (syntax-local-value #'type-id (λ () #f)))]
             [type-info (first info)]
             [type? (second info)])
-       
-       ; Ensure all names are unique
+
+       ;; Ensure all names are unique
        (assert-unique #'(variant ...))
        (map assert-unique (syntax->list #'((field ...) ...)))
-       
-       ; Ensure variants are valid.
+
+       ;; Ensure variants are valid.
        (map (assert-variant type-info) (syntax->list #'(variant ...)))
-       
-       ; Ensure field counts match.
-       (map (assert-field-count type-info) 
+
+       ;; Ensure field counts match.
+       (map (assert-field-count type-info)
             (syntax->list #'(variant ...))
             (syntax->list #'((field ...) ...)))
-       
-       ; Ensure some variant is missing.
-       (unless (ormap (variant-missing? stx #'(variant ...)) 
+
+       ;; Ensure some variant is missing.
+       (unless (ormap (variant-missing? stx #'(variant ...))
                       (map first type-info))
          (plai-syntax-error 'type-case stx type-case:unreachable-else))
-       
-       
+
+
        #`(let ([expr test-expr])
            (if (not (#,type? expr))
-               #,(syntax/loc #'test-expr 
-                   (error 'type-case "expected a value from type ~a, got: ~a"
-                          'type-id
-                          expr))
-               (cond
-                 [(let ([variant-info (lookup-variant variant #,type-info)])
-                    ((second variant-info) expr))
-                  (bind-fields-in (field ...) variant #,type-info expr case-expr)]
-                 ...
-                 [else else-expr]))))]
+             #,(syntax/loc #'test-expr
+                 (error 'type-case "expected a value from type ~a, got: ~a"
+                        'type-id
+                        expr))
+             (cond
+               [(let ([variant-info (lookup-variant variant #,type-info)])
+                  ((second variant-info) expr))
+                (bind-fields-in (field ...) variant #,type-info expr case-expr)]
+               ...
+               [else else-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)
           (andmap identifier? (syntax->list #'(variant ...)))
           (andmap (λ (stx) (andmap identifier? (syntax->list stx)))
                   (syntax->list #'((field ...) ...))))
-     (let* ([info (validate-and-remove-type-symbol 
+     (let* ([info (validate-and-remove-type-symbol
                    #'type-id (syntax-local-value #'type-id (λ () #f)))]
             [type-info (first info)]
             [type? (second info)])
-       
-       ; Ensure all names are unique
+
+       ;; Ensure all names are unique
        (assert-unique #'(variant ...))
        (map assert-unique (syntax->list #'((field ...) ...)))
-       
-       ; Ensure variants are valid.
+
+       ;; Ensure variants are valid.
        (map (assert-variant type-info) (syntax->list #'(variant ...)))
-       
-       ; Ensure field counts match.
-       (map (assert-field-count type-info) 
+
+       ;; Ensure field counts match.
+       (map (assert-field-count type-info)
             (syntax->list #'(variant ...))
             (syntax->list #'((field ...) ...)))
-       
-       ; Ensure all variants are covered
+
+       ;; Ensure all variants are covered
        (map (ensure-variant-present stx #'(variant ...))
             (map first type-info))
-       
+
        #`(let ([expr test-expr])
            (if (not (#,type? expr))
-               #,(syntax/loc #'test-expr 
-                   (error 'type-case "expected a value from type ~a, got: ~a"
-                          'type-id
-                          expr))
-               (cond
-                 [(let ([variant-info (lookup-variant variant #,type-info)])
-                    ((second variant-info) expr))
-                  (bind-fields-in (field ...) variant #,type-info expr case-expr)]
-                 ...
-                 [else (error 'type-case bug:fallthru-no-else)]))))]
+             #,(syntax/loc #'test-expr
+                 (error 'type-case "expected a value from type ~a, got: ~a"
+                        'type-id
+                        expr))
+             (cond
+               [(let ([variant-info (lookup-variant variant #,type-info)])
+                  ((second variant-info) expr))
+                (bind-fields-in (field ...) variant #,type-info expr case-expr)]
+               ...
+               [else (error 'type-case bug:fallthru-no-else)]))))]
     ;;; The remaining clauses are for error reporting only.  If we got this
     ;;; far, either the clauses are malformed or the error is completely
     ;;; unintelligible.
@@ -359,6 +418,3 @@
        (andmap validate-clause (syntax->list #'(clauses ...)))
        (plai-syntax-error 'type-case stx "Unknown error"))]
     [_ (plai-syntax-error 'type-case stx type-case:generic)]))
-
-
-
diff --git a/collects/tests/plai/datatype-exports.rkt b/collects/tests/plai/datatype-exports.rkt
index 75d9c52b21..7a89dde775 100644
--- a/collects/tests/plai/datatype-exports.rkt
+++ b/collects/tests/plai/datatype-exports.rkt
@@ -11,6 +11,6 @@
     (let ([exports (syntax-local-module-exports (syntax->datum #'module-name))])
       #`(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?))
diff --git a/collects/tests/plai/shared.rkt b/collects/tests/plai/shared.rkt
new file mode 100644
index 0000000000..4bd806891c
--- /dev/null
+++ b/collects/tests/plai/shared.rkt
@@ -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))