add read-tree example

tapl/mlish-do.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+
+(provide do)
+
+(require (only-in "mlish.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 : t1:expr
+              <- m1:expr]
+       rst ...
+       body:expr)
+     #'(bind
+        m1
+        (λ ([x1 : t1])
+          (do bind rst ... body)))]
+    [(do bind:id
+       [m1:expr]
+       rst ...
+       body:expr)
+     #'(bind
+        m1
+        (λ ([dummy : Unit])
+          (do bind rst ... body)))]
+    ))
+

tapl/mlish.rkt

@@ -527,6 +527,7 @@
 
 (define-primop random : (→ Int Int))
 (define-primop integer->char : (→ Int Char))
+(define-primop string->list : (→ String (List Char)))
 (define-primop string->number : (→ String Int))
 ;(define-primop number->string : (→ Int String))
 (define-typed-syntax num->str #:export-as number->string

tapl/tests/mlish/result.mlish

@@ -0,0 +1,131 @@
+#lang s-exp "../../mlish.rkt"
+(require "../rackunit-typechecking.rkt" "../../mlish-do.rkt")
+
+(define-type (Result A B)
+  (Ok A)
+  (Error B))
+
+(define {A B} (ok [a : A] → (Result A B))
+  (Ok a))
+(define {A B} (error [b : B] → (Result A B))
+  (Error b))
+
+(provide-type Result)
+(provide ok)
+(provide error)
+
+(check-type (inst ok Int String) : (→ Int (Result Int String)))
+(check-type (inst error Int String) : (→ String (Result Int String)))
+
+(check-type
+ (list (Ok {Int String} 3) (Error "abject failure") (Ok 4))
+ : (List (Result Int String))
+ -> (list (Ok {Int String} 3) (Error "abject failure") (Ok 4)))
+
+(define {A B Er} (result-bind [a : (Result A Er)] [f : (→ A (Result B Er))] → (Result B Er))
+  (match a with
+    [Ok v -> (f v)]
+    [Error er -> (Error er)]))
+
+(provide result-bind)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; read-tree, a function that parses a tree and uses the result monad.
+
+(require "trees.mlish")
+
+;; Parsing 42 in base 10: (rev-list->int 10 (list 2 4) 1 0) yields 42.
+(define (rev-list->int [base : Int] [rev-list : (List Int)] [place : Int] [accum : Int] → Int)
+  (cond
+    [(isnil rev-list) accum]
+    [else (rev-list->int base
+                         (tail rev-list)
+                         (* base place)
+                         (+ accum (* place (head rev-list))))]))
+
+(define (digit? [c : Char] → Bool)
+  (or (equal? c #\0)
+      (equal? c #\1)
+      (equal? c #\2)
+      (equal? c #\3)
+      (equal? c #\4)
+      (equal? c #\5)
+      (equal? c #\6)
+      (equal? c #\7)
+      (equal? c #\8)
+      (equal? c #\9)))
+
+(define (digit->int [c : Char] → Int)
+  (string->number (string c)))
+
+(define-type-alias (Read-Result A) (Result (× A (List Char)) String))
+
+(define (read-int [str : (List Char)] [accum : (List Int)] → (Read-Result Int))
+  (cond
+    [(isnil str)
+     (cond [(isnil accum) (error "expected an int, given nothing")]
+           [else (ok (tup (rev-list->int 10 accum 1 0) str))])]
+    [(digit? (head str))
+     (read-int (tail str) (cons (digit->int (head str)) accum))]
+    [else
+     (ok (tup (rev-list->int 10 accum 1 0) str))]))
+
+(define (read-tree [str : (List Char)] → (Read-Result (Tree Int)))
+  (cond
+    [(isnil str)
+     (error "expected a tree of integers, given nothing")]
+    [(equal? (head str) #\( )
+     (do result-bind
+       [tree1+str : (× (Tree Int) (List Char))
+                  <- (read-tree (tail str))]
+       [(cond [(equal? (head (proj tree1+str 1)) #\space)
+               ((inst ok Unit String) (void))]
+              [else
+               ((inst error Unit String) "expected a space")])]
+       [int+str : (× Int (List Char))
+                <- (read-int (tail (proj tree1+str 1)) nil)]
+       [(cond [(equal? (head (proj int+str 1)) #\space)
+               ((inst ok Unit String) (void))]
+              [else
+               ((inst error Unit String) "expected a space")])]
+       [tree2+str : (× (Tree Int) (List Char))
+                  <- (read-tree (tail (proj int+str 1)))]
+       [(cond [(equal? (head (proj tree2+str 1)) #\) )
+               ((inst ok Unit String) (void))]
+              [else
+               ((inst error Unit String) "expected a `)`")])]
+       ((inst ok (× (Tree Int) (List Char)) String)
+        (tup (Node (proj tree1+str 0)
+                   (proj int+str 0)
+                   (proj tree2+str 0))
+             (tail (proj tree2+str 1)))))]
+    [(digit? (head str))
+     (do result-bind
+       [int+str : (× Int (List Char))
+                <- (read-int str nil)]
+       ((inst ok (× (Tree Int) (List Char)) String)
+        (tup (Leaf (proj int+str 0))
+             (proj int+str 1))))]
+    [else
+     (error "expected either a `(` or a digit")]))
+
+(check-type
+ (read-tree (string->list "42"))
+ : (Read-Result (Tree Int))
+ -> ((inst ok (× (Tree Int) (List Char)) String)
+     (tup (Leaf 42) nil)))
+
+(check-type
+ (read-tree (string->list "x"))
+ : (Read-Result (Tree Int))
+ -> ((inst error (× (Tree Int) (List Char)) String)
+     "expected either a `(` or a digit"))
+
+(check-type
+ (read-tree (string->list "(42 43 (44 45 46))"))
+ : (Read-Result (Tree Int))
+ -> ((inst ok (× (Tree Int) (List Char)) String)
+     (tup (Node (Leaf 42) 43 (Node (Leaf 44) 45 (Leaf 46))) nil)))
+
+

tapl/tests/mlish/trees.mlish

@@ -5,6 +5,10 @@
   (Leaf X)
   (Node (Tree X) X (Tree X)))
 
+(provide-type Tree)
+(provide-type Leaf)
+(provide-type Node)
+
 (define (make [item : Int] [depth : Int] -> (Tree Int))
   (if (zero? depth)
       (Leaf item)