implement ext-stlc and stlc+tup with typed-lang-builder

tapl/tests/ext-stlc-tests.rkt

@@ -1,4 +1,4 @@
-#lang s-exp "../ext-stlc.rkt"
+#lang s-exp "../typed-lang-builder/ext-stlc.rkt"
 (require "rackunit-typechecking.rkt")
 
 ;; tests for stlc extensions
@@ -14,10 +14,10 @@
 
 (typecheck-fail
  ((λ ([x : Unit]) x) 2)
- #:with-msg (expected "Unit" #:given "Int"))
+ #:with-msg "expected: +Unit\n *given: +Int")
 (typecheck-fail
  ((λ ([x : Unit]) x) void)
-  #:with-msg (expected "Unit" #:given "(→ Unit)"))
+  #:with-msg "expected: +Unit\n *given: +\\(→ Unit\\)")
 
 (check-type ((λ ([x : Unit]) x) (void)) : Unit)
 
@@ -41,12 +41,14 @@
 ;;ascription
 (check-type (ann 1 : Int) : Int ⇒ 1)
 (check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10)
-(typecheck-fail (ann 1 : Bool) #:with-msg "ann: 1 does not have type Bool")
+(typecheck-fail (ann 1 : Bool)
+                #:with-msg "ann: type mismatch: expected Bool, given Int\n *expression: 1")
 ;ann errs
 (typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier")
 (typecheck-fail (ann 1 : 1) #:with-msg "not a valid type")
 (typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type")
-(typecheck-fail (ann Int : Int) #:with-msg "does not have type Int")
+(typecheck-fail (ann Int : Int)
+                #:with-msg "ann: type mismatch: expected Int, given #%type\n *expression: Int")
 
 ; let
 (check-type (let () (+ 1 1)) : Int ⇒ 2)
@@ -54,24 +56,24 @@
 (check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30)
 (typecheck-fail
  (let ([x #f]) (+ x 1))
- #:with-msg (expected "Int, Int" #:given "Bool, Int"))
+ #:with-msg "expected: +Int, Int\n *given: +Bool, Int\n *expressions: x, 1")
 (typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))
                 #:with-msg "x: unbound identifier")
 
 (check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21)
 (typecheck-fail
  (let* ([x #t] [y (+ x 1)]) 1)
-  #:with-msg (expected "Int, Int" #:given "Bool, Int"))
+  #:with-msg "expected: +Int, Int\n *given: +Bool, Int\n *expressions: x, 1")
 
 ; letrec
 (typecheck-fail
  (letrec ([(x : Int) #f] [(y : Int) 1]) y)
  #:with-msg
- "letrec: type check fail, args have wrong type:\n#f has type Bool, expected Int")
+ "letrec: type mismatch\n *expected: +Int, Int\n *given: +Bool, Int\n *expressions: #f, 1")
 (typecheck-fail
  (letrec ([(y : Int) 1] [(x : Int) #f]) x)
  #:with-msg
- "letrec: type check fail, args have wrong type:.+#f has type Bool, expected Int")
+ "letrec: type mismatch\n *expected: +Int, Int\n *given: +Int, Bool\n *expressions: 1, #f")
 
 (check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3)
 
@@ -99,19 +101,20 @@
 ;; check some more err msgs
 (typecheck-fail
  (and "1" #f)
- #:with-msg "Expected expression \"1\" to have Bool type, got: String")
+ #:with-msg
+ "and: type mismatch: expected Bool, given String\n *expression: \"1\"")
 (typecheck-fail
  (and #t "2")
  #:with-msg
- "Expected expression \"2\" to have Bool type, got: String")
+ "and: type mismatch: expected Bool, given String\n *expression: \"2\"")
 (typecheck-fail
  (or "1" #f)
  #:with-msg
- "Expected expression \"1\" to have Bool type, got: String")
+ "or: type mismatch\n *expected: +Bool, Bool\n *given: +String, Bool\n *expressions: \"1\", #f")
 (typecheck-fail
  (or #t "2")
  #:with-msg
- "Expected expression \"2\" to have Bool type, got: String")
+ "or: type mismatch\n *expected: +Bool, Bool\n *given: +Bool, String\n *expressions: #t, \"2\"")
 ;; 2016-03-10: change if to work with non-false vals
 (check-type (if "true" 1 2) : Int -> 1)
 (typecheck-fail
@@ -133,12 +136,12 @@
 
 (typecheck-fail
  ((λ ([x : Bool]) x) 1)
- #:with-msg (expected "Bool" #:given "Int"))
+ #:with-msg "expected: +Bool\n *given: +Int\n *expressions: +1")
 ;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type
 (typecheck-fail
  (λ ([f : Int]) (f 1 2))
  #:with-msg
- "Expected expression f to have → type, got: Int")
+ "Expected → type, got: Int")
 
 (check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y))
             : (→ (→ Int Int Int) Int Int Int))
@@ -147,14 +150,13 @@
 
 (typecheck-fail
  (+ 1 (λ ([x : Int]) x))
- #:with-msg (expected "Int, Int" #:given "Int, (→ Int Int)"))
+ #:with-msg "expected: +Int, Int\n *given: +Int, \\(→ Int Int\\)")
 (typecheck-fail
  (λ ([x : (→ Int Int)]) (+ x x))
-  #:with-msg (expected "Int, Int" #:given "(→ Int Int), (→ Int Int)"))
+  #:with-msg "expected: +Int, Int\n *given: +\\(→ Int Int\\), \\(→ Int Int\\)\n *expressions: x, x")
 (typecheck-fail
  ((λ ([x : Int] [y : Int]) y) 1)
- #:with-msg (expected "Int, Int" #:given "Int"
-                      #:note "Wrong number of arguments"))
+ #:with-msg "wrong number of arguments: expected 2, given 1")
 
 (check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20)
 

tapl/tests/stlc+tup-tests.rkt

@@ -1,4 +1,4 @@
-#lang s-exp "../stlc+tup.rkt"
+#lang s-exp "../typed-lang-builder/stlc+tup.rkt"
 (require "rackunit-typechecking.rkt")
 
 ;; tests for tuples
@@ -17,7 +17,7 @@
 (typecheck-fail
  (proj 1 2)
  #:with-msg
- "Expected expression 1 to have × type, got: Int")
+ "proj: Expected × type, got: Int")
 
 ;; ext-stlc.rkt tests ---------------------------------------------------------
 ;; should still pass

tapl/typed-lang-builder/ext-stlc.rkt

@@ -0,0 +1,146 @@
+#lang macrotypes/tapl/typed-lang-builder
+(extends "stlc+lit.rkt" #:except #%datum)
+(provide ⊔ (for-syntax current-join))
+
+;; Simply-Typed Lambda Calculus, plus extensions (TAPL ch11)
+;; Types:
+;; - types from stlc+lit.rkt
+;; - Bool, String
+;; - Unit
+;; Terms:
+;; - terms from stlc+lit.rkt
+;; - literals: bool, string
+;; - boolean prims, numeric prims
+;; - if
+;; - prim void : (→ Unit)
+;; - begin
+;; - ascription (ann)
+;; - let, let*, letrec
+
+(define-base-type Bool)
+(define-base-type String)
+(define-base-type Float)
+(define-base-type Char)
+
+(define-typed-syntax #%datum
+  [(#%datum . b:boolean) ▶
+   --------
+   [⊢ [[_ ≫ (#%datum- . b)] ⇒ (: Bool)]]]
+  [(#%datum . s:str) ▶
+   --------
+   [⊢ [[_ ≫ (#%datum- . s)] ⇒ (: String)]]]
+  [(#%datum . f) ▶
+   [#:when (flonum? (syntax-e #'f))]
+   --------
+   [⊢ [[_ ≫ (#%datum- . f)] ⇒ (: Float)]]]
+  [(#%datum . c:char) ▶
+   --------
+   [⊢ [[_ ≫ (#%datum- . c)] ⇒ (: Char)]]]
+  [(#%datum . x) ▶
+   --------
+   [_ ≻ (stlc+lit:#%datum . x)]])
+
+(define-primop zero? : (→ Int Bool))
+(define-primop = : (→ Int Int Bool))
+(define-primop - : (→ Int Int Int))
+(define-primop add1 : (→ Int Int))
+(define-primop sub1 : (→ Int Int))
+(define-primop not : (→ Bool Bool))
+
+(define-typed-syntax and
+  [(and e1 e2) ▶
+   [⊢ [[e1 ≫ e1-] ⇐ (: Bool)]]
+   [⊢ [[e2 ≫ e2-] ⇐ (: Bool)]]
+   --------
+   [⊢ [[_ ≫ (and- e1- e2-)] ⇒ (: Bool)]]])
+
+(define-typed-syntax or
+  [(or e ...) ▶
+   [#:with [Bool* ...] (make-list (stx-length #'[e ...]) #'Bool)]
+   [⊢ [[e ≫ e-] ⇐ (: Bool*)] ...]
+   --------
+   [⊢ [[_ ≫ (or- e- ...)] ⇒ (: Bool)]]])
+
+(begin-for-syntax 
+  (define current-join 
+    (make-parameter 
+      (λ (x y) 
+        (unless (typecheck? x y)
+          (type-error
+            #:src x
+            #:msg  "branches have incompatible types: ~a and ~a" x y))
+        x))))
+
+(define-syntax ⊔
+  (syntax-parser
+    [(⊔ τ1 τ2 ...)
+     (for/fold ([τ ((current-type-eval) #'τ1)])
+               ([τ2 (in-list (stx-map (current-type-eval) #'[τ2 ...]))])
+       ((current-join) τ τ2))]))
+
+(define-typed-syntax if
+  [(if e_tst e1 e2) ⇐ (: τ-expected) ▶
+   [⊢ [[e_tst ≫ e_tst-] ⇒ (: _)]] ; Any non-false value is truthy.
+   [⊢ [[e1 ≫ e1-] ⇐ (: τ-expected)]]
+   [⊢ [[e2 ≫ e2-] ⇐ (: τ-expected)]]
+   --------
+   [⊢ [[_ ≫ (if- e_tst- e1- e2-)] ⇐ (: _)]]]
+  [(if e_tst e1 e2) ▶
+   [⊢ [[e_tst ≫ e_tst-] ⇒ (: _)]] ; Any non-false value is truthy.
+   [⊢ [[e1 ≫ e1-] ⇒ (: τ1)]]
+   [⊢ [[e2 ≫ e2-] ⇒ (: τ2)]]
+   --------
+   [⊢ [[_ ≫ (if- e_tst- e1- e2-)] ⇒ (: (⊔ τ1 τ2))]]])
+
+(define-base-type Unit)
+(define-primop void : (→ Unit))
+
+(define-typed-syntax begin
+  [(begin e_unit ... e) ⇐ (: τ_expected) ▶
+   [⊢ [[e_unit ≫ e_unit-] ⇒ (: _)] ...]
+   [⊢ [[e ≫ e-] ⇐ (: τ_expected)]]
+   --------
+   [⊢ [[_ ≫ (begin- e_unit- ... e-)] ⇐ (: _)]]]
+  [(begin e_unit ... e) ▶
+   [⊢ [[e_unit ≫ e_unit-] ⇒ (: _)] ...]
+   [⊢ [[e ≫ e-] ⇒ (: τ_e)]]
+   --------
+   [⊢ [[_ ≫ (begin- e_unit- ... e-)] ⇒ (: τ_e)]]])
+
+(define-typed-syntax let
+  [(let ([x e] ...) e_body) ⇐ (: τ_expected) ▶
+   [⊢ [[e ≫ e-] ⇒ (: τ_x)] ...]
+   [() ([x : τ_x ≫ x-] ...) ⊢ [[e_body ≫ e_body-] ⇐ (: τ_expected)]]
+   --------
+   [⊢ [[_ ≫ (let- ([x- e-] ...) e_body-)] ⇐ (: _)]]]
+  [(let ([x e] ...) e_body) ▶
+   [⊢ [[e ≫ e-] ⇒ (: τ_x)] ...]
+   [() ([x : τ_x ≫ x-] ...) ⊢ [[e_body ≫ e_body-] ⇒ (: τ_body)]]
+   --------
+   [⊢ [[_ ≫ (let- ([x- e-] ...) e_body-)] ⇒ (: τ_body)]]])
+
+; dont need to manually transfer expected type
+; result template automatically propagates properties
+; - only need to transfer expected type when local expanding an expression
+;   - see let/tc
+(define-typed-syntax let*
+  [(let* () e_body) ▶
+   --------
+   [_ ≻ e_body]]
+  [(let* ([x e] [x_rst e_rst] ...) e_body) ▶
+   --------
+   [_ ≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body))]])
+
+(define-typed-syntax letrec
+  [(letrec ([b:type-bind e] ...) e_body) ⇐ (: τ_expected) ▶
+   [() ([b.x : b.type ≫ x-] ...)
+    ⊢ [[e ≫ e-] ⇐ (: b.type)] ... [[e_body ≫ e_body-] ⇐ (: τ_expected)]]
+   --------
+   [⊢ [[_ ≫ (letrec- ([x- e-] ...) e_body-)] ⇐ (: _)]]]
+  [(letrec ([b:type-bind e] ...) e_body) ▶
+   [() ([b.x : b.type ≫ x-] ...)
+    ⊢ [[e ≫ e-] ⇐ (: b.type)] ... [[e_body ≫ e_body-] ⇒ (: τ_body)]]
+   --------
+   [⊢ [[_ ≫ (letrec- ([x- e-] ...) e_body-)] ⇒ (: τ_body)]]])
+
+

tapl/typed-lang-builder/stlc+tup.rkt

@@ -0,0 +1,35 @@
+#lang macrotypes/tapl/typed-lang-builder
+(extends "ext-stlc.rkt")
+
+(require (for-syntax racket/list))
+
+;; Simply-Typed Lambda Calculus, plus tuples
+;; Types:
+;; - types from ext-stlc.rkt
+;; - ×
+;; Terms:
+;; - terms from ext-stlc.rkt
+;; - tup and proj
+
+(define-type-constructor × #:arity >= 0
+  #:arg-variances (λ (stx)
+                    (make-list (stx-length (stx-cdr stx)) covariant)))
+
+(define-typed-syntax tup
+  [(tup e ...) ⇐ (: (~× τ ...)) ▶
+   [#:when (stx-length=? #'[e ...] #'[τ ...])]
+   [⊢ [[e ≫ e-] ⇐ (: τ)] ...]
+   --------
+   [⊢ [[_ ≫ (list- e- ...)] ⇐ (: _)]]]
+  [(tup e ...) ▶
+   [⊢ [[e ≫ e-] ⇒ (: τ)] ...]
+   --------
+   [⊢ [[_ ≫ (list- e- ...)] ⇒ (: (× τ ...))]]])
+
+(define-typed-syntax proj
+  [(proj e_tup n:nat) ▶
+   [⊢ [[e_tup ≫ e_tup-] ⇒ (: (~× τ ...))]]
+   [#:fail-unless (< (syntax-e #'n) (stx-length #'[τ ...])) "index too large"]
+   --------
+   [⊢ [[_ ≫ (list-ref- e_tup- n)] ⇒ (: #,(stx-list-ref #'[τ ...] (syntax-e #'n)))]]])
+