From 0bc592240d1936acc18486f8b79696be44b7186b Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Mon, 21 Mar 2016 00:07:20 -0400 Subject: [PATCH] add read-tree example --- tapl/mlish-do.rkt | 32 +++++++++ tapl/mlish.rkt | 1 + tapl/tests/mlish/result.mlish | 131 ++++++++++++++++++++++++++++++++++ tapl/tests/mlish/trees.mlish | 4 ++ 4 files changed, 168 insertions(+) create mode 100644 tapl/mlish-do.rkt create mode 100644 tapl/tests/mlish/result.mlish diff --git a/tapl/mlish-do.rkt b/tapl/mlish-do.rkt new file mode 100644 index 0000000..10df324 --- /dev/null +++ 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 index c032ca6..21a7897 100644 --- 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 new file mode 100644 index 0000000..6e9b6aa --- /dev/null +++ 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 index 4bbbc11..1a07287 100644 --- 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)