From c8ff0afa0255c9fd620861a4aa66c0d0a43b36e5 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Mon, 20 Jun 2016 15:14:20 -0400
Subject: [PATCH] implement stlc+box and stlc+effect with typed-lang-builder

---
 tapl/stlc+effect.rkt                    |  24 ++---
 tapl/tests/rackunit-typechecking.rkt    |   8 +-
 tapl/tests/stlc+box-tests.rkt           |   6 +-
 tapl/tests/stlc+effect-tests.rkt        |  10 +-
 tapl/typed-lang-builder/stlc+box.rkt    |  32 +++++++
 tapl/typed-lang-builder/stlc+effect.rkt | 118 ++++++++++++++++++++++++
 6 files changed, 174 insertions(+), 24 deletions(-)
 create mode 100644 tapl/typed-lang-builder/stlc+box.rkt
 create mode 100644 tapl/typed-lang-builder/stlc+effect.rkt

diff --git a/tapl/stlc+effect.rkt b/tapl/stlc+effect.rkt
index 4012d64..b9e71e9 100644
--- a/tapl/stlc+effect.rkt
+++ b/tapl/stlc+effect.rkt
@@ -12,9 +12,9 @@
 ;; - ref deref :=
 
 (begin-for-syntax 
-  (define (add-news e locs) (syntax-property e 'new locs))
-  (define (add-assigns e locs) (syntax-property e 'assign locs))
-  (define (add-derefs e locs) (syntax-property e 'deref locs))
+  (define (add-news e locs) (syntax-property e 'ν locs))
+  (define (add-assigns e locs) (syntax-property e ':= locs))
+  (define (add-derefs e locs) (syntax-property e '! locs))
   (define (add-effects e new-locs assign-locs deref-locs)
     (add-derefs
      (add-assigns
@@ -27,16 +27,16 @@
          (local-expand (if (null? vs) e #`(stlc+box:λ #,vs #,e)) 'expression null)
          tag)
         null))
-  (define (get-new-effects e [vs '()]) (get-effects e 'new vs))
-  (define (get-assign-effects e [vs '()]) (get-effects e 'assign vs))
-  (define (get-deref-effects e [vs '()]) (get-effects e 'deref vs))
+  (define (get-new-effects e [vs '()]) (get-effects e 'ν vs))
+  (define (get-assign-effects e [vs '()]) (get-effects e ':= vs))
+  (define (get-deref-effects e [vs '()]) (get-effects e '! vs))
   
   (define (print-effects e)
     (printf "expr ~a\n" (syntax->datum e))
     (define e+ (local-expand e 'expression null))
-    (printf "new locs: ~a\n" (syntax-property e+ 'new))
-    (printf "deref locs: ~a\n" (syntax-property e+ 'deref))
-    (printf "assign locs: ~a\n" (syntax-property e+ 'assign)))
+    (printf "new locs: ~a\n" (syntax-property e+ 'ν))
+    (printf "deref locs: ~a\n" (syntax-property e+ '!))
+    (printf "assign locs: ~a\n" (syntax-property e+ ':=)))
   
   (define (loc-union locs1 locs2)
     (cond
@@ -128,11 +128,11 @@
                     (stx-append #'ds1 #'ds2))])
 ;(define-typed-syntax ref
 ;  [(_ e)
-;   (syntax-property #'(stlc+box:ref e) 'new (set (syntax-position stx)))])
+;   (syntax-property #'(stlc+box:ref e) 'ν (set (syntax-position stx)))])
 ;(define-typed-syntax deref
 ;  [(_ e)
-;   (syntax-property #'(stlc+box:deref e) 'deref (set (syntax-position stx)))])
+;   (syntax-property #'(stlc+box:deref e) '! (set (syntax-position stx)))])
 ;(define-typed-syntax :=
 ;  [(_ e_ref e)
-;   (syntax-property #'(stlc+box::= e_ref e) 'assign (set (syntax-position stx)))])
+;   (syntax-property #'(stlc+box::= e_ref e) ':= (set (syntax-position stx)))])
 
diff --git a/tapl/tests/rackunit-typechecking.rkt b/tapl/tests/rackunit-typechecking.rkt
index 64bff9a..ef9a62d 100644
--- a/tapl/tests/rackunit-typechecking.rkt
+++ b/tapl/tests/rackunit-typechecking.rkt
@@ -41,15 +41,15 @@
 ;; for checking properties other than types
 (define-syntax (check-props stx)
   (syntax-parse stx #:datum-literals (: ⇒ ->)
-    [(_ prop e : v ... (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e])))
+    [(_ prop e : v (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e])))
      #:with props (or (syntax-property (expand/df #'e) (syntax->datum #'prop))
                       #'())
-     #:fail-unless (set=? (apply set (syntax->datum #'(v ...)))
-                          (apply set (syntax->datum #'props)))
+     #:fail-unless (equal? (syntax->datum #'v)
+                           (syntax->datum #'props))
      (format
       "Expression ~a [loc ~a:~a:~a] does not have prop ~a, actual: ~a"
       (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) (syntax-position #'e)
-      (syntax->datum #'(v ...)) (syntax->datum #'props))
+      (syntax->datum #'v) (syntax->datum #'props))
      (syntax/loc stx (check-equal? e v2))]))
 
 (define-syntax (check-not-type stx)
diff --git a/tapl/tests/stlc+box-tests.rkt b/tapl/tests/stlc+box-tests.rkt
index 2e14b36..fdc6d84 100644
--- a/tapl/tests/stlc+box-tests.rkt
+++ b/tapl/tests/stlc+box-tests.rkt
@@ -1,4 +1,4 @@
-#lang s-exp "../stlc+box.rkt"
+#lang s-exp "../typed-lang-builder/stlc+box.rkt"
 (require "rackunit-typechecking.rkt")
 
 (define x (ref 10))
@@ -26,11 +26,11 @@
 (typecheck-fail
  (deref 1)
  #:with-msg
- "Expected expression 1 to have Ref type, got: Int")
+ "Expected Ref type, got: Int")
 (typecheck-fail
  (:= 1 1)
  #:with-msg
- "Expected expression 1 to have Ref type, got: Int")
+ "Expected Ref type, got: Int")
 
 ;; previous tests: ------------------------------------------------------------
 (typecheck-fail (cons 1 2))
diff --git a/tapl/tests/stlc+effect-tests.rkt b/tapl/tests/stlc+effect-tests.rkt
index 9ce7a73..06a29bf 100644
--- a/tapl/tests/stlc+effect-tests.rkt
+++ b/tapl/tests/stlc+effect-tests.rkt
@@ -1,10 +1,10 @@
-#lang s-exp "../stlc+effect.rkt"
+#lang s-exp "../typed-lang-builder/stlc+effect.rkt"
 (require "rackunit-typechecking.rkt")
 
-(check-props new (ref 11) : 90)
-(check-props deref (deref (ref 11)) : 124)
-(check-props new (deref (ref 11)) : 172)
-(check-props new ((λ ([x : Int]) (ref x)) 21) : 222)
+(check-props ν (ref 11) : '(107))
+(check-props ! (deref (ref 11)) : '(141))
+(check-props ν (deref (ref 11)) : '(190))
+(check-props ν ((λ ([x : Int]) (ref x)) 21) : '(241))
              
 (define x (ref 10))
 (check-type x : (Ref Int))
diff --git a/tapl/typed-lang-builder/stlc+box.rkt b/tapl/typed-lang-builder/stlc+box.rkt
new file mode 100644
index 0000000..c87e120
--- /dev/null
+++ b/tapl/typed-lang-builder/stlc+box.rkt
@@ -0,0 +1,32 @@
+#lang macrotypes/tapl/typed-lang-builder
+(extends "stlc+cons.rkt")
+
+;; Simply-Typed Lambda Calculus, plus mutable references
+;; Types:
+;; - types from stlc+cons.rkt
+;; - Ref constructor
+;; Terms:
+;; - terms from stlc+cons.rkt
+;; - ref deref :=
+
+(define-type-constructor Ref)
+
+(define-typed-syntax ref
+  [(ref e) ▶
+   [⊢ [[e ≫ e-] ⇒ (: τ)]]
+   --------
+   [⊢ [[_ ≫ (box- e-)] ⇒ (: (Ref τ))]]])
+
+(define-typed-syntax deref
+  [(deref e) ▶
+   [⊢ [[e ≫ e-] ⇒ (: (~Ref τ))]]
+   --------
+   [⊢ [[_ ≫ (unbox- e-)] ⇒ (: τ)]]])
+
+(define-typed-syntax := #:literals (:=)
+  [(:= e_ref e) ▶
+   [⊢ [[e_ref ≫ e_ref-] ⇒ (: (~Ref τ))]]
+   [⊢ [[e ≫ e-] ⇐ (: τ)]]
+   --------
+   [⊢ [[_ ≫ (set-box!- e_ref- e-)] ⇒ (: Unit)]]])
+
diff --git a/tapl/typed-lang-builder/stlc+effect.rkt b/tapl/typed-lang-builder/stlc+effect.rkt
new file mode 100644
index 0000000..15d18b3
--- /dev/null
+++ b/tapl/typed-lang-builder/stlc+effect.rkt
@@ -0,0 +1,118 @@
+#lang macrotypes/tapl/typed-lang-builder
+(extends "stlc+box.rkt" #:except ref deref := #%app λ)
+
+(provide (for-syntax get-new-effects))
+
+;; Simply-Typed Lambda Calculus, plus mutable references
+;; Types:
+;; - types from stlc+cons.rkt
+;; - Ref constructor
+;; Terms:
+;; - terms from stlc+cons.rkt
+;; - ref deref :=
+
+(define-syntax-rule (locs loc ...)
+  '(loc ...))
+(begin-for-syntax
+  (define-syntax ~locs
+    (pattern-expander
+     (syntax-parser
+       [(locs loc:id ...)
+        #:with tmp (generate-temporary 'locs)
+        #'(~and tmp
+                (~parse ((~literal quote) (loc ...))
+                        (stx-or #'tmp #'(quote ()))))])))
+
+  (define (add-news e locs) (assign-type e #:tag 'ν locs))
+  (define (add-assigns e locs) (assign-type e #:tag ':= locs))
+  (define (add-derefs e locs) (assign-type e #:tag '! locs))
+  (define (add-effects e new-locs assign-locs deref-locs)
+    (add-derefs
+     (add-assigns
+      (add-news e new-locs)
+      assign-locs)
+     deref-locs))
+     
+  (define (get-effects e tag)
+    (syntax-property e tag))
+  (define (get-new-effects e) (get-effects e 'ν))
+  (define (get-assign-effects e) (get-effects e ':=))
+  (define (get-deref-effects e) (get-effects e '!))
+  
+  (define (print-effects e)
+    (printf "expr ~a\n" (syntax->datum e))
+    (define e+ (local-expand e 'expression null))
+    (printf "new locs: ~a\n" (syntax-property e+ 'ν))
+    (printf "deref locs: ~a\n" (syntax-property e+ '!))
+    (printf "assign locs: ~a\n" (syntax-property e+ ':=)))
+
+  (define (stx-cons a b)
+    (datum->syntax #f (cons a b)))
+  (define (stx-truth? a)
+    (and a (not (and (syntax? a) (false? (syntax-e a))))))
+  (define (stx-or a b)
+    (cond [(stx-truth? a) a]
+          [else b])))
+
+
+(define-typed-syntax effect:#%app #:export-as #%app
+  [(_ efn e ...) ▶
+   [⊢ [[efn ≫ e_fn-]
+       ⇒ (: ty_fn ν (~locs fns ...) := (~locs fas ...) ! (~locs fds ...))
+       ⇒ (ν (~locs tyns ...) := (~locs tyas ...) ! (~locs tyds ...))]]
+   [#:with (~→ τ_in ... τ_out) #'ty_fn]
+   [⊢ [[e ≫ e_arg-] ⇒ (: τ_arg ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))] ...]
+   [#:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...))
+    "wrong number of arguments"]
+   [τ_arg τ⊑ τ_in] ...
+   --------
+   [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)]
+       ⇒ (: τ_out
+            ν (locs fns ... tyns ... ns ... ...)
+            := (locs fas ... tyas ... as ... ...)
+            ! (locs fds ... tyds ... ds ... ...))]]])
+
+(define-typed-syntax λ
+  [(λ bvs:type-ctx e) ▶
+   [() ([bvs.x : bvs.type ≫ x-] ...) ⊢
+       [[e ≫ e-]
+        ⇒ (: τ_res ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))]]
+   --------
+   [⊢ [[_ ≫ (λ- (x- ...) e-)]
+       ⇒ (: #,(add-effects #'(→ bvs.type ... τ_res)
+                           #'(locs ns ...)
+                           #'(locs as ...)
+                           #'(locs ds ...)))]]])
+
+(define-type-constructor Ref)
+
+(define-typed-syntax ref
+  [(ref e) ▶
+   [⊢ [[e ≫ e-] ⇒ (: τ ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))]]
+   --------
+   [⊢ [[_ ≫ (box- e-)]
+       ⇒ (: (Ref τ)
+            ν (locs #,(syntax-position stx) ns ...)
+            := (locs as ...)
+            ! (locs ds ...))]]])
+(define-typed-syntax deref
+  [(deref e) ▶
+   [⊢ [[e ≫ e-] ⇒ (: (~Ref ty) ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))]]
+   --------
+   [⊢ [[_ ≫ (unbox- e-)]
+       ⇒ (: ty
+            ν (locs ns ...)
+            := (locs as ...)
+            ! (locs #,(syntax-position stx) ds ...))]]])
+(define-typed-syntax := #:literals (:=)
+  [(:= e_ref e) ▶
+   [⊢ [[e_ref ≫ e_ref-] ⇒ (: (~Ref ty1) ν (~locs ns1 ...) := (~locs as1 ...) ! (~locs ds1 ...))]]
+   [⊢ [[e ≫ e-] ⇒ (: ty2 ν (~locs ns2 ...) := (~locs as2 ...) ! (~locs ds2 ...))]]
+   [ty1 τ⊑ ty2]
+   --------
+   [⊢ [[_ ≫ (set-box!- e_ref- e-)]
+       ⇒ (: Unit
+            ν (locs ns1 ... ns2 ...)
+            := (locs #,(syntax-position stx) as1 ... as2 ...)
+            ! (locs ds1 ... ds2 ...))]]])
+