commit 0bc592240d1936acc18486f8b79696be44b7186b
parent 93323091600ebf3db9a3fb92de82557ae493b2cc
Author: AlexKnauth <alexander@knauth.org>
Date: Mon, 21 Mar 2016 00:07:20 -0400
add read-tree example
Diffstat:
4 files changed, 168 insertions(+), 0 deletions(-)
diff --git a/tapl/mlish-do.rkt b/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)))]
+ ))
+
diff --git a/tapl/mlish.rkt b/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
diff --git a/tapl/tests/mlish/result.mlish b/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)))
+
+
diff --git a/tapl/tests/mlish/trees.mlish b/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)
