{ : file } Where Define (file text) Let result (parse text) In Match result | 'fail._ result | 'succeed.{x _} 'succeed.x ; Where Define (parse text) Unfold {parser i} From {file_block 0} Match parser | 'production.name Let parser Match name | 'expr expr | 'block_body block_body | 'binder binder | 'binder_group binder_group ; In (Fold parser i) | 'fail.message 'fail.{message i} | 'pure.x 'succeed.{x i} | 'bind1.{m1 f} Let r1 (Fold m1 i) In Match r1 | 'fail._ r1 | 'succeed.{x1 i} (Fold (f x1) i) ; | 'bind2.{m1 m2 f} Let r1 (Fold m1 i) In Match r1 | 'fail._ r1 | 'succeed.{x1 i} Let r2 (Fold m2 i) In Match r2 | 'fail._ r2 | 'succeed.{x2 i} (Fold (f x1 x2) i) ; ; | 'lift1.{m1 f} Let r1 (Fold m1 i) In Match r1 | 'fail._ r1 | 'succeed.{x1 i} 'succeed.{(f x1) i} ; | 'lift2.{m1 m2 f} Let r1 (Fold m1 i) In Match r1 | 'fail._ r1 | 'succeed.{x1 i} Let r2 (Fold m2 i) In Match r2 | 'fail._ r2 | 'succeed.{x2 i} 'succeed.{(f x1 x2) i} ; ; | 'lift3.{m1 m2 m3 f} Let r1 (Fold m1 i) In Match r1 | 'fail._ r1 | 'succeed.{x1 i} Let r2 (Fold m2 i) In Match r2 | 'fail._ r2 | 'succeed.{x2 i} Let r3 (Fold m3 i) In Match r3 | 'fail._ r3 | 'succeed.{x3 i} 'succeed.{(f x1 x2 x3) i} ; ; ; | 'ignore1.{m1 m2} Let r1 (Fold m1 i) In Match r1 | 'fail._ r1 | 'succeed.{_ i} (Fold m2 i) ; | 'pop Let i (SCAN.whitespace text i) In Let {i token} (SCAN.token text i) In 'succeed.{token i} | 'peek Let j (SCAN.whitespace text i) In Let {_ token} (SCAN.token text j) In 'succeed.{token i} ; Where Let file_block (lift2 PROD.expr (sequence (ignore1 (match "Where") PROD.binder_group) 'nothing) Func {expr binder_groups} (LIST.reduce binder_groups expr Func {expr binders} 'block.{binders 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 PROD.expr Func expr 'app.{'prim."negate" [expr & 'nil]}) | (STRING.equal name "!") (lift1 PROD.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 "(") (if_match "Prim" (lift2 id (sequence PROD.expr 'just.")") Func {name args} 'app.{'prim.name args}) (if_match "Continue" (lift1 (sequence PROD.expr 'just.")") Func exprs 'continue.exprs) (if_match "Fold" (lift1 (sequence PROD.expr 'just.")") Func exprs 'fold.exprs) (lift2 PROD.expr (sequence PROD.expr 'just.")") Func {func args} 'app.{func args})))) | (STRING.equal text "{") 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 PROD.expr Func expr {name expr})) In (if_can_match ":" (lift1 (sequence record_init 'just."}") Func labels_and_inits 'record.(LIST.unzip labels_and_inits)) (lift1 (sequence PROD.expr 'just."}") Func exprs Match (extract_singleton exprs) | 'nothing 'tuple.exprs | 'just.expr expr ;)) | (STRING.equal text "[") Define (app left op right) Cond | (STRING.equal op "compose_left") 'app.{'prim."compose" [Right left & right & 'nil]} | (STRING.equal op "compose_right") 'app.{'prim."compose" [Right right & left & 'nil]} | (STRING.equal op "apply_left") 'app.{left [right & 'nil]} | (STRING.equal op "apply_right") 'app.{right [left & 'nil]} | True 'app.{'prim.op [Right left & right & 'nil]} ; In Define (reduce_left left pairs) (LIST.reduce pairs left Func {left {op right}} (app left op right)) Define (reduce_right left pairs) Match pairs | 'nil left | 'cons.{pair pairs} Unfold {left pair pairs} Let {op right} pair In Match pairs | 'nil (app left op right) | 'cons.{pair pairs} (app left op (Fold right pair pairs)) ; ; In (lift3 (if_match "Right" (pure 'right) (pure 'left)) PROD.expr (sequence (lift2 op PROD.expr Func {op right} {op right}) 'just."]") Func {assoc left pairs} Match assoc | 'left (reduce_left left pairs) | 'right (reduce_right left pairs) ;) | (STRING.equal text "'") (bind1 id Func label (if_match "." (lift1 PROD.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 PROD.expr PROD.expr Func {test then} 'and.{test then}) | (STRING.equal text "Or") (lift2 PROD.expr PROD.expr Func {test else} 'or.{test else}) | (STRING.equal text "If") (lift3 PROD.expr PROD.expr PROD.expr Func {test then else} 'if.{test then else}) | (STRING.equal text "Cond") Let cond_clause (ignore1 (match "|") (lift2 PROD.expr PROD.block_body Func {test body} {test body})) In (lift1 (sequence cond_clause 'just.";") Func clauses 'cond.clauses) | (STRING.equal text "Match") Let match_clause (ignore1 (match "|") (lift2 match_pattern PROD.block_body Func {pat body} {pat body})) In (lift2 PROD.expr (sequence match_clause 'just.";") Func {expr clauses} 'match.{expr clauses}) | (STRING.equal text "Func") (bind1 (if_match "{" (sequence pattern 'just."}") (if_match "_" (pure ['ignore & 'nil]) (lift1 id Func name ['var.name & 'nil]))) Func pats (lift1 PROD.block_body Func body 'func.{pats body})) | (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") PROD.block_body | (STRING.equal text "For") (lift2 PROD.expr PROD.binder Func {expr binder} 'block.{[binder & 'nil] expr}) | (STRING.equal text "Iterate") (bind2 (if_match "{" (sequence simple_pattern 'just."}") (lift1 id Func name [name & 'nil])) (if_match "From" (lift1 (if_match "{" (sequence PROD.expr 'just."}") (lift1 PROD.expr [Func expr [expr & 'nil]])) Func inits 'just.inits) (pure 'nothing)) Func {vars maybe_inits} Let inits Match maybe_inits | 'just.inits inits | 'nothing (LIST.map vars [Func name 'var.name]) ; In If [(LIST.length vars) != (LIST.length inits)] (fail "Wrong number of initializers.") (lift1 PROD.block_body Func expr 'iterate.{vars inits expr})) | (STRING.equal text "Unfold") (bind2 (if_match "{" (sequence simple_pattern 'just."}") (lift1 id Func name [name & 'nil])) (if_match "From" (lift1 (if_match "{" (sequence PROD.expr 'just."}") (lift1 PROD.expr [Func expr [expr & 'nil]])) Func inits 'just.inits) (pure 'nothing)) Func {vars maybe_inits} Let inits Match maybe_inits | 'just.inits inits | 'nothing (LIST.map vars [Func name 'var.name]) ; In If [(LIST.length vars) != (LIST.length inits)] (fail "Wrong number of initializers.") (lift1 PROD.block_body Func expr 'unfold.{vars inits expr})) | (STRING.equal text "Begin") (bind1 (sequence PROD.expr 'just."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 PROD.expr (sequence PROD.expr 'just."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 binder_group Unfold binders From 'nil (bind1 peek Func token Let has_binder Match token | 'sym.s Cond | (STRING.equal s "Let") True | (STRING.equal s "Do") True | (STRING.equal s "Define") True | True False ; | _ False ; In If has_binder (bind1 PROD.binder Func binder (Fold [binder & binders])) (pure binders)) Let binder Let let_binder (lift2 (if_match "{" (lift1 (sequence simple_pattern 'just."}") Func vars Match (extract_singleton vars) | 'nothing 'tuple.vars | 'just.name 'var.name ;) (lift1 id Func name 'var.name)) PROD.block_body Func {pat expr} 'let.{pat expr}) Let do_binder (lift1 PROD.block_body Func expr 'do.expr) Let define_binder (lift3 (ignore1 (match "(") id) (sequence pattern 'just.")") PROD.block_body Func {name pats expr} 'let.{'var.name 'func.{pats expr}}) In (bind1 pop Func token Let maybe_binder Match token | 'sym.s Cond | (STRING.equal s "Let") 'just.let_binder | (STRING.equal s "Do") 'just.do_binder | (STRING.equal s "Define") 'just.define_binder | True 'nothing ; | _ 'nothing ; In Match maybe_binder | 'nothing (fail "Expected binder.") | 'just.binder binder ;) Let block_body (bind1 peek Func token Let has_binder Match token | 'sym.s Cond | (STRING.equal s "Let") True | (STRING.equal s "Do") True | (STRING.equal s "Define") True | True False ; | _ False ; In If has_binder (lift2 PROD.binder_group (ignore1 (match "In") PROD.block_body) Func {binders expr} 'block.{binders expr}) PROD.expr) Where Let PROD { : expr 'production.'expr : block_body 'production.'block_body : binder 'production.'binder : binder_group 'production.'binder_group } Where Let match_pattern Let vars (if_match "{" (lift1 (sequence simple_pattern 'just."}") Func vars Match (extract_singleton vars) | 'nothing 'tuple.vars | 'just.name 'var.name ;) (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 pattern (bind1 pop Func token Match token | 'id.name (pure 'var.name) | 'sym.s Cond | (STRING.equal s "{") (lift1 (sequence simple_pattern 'just."}") 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.") ;) Define (sequence parser maybe_terminator) Let check_for_termination (lift1 peek Func token Match token | 'eof True | 'sym.s Match maybe_terminator | 'nothing False | 'just.terminator (STRING.equal s terminator) ; | _ False ;) In Unfold {} (bind1 check_for_termination Func is_terminated If is_terminated (ignore1 pop (pure 'nil)) (lift2 parser (Fold) LIST.cons)) Let chain Unfold {} (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 "." (Fold) (pure 'nil)) Func {access chain} [access & chain])) Where Let id (bind1 pop Func token Match token | 'id.name (pure name) | '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" | (STRING.equal s "<<") "compose_left" | (STRING.equal s ">>") "compose_right" | (STRING.equal s "<-") "apply_left" | (STRING.equal s "->") "apply_right" ; In (bind1 pop Func token Match token | 'op.s (pure (long_name s)) | _ (fail "Unexpected token.") ;) Where Define (match s) (bind1 pop Func token If (is_symbol_with_text token s) (pure token) (fail (STRING.concat [Right "Expected \"" & s & "\"." & 'nil]))) Define (if_match s then else) (bind1 peek Func token If (is_symbol_with_text token s) (ignore1 pop then) else) Define (if_can_match s then else) (bind1 peek Func token If (is_symbol_with_text token s) then else) Where Define (is_symbol_with_text token s) Match token | 'sym.t (STRING.equal s t) | _ False ; Define (extract_singleton items) Match items | 'nil 'nothing | 'cons.{item more_items} Match more_items | 'nil 'just.item | 'cons._ 'nothing ; ; Where Let pop 'pop Let peek 'peek Define (fail message) 'fail.message Define (pure x) 'pure.x Define (bind1 m1 f) 'bind1.{m1 f} Define (bind2 m1 m2 f) 'bind2.{m1 m2 f} Define (lift1 m1 f) 'lift1.{m1 f} Define (lift2 m1 m2 f) 'lift2.{m1 m2 f} Define (lift3 m1 m2 m3 f) 'lift3.{m1 m2 m3 f} Define (ignore1 m1 m2) 'ignore1.{m1 m2} Where Let LIST Package "list" Let OS Package "os" Let SCAN Package "scan" Let STDIO Package "stdio" Let STRING Package "string"