commit a2ca7879403145497d8fb1bf1789f1b53c4a828b
parent fba974d8bb7c960733d40501f08b4af32e0c1d07
Author: AlexKnauth <alexander@knauth.org>
Date: Wed, 22 Jun 2016 13:35:59 -0400
convert more mlish tests to typed-lang-builder/mlish-core
Diffstat:
19 files changed, 57 insertions(+), 30 deletions(-)
diff --git a/tapl/tests/mlish/ack.mlish b/tapl/tests/mlish/ack.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
;; tests cond with else
diff --git a/tapl/tests/mlish/alex.mlish b/tapl/tests/mlish/alex.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
;; the following function def produces error:
diff --git a/tapl/tests/mlish/ary.mlish b/tapl/tests/mlish/ary.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
;; test vectors and for loops
diff --git a/tapl/tests/mlish/chameneos.mlish b/tapl/tests/mlish/chameneos.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define-type Color Red Yellow Blue)
@@ -15,7 +15,7 @@
(define-type-alias ResultChan (Channel Result))
(typecheck-fail (channel-put (make-channel {Bool}) 1)
- #:with-msg "Cannot send Int value on Bool channel")
+ #:with-msg "channel-put: type mismatch: expected Bool, given Int\n *expression: 1")
(define (change [c1 : Color] [c2 : Color] -> Color)
(match c1 with
diff --git a/tapl/tests/mlish/fannkuch.mlish b/tapl/tests/mlish/fannkuch.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define (fannkuch [n : Int] -> Int)
diff --git a/tapl/tests/mlish/fasta.mlish b/tapl/tests/mlish/fasta.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define +alu+
diff --git a/tapl/tests/mlish/fibo.mlish b/tapl/tests/mlish/fibo.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define (fib [n : Int] -> Int)
diff --git a/tapl/tests/mlish/find.mlish b/tapl/tests/mlish/find.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define-type (List X)
diff --git a/tapl/tests/mlish/hash.mlish b/tapl/tests/mlish/hash.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define (main [argv : (Vector String)] -> Int)
diff --git a/tapl/tests/mlish/inst.mlish b/tapl/tests/mlish/inst.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
;; tests for instantiation of polymorphic functions and constructors
diff --git a/tapl/tests/mlish/knuc.mlish b/tapl/tests/mlish/knuc.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(require-typed mk-fasta #:from "fasta.mlish")
diff --git a/tapl/tests/mlish/matrix.mlish b/tapl/tests/mlish/matrix.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define-type-alias Matrix (Vector (Vector Int)))
diff --git a/tapl/tests/mlish/nbody.mlish b/tapl/tests/mlish/nbody.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define +pi+ 3.141592653589793)
diff --git a/tapl/tests/mlish/result.mlish b/tapl/tests/mlish/result.mlish
@@ -1,5 +1,5 @@
-#lang s-exp "../../mlish.rkt"
-(require "../rackunit-typechecking.rkt" "../../mlish-do.rkt")
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
+(require "../rackunit-typechecking.rkt" "../../typed-lang-builder/mlish-do.rkt")
(define-type (Result A B)
(Ok A)
@@ -82,18 +82,15 @@
(let ([do-ok (inst ok Unit String)]
[do-error (inst error String Unit)])
(do result-bind
- [tree1+str : (× (Tree Int) (List Char))
- <- (read-tree (tail str))]
+ [tree1+str <- (read-tree (tail str))]
[(cond [(equal? (head (proj tree1+str 1)) #\space)
(do-ok (void))]
[else (do-error "expected a space")])]
- [int+str : (× Int (List Char))
- <- (read-int (tail (proj tree1+str 1)) nil)]
+ [int+str <- (read-int (tail (proj tree1+str 1)) nil)]
[(cond [(equal? (head (proj int+str 1)) #\space)
(do-ok (void))]
[else (do-error "expected a space")])]
- [tree2+str : (× (Tree Int) (List Char))
- <- (read-tree (tail (proj int+str 1)))]
+ [tree2+str <- (read-tree (tail (proj int+str 1)))]
[(cond [(equal? (head (proj tree2+str 1)) #\) )
(do-ok (void))]
[else (do-error "expected a `)`")])]
@@ -104,8 +101,7 @@
(tail (proj tree2+str 1))))))]
[(digit? (head str))
(do result-bind
- [int+str : (× Int (List Char))
- <- (read-int str nil)]
+ [int+str <- (read-int str nil)]
(ok
(tup (Leaf (proj int+str 0))
(proj int+str 1))))]
diff --git a/tapl/tests/mlish/term.mlish b/tapl/tests/mlish/term.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
;; from chap 6 of RW OCaml
diff --git a/tapl/tests/mlish/trees-tests.mlish b/tapl/tests/mlish/trees-tests.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(require "trees.mlish")
diff --git a/tapl/tests/mlish/trees.mlish b/tapl/tests/mlish/trees.mlish
@@ -1,4 +1,4 @@
-#lang s-exp "../../mlish.rkt"
+#lang s-exp "../../typed-lang-builder/mlish-core.rkt"
(require "../rackunit-typechecking.rkt")
(define-type (Tree X)
diff --git a/tapl/typed-lang-builder/mlish-core.rkt b/tapl/typed-lang-builder/mlish-core.rkt
@@ -1200,9 +1200,9 @@
[() ([name : (→ ty_e ... ty.norm) ≫ name-] [x : ty_e ≫ x-] ...)
⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇐ : ty.norm]]
--------
- [⊢ [[_ ≫ (letrec- ([name- (λ- xs- b- ... body-)])
+ [⊢ [[_ ≫ (letrec- ([name- (λ- (x- ...) b- ... body-)])
(name- e- ...))]
- ⇒ : ty_body]]]
+ ⇒ : ty.norm]]]
[(let ([x:id e] ...) body ...) ▶
--------
[_ ≻ (ext-stlc:let ([x e] ...) (begin body ...))]])
@@ -1288,7 +1288,7 @@
(define-typed-syntax write-string
[(write-string str out) ▶
--------
- [_ ≻ (write-string str out (ext-stlc:#%datum . 0) (string-length/tc str))]]
+ [_ ≻ (write-string str out (ext-stlc:#%datum . 0) (string-length str))]]
[(write-string str out start end) ▶
[⊢ [[str ≫ str-] ⇐ : String]]
[⊢ [[out ≫ out-] ⇐ : String-Port]]
diff --git a/tapl/typed-lang-builder/mlish-do.rkt b/tapl/typed-lang-builder/mlish-do.rkt
@@ -0,0 +1,31 @@
+#lang racket/base
+
+(provide do)
+
+(require (only-in "mlish-core.rkt" #%app λ Unit)
+ (for-syntax racket/base
+ syntax/parse))
+
+(define-syntax do
+ (syntax-parser
+ #:datum-literals (<- :)
+ [(do bind:id body:expr)
+ #'body]
+ [(do bind:id
+ [x1:id <- m1:expr]
+ rst ...
+ body:expr)
+ #'(bind
+ m1
+ (λ (x1)
+ (do bind rst ... body)))]
+ [(do bind:id
+ [m1:expr]
+ rst ...
+ body:expr)
+ #'(bind
+ m1
+ (λ (dummy)
+ (do bind rst ... body)))]
+ ))
+
