{ : file } Where Define (file text) Let result (file_block text 0 { : expr : binder_group : block_body }) In Match result | 'fail._ result | 'succeed.{x _} 'succeed.x ; Where Let file_block Define (rec rec expr) (bind1 pop Func {token} Match token | 'eof (pure expr) | 'sym.s Cond | (STRING.equal s "Where") (binder_group 'nil Func {binders} (rec rec 'block.{binders expr})) | True (fail "Unexpected token while parsing package.") ; | _ (fail "Unexpected token while parsing package.") ;) In (bind1 expr Func {expr} (rec rec expr)) Let expr (bind1 pop Func {token} Match token | 'eof (fail "Unexpected end of file.") | 'num.n (pure 'num.n) | 'str.s (pure 'str.s) | 'op.name Cond | (STRING.equal name "-") (lift1 expr Func {expr} 'app.{'prim."negate" [expr & 'nil]}) | (STRING.equal name "!") (lift1 expr Func {expr} 'if.{expr 'false 'true}) | True (fail "Unexpected unary operator.") ; | 'id.name (if_match "." (lift1 chain Func {chain} 'chain.{'var.name chain}) (pure 'var.name)) | 'sym.text Cond | (STRING.equal text "(") (lift2 expr (sequence expr ")") Func {func args} 'app.{func args}) | (STRING.equal text "{") (if_can_match ":" (lift1 (sequence record_init "}") Func {labels_and_inits} 'record.(LIST.unzip labels_and_inits)) (lift1 (sequence expr "}") Func {exprs} 'tuple.exprs)) | (STRING.equal text "[") infix_expr | (STRING.equal text "'") (bind1 id Func {label} (if_match "." (lift1 expr Func {expr} 'labeled.{label expr}) (pure 'labeled.{label 'tuple.'nil}))) | (STRING.equal text "True") (pure 'true) | (STRING.equal text "False") (pure 'false) | (STRING.equal text "And") (lift2 expr expr Func {test then} 'and.{test then}) | (STRING.equal text "Or") (lift2 expr expr Func {test else} 'or.{test else}) | (STRING.equal text "If") (lift3 expr expr expr Func {test then else} 'if.{test then else}) | (STRING.equal text "Cond") Let cond_clause (ignore1 (match "|") (lift2 expr block_body Func {test body} {test body})) In (lift1 (sequence cond_clause ";") Func {clauses} 'cond.clauses) | (STRING.equal text "Match") Let match_clause (ignore1 (match "|") (lift2 match_pattern block_body Func {pat body} {pat body})) In (lift2 expr (sequence match_clause ";") Func {expr clauses} 'match.{expr clauses}) | (STRING.equal text "Func") (bind1 (ignore1 (match "{") (sequence pattern "}")) Func {pats} (lift1 block_body Func {body} 'func.{pats body})) | (STRING.equal text "Prim") (lift1 id Func {name} 'prim.name) | (STRING.equal text "Package") (bind1 pop Func {token} Match token | 'str.s Define (strip_quotes s) (STRING.clip s 1 [(STRING.length s) - 1]) In (pure 'package.(strip_quotes s)) | _ (fail "Malformed Package expression.") ;) | (STRING.equal text "Block") block_body | (STRING.equal text "For") (bind2 expr (if_match "Let" (pure let_binder) (if_match "Do" (pure do_binder) (if_match "Define" (pure define_binder) (ignore1 pop (fail "Expected binder."))))) Func {expr binder} (lift1 binder Func {binder} 'block.{[binder & 'nil] expr})) | (STRING.equal text "Iterate") (bind1 (ignore1 (match "{") (sequence simple_pattern "}")) Func {vars} (bind1 (if_match "From" (ignore1 (match "{") (sequence expr "}")) (pure (LIST.map vars [Func {name} 'var.name]))) Func {inits} If [(LIST.length vars) != (LIST.length inits)] (fail "Wrong number of initializers.") (lift1 block_body Func {expr} 'iterate.{vars inits expr}))) | (STRING.equal text "Continue") (lift1 (ignore1 (match "{") (sequence expr "}")) Func {exprs} 'continue.exprs) | (STRING.equal text "Begin") (bind1 (sequence expr "End") Func {exprs} Match (LIST.reverse exprs) | 'nil (fail "Empty Begin expression.") | 'cons.{expr exprs} Let binders (LIST.map exprs Func {expr} 'do.expr) In (pure 'block.{binders expr}) ;) | (STRING.equal text "When") (bind2 expr (sequence expr "End") Func {test exprs} Match (LIST.reverse exprs) | 'nil (fail "Empty When expression.") | 'cons.{expr exprs} Let binders (LIST.map exprs Func {expr} 'do.expr) In (pure 'if.{test 'block.{binders expr} 'tuple.'nil}) ;) | True (fail "Unexpected token while parsing expression.") ; ;) Let block_body Define (continue binders) (ignore1 (match "In") (lift1 block_body Func {expr} 'block.{binders expr})) In (bind1 peek Func {token} Match token | 'sym.s Let has_binder Cond | (STRING.equal s "Let") True | (STRING.equal s "Do") True | (STRING.equal s "Define") True | True False ; In If has_binder (binder_group 'nil continue) expr | _ expr ;) Define (binder_group binders continue) (bind1 peek Func {token} Match token | 'sym.s Let maybe_parser Cond | (STRING.equal s "Let") 'just.let_binder | (STRING.equal s "Define") 'just.define_binder | (STRING.equal s "Do") 'just.do_binder | True 'nothing ; In Match maybe_parser | 'just.binder (bind1 (ignore1 pop binder) Func {binder} Let binders [binder & binders] In (binder_group binders continue)) | 'nothing (continue binders) ; | _ (continue binders) ;) Where Let infix_expr (lift3 (if_match "Right" (pure 'right) (pure 'left)) expr (sequence (lift2 op expr Func {op right} {op right}) "]") Func {assoc left pairs} Define (app left op right) 'app.{'prim.op [Right left & right & 'nil]} In Match assoc | 'left (LIST.reduce pairs left Func {left {op right}} (app left op right)) | 'right Match pairs | 'nil left | 'cons.{pair pairs} For (rec rec left pair pairs) Define (rec rec left {op right} pairs) Match pairs | 'nil (app left op right) | 'cons.{pair pairs} (app left op (rec rec right pair pairs)) ; ; ;) Let match_pattern Let vars (if_match "{" (lift1 (sequence simple_pattern "}") Func {vars} 'tuple.vars) (if_match "_" (pure 'ignore) (lift1 id Func {name} 'var.name))) In (bind1 pop Func {token} Match token | 'sym.s Cond | (STRING.equal s "_") (pure 'default) | (STRING.equal s "'") (lift2 id (if_match "." vars (pure 'tuple.'nil)) Func {label vars} 'labeled.{label vars}) | True (fail "Malformed Match pattern.") ; | 'eof (fail "Unexpected end of file.") | _ (fail "Malformed Match pattern.") ;) Where Let let_binder (lift2 (if_match "{" (lift1 (sequence simple_pattern "}") Func {vars} 'tuple.vars) (lift1 id Func {name} 'var.name)) block_body Func {pat expr} 'let.{pat expr}) Let do_binder (lift1 block_body Func {expr} 'do.expr) Let define_binder (lift3 (ignore1 (match "(") id) (sequence pattern ")") block_body Func {name pats expr} 'let.{'var.name 'func.{pats expr}}) Where Let pattern (bind1 pop Func {token} Match token | 'id.name (pure 'var.name) | 'sym.s Cond | (STRING.equal s "{") (lift1 (sequence simple_pattern "}") Func {pats} 'tuple.pats) | (STRING.equal s "_") (pure 'ignore) | True (fail "Invalid pattern.") ; | 'eof (fail "Unexpected end of file.") | _ (fail "Expected token while parsing patterns.") ;) Where Let simple_pattern (bind1 pop Func {token} Match token | 'id.name (pure name) | 'sym.s Cond | (STRING.equal s "_") (pure "_") | True (fail "Invalid pattern.") ; | 'eof (fail "Unexpected end of file.") | _ (fail "Unexpected token.") ;) Let record_init (bind2 (ignore1 (match ":") id) peek Func {name token} Let is_expr_omitted Match token | 'sym.s Or (STRING.equal s ":") (STRING.equal s "}") | _ False ; In If is_expr_omitted (pure {name 'var.name}) (lift1 expr Func {expr} {name expr})) Define (sequence parser terminator) Define (rec rec) (if_match terminator (pure 'nil) (bind1 parser Func {item} (lift1 (rec rec) Func {items} [item & items]))) In (rec rec) Let chain Define (rec rec) (bind1 pop Func {token} Let access Match token | 'id.name (pure 'id.name) | 'num.n (pure 'num.n) | 'eof (fail "Unexpected end of file.") | _ (fail "Unexpected token.") ; In (lift2 access (if_match "." (rec rec) (pure 'nil)) Func {access chain} [access & chain])) In (rec rec) Where Let id (bind1 pop Func {token} Match token | 'id.name (pure name) | 'sym.s (fail (STRING.append "Expected identifier, got " s)) | 'eof (fail "Unexpected end of file.") | _ (fail "Unexpected token.") ;) Let op Define (long_name s) Cond | (STRING.equal s "+") "add" | (STRING.equal s "-") "subtract" | (STRING.equal s "*") "multiply" | (STRING.equal s "/") "quotient" | (STRING.equal s "%") "remainder" | (STRING.equal s "<") "less" | (STRING.equal s ">") "greater" | (STRING.equal s "=") "equal" | (STRING.equal s "!=") "not_equal" | (STRING.equal s "<=") "less_or_equal" | (STRING.equal s ">=") "greater_or_equal" | (STRING.equal s "&") "cons" ; In (bind1 pop Func {token} Match token | 'op.s (pure (long_name s)) | _ (fail "Unexpected token.") ;) Where Define (match s) (if_can_match s pop (fail (STRING.concat [Right "Expected \"" & s & "\"." & 'nil]))) Define (if_match s1 then else) (if_can_match s1 (ignore1 pop then) else) Where Define (if_can_match s then else) (bind1 peek Func {token} Match token | 'sym.t If (STRING.equal s t) then else | _ else ;) Where Let expr Func {text i rec} (rec.expr text i rec) Define (binder_group binders continue) Func {text i rec} ((rec.binder_group binders continue) text i rec) Let block_body Func {text i rec} (rec.block_body text i rec) Let pop Func {text i _} Let i (SCAN.whitespace text i) In Let {i token} (SCAN.token text i) In 'succeed.{token i} Let peek Func {text i _} Let j (SCAN.whitespace text i) In Let {_ token} (SCAN.token text j) In 'succeed.{token i} Define (fail message) Func {_ i _} 'fail.{message i} Define (pure x) Func {_ i _} 'succeed.{x i} Let rec Func {_ i rec} 'succeed.{rec i} Define (bind1 m1 f) Func {text i rec} Let r1 (m1 text i rec) In Match r1 | 'succeed.{x1 i} Let m2 (f x1) In (m2 text i rec) | 'fail._ r1 ; Define (bind2 m1 m2 f) Func {text i rec} Let r1 (m1 text i rec) In Match r1 | 'succeed.{x1 i} Let r2 (m2 text i rec) In Match r2 | 'succeed.{x2 i} Let m3 (f x1 x2) In (m3 text i rec) | 'fail._ r2 ; | 'fail._ r1 ; Define (lift1 m1 f) Func {text i rec} Let r1 (m1 text i rec) In Match r1 | 'succeed.{x1 i} 'succeed.{(f x1) i} | 'fail._ r1 ; Define (lift2 m1 m2 f) Func {text i rec} Let r1 (m1 text i rec) In Match r1 | 'succeed.{x1 i} Let r2 (m2 text i rec) In Match r2 | 'succeed.{x2 i} 'succeed.{(f x1 x2) i} | 'fail._ r2 ; | 'fail._ r1 ; Define (lift3 m1 m2 m3 f) Func {text i rec} Let r1 (m1 text i rec) In Match r1 | 'succeed.{x1 i} Let r2 (m2 text i rec) In Match r2 | 'succeed.{x2 i} Let r3 (m3 text i rec) In Match r3 | 'succeed.{x3 i} 'succeed.{(f x1 x2 x3) i} | 'fail._ r3 ; | 'fail._ r2 ; | 'fail._ r1 ; Define (ignore1 m1 m2) Func {text i rec} Let r1 (m1 text i rec) In Match r1 | 'succeed.{_ i} (m2 text i rec) | 'fail._ r1 ; Where Let LIST Package "list" Let OS Package "os" Let SCAN Package "scan" Let STDIO Package "stdio" Let STRING Package "string"