commit c75f79c0dbed04f19d0bb55d8662db716d4e0b59
parent 3bc035fde1e0a17129152e8e65ba316bd4615ddd
Author: AlexKnauth <alexander@knauth.org>
Date: Mon, 20 Jun 2016 15:07:38 -0400
implement ext-stlc and stlc+tup with typed-lang-builder
Diffstat:
4 files changed, 204 insertions(+), 21 deletions(-)
diff --git a/tapl/tests/ext-stlc-tests.rkt b/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)
diff --git a/tapl/tests/stlc+tup-tests.rkt b/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
diff --git a/tapl/typed-lang-builder/ext-stlc.rkt b/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)]]])
+
+
diff --git a/tapl/typed-lang-builder/stlc+tup.rkt b/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)))]]])
+
