convert more mlish tests to typed-lang-builder/mlish-core

2016-06-22 13:35:59 -04:00 · 2016-06-22 13:35:59 -04:00 · a2ca787940
commit a2ca787940
parent fba974d8bb
19 changed files with 57 additions and 30 deletions
--- 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
--- 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:
--- 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
--- 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
--- 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)
--- 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+
--- 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)
--- 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)
--- 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)
--- 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
--- 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")
--- 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)))
--- 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)
--- 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))))]
--- 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
--- 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")

--- 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)
--- 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]]
--- 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)))]
+    ))
+