{ :file } Where Define (file text) (parse text expand (rule 'file_block)) Where Define (parse text expand parser) Let {i peek} (scan text 0) Let cont 'halt In Iterate {parser cont peek i} Match parser { | 'rule.term (Continue (expand term) cont peek i) | 'fail.message 'fail.{message i} | 'peek (Continue peek cont peek i) | 'pop Let parser peek Let {i peek} (scan text i) In (Continue parser cont peek i) | 'pure.x Match cont { | 'halt 'succeed.x | 'bind1.{f cont} (Continue (f x) cont peek i) } | 'bind1.{p1 f} (Continue p1 'bind1.{f cont} peek i) } Define (expand term) Match term { | 'repeat.{parser follow} (repeat parser follow) | 'file_block file_block | 'expr expr | 'binder_group binder_group | 'binder binder | 'block_body block_body | 'stmt stmt | 'begin_body begin_body | 'chain.prefix (chain prefix) | 'define_pattern define_pattern } Where Define (scan text i) Let {i token} (SCAN.token text (SCAN.skip_whitespace text i)) In Let peek If Pattern 'error.message Matches token (fail message) (pure token) In {i peek} Let file_block (lift2 expr (repeat (ignore1 (match "Where") binder_group) 'eof) Func {expr binder_groups} (LIST.reduce binder_groups expr Func {expr binders} 'block.{(LIST.reverse binders) expr})) Let expr Let app (bind1 peek Func token Let maybe_parser If Pattern 'sym.s Matches token (special_app_parser s) 'nothing In Match maybe_parser { | 'just.parser (ignore1 pop parser) | 'nothing (lift2 expr (repeat expr follow_args) Func {func args} 'app.{func args}) }) Let record Let record_init Let terminators [":" & "}" & 'nil] Let op_keywords ["Prefix" & "Infix" & 'nil] Define (op_label keyword op) (STRING.concat [keyword & "_" & op & 'nil]) In (ignore1 (match ":") (if_match_one_of op_keywords Func keyword (bind1 op Func op1 Let label (op_label keyword op1) In (if_can_match_one_of terminators (pure {label 'var.label}) (lift1 op Func op2 {label 'var.(op_label keyword op2)}))) (bind1 id Func name (if_can_match_one_of terminators (pure {name 'var.name}) (lift1 expr Func expr {name expr}))))) In (if_can_match ":" (lift1 (repeat record_init follow_record_init) Func labels_and_inits 'record.(LIST.unzip labels_and_inits)) (lift1 (repeat expr follow_tuple_contents) Func exprs Match (extract_singleton exprs) { | 'nothing 'tuple.exprs | 'just.expr expr })) In Let infix_app (bind2 expr (repeat (lift2 op expr Func {op right} {op right}) follow_infix_contents) Func {left pairs} Match pairs { | 'nil (pure left) | 'cons.{pair pairs} Let {op right} pair In Let ops_match (LIST.reduce pairs True Func {flag {later_op _}} (And flag (STRING.equal later_op op))) Let rights (LIST.map pairs Func {_ right} right) In If ops_match (pure 'app_infix.{op left [right & rights]}) (fail "Ambiguous infix expression.") }) Let variant (lift2 id (if_match "." expr (pure empty_tuple)) Func {label expr} 'labeled.{label expr}) Let true (pure 'true) Let false (pure 'false) Let if (lift3 expr expr expr Func {test then else} 'if.{test then else}) Let cond Let cond_clause (ignore1 (match "|") (lift2 expr block_body Func {test body} {test body})) In (ignore1 (match "{") (lift1 (repeat cond_clause follow_cond_clauses) Func clauses 'cond.clauses)) Let match Let match_clause (ignore1 (match "|") (lift2 match_pattern block_body Func {pat body} {pat body})) In (lift2 expr (ignore1 (match "{") (repeat match_clause follow_match_clauses)) Func {expr clauses} 'match.{expr clauses}) Let func (lift2 (if_match "{" (repeat pattern follow_tuple_contents) (if_match "_" (pure ['ignore & 'nil]) (lift1 id Func name ['var.name & 'nil]))) block_body Func {pats body} 'func.{pats body}) Let package (lift1 string Func s 'package.(strip_quotes s)) Let iterate (bind2 (if_match "{" (repeat simple_pattern follow_tuple_contents) (lift1 id Func name [name & 'nil])) (if_match "From" (lift1 (if_match "{" (repeat expr follow_tuple_contents) (lift1 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 block_body Func expr 'iterate.{vars inits expr})) Let unfold (bind2 (if_match "{" (repeat simple_pattern follow_tuple_contents) (lift1 id Func name [name & 'nil])) (if_match "From" (lift1 (if_match "{" (repeat expr follow_tuple_contents) (lift1 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 block_body Func expr 'unfold.{vars inits expr})) Let when (lift2 expr begin_body Func {test then} 'if.{test then empty_tuple}) Let prefix (lift1 op Func op 'var.(STRING.append "Prefix_" op)) Let infix (lift1 op Func op 'var.(STRING.append "Infix_" op)) Let pattern_matches (lift3 match_pattern (match "Matches") expr Func {pat _ expr} 'pattern_matches.{pat expr}) In Let okay (pure {}) In Define (check token) Match token { | 'eof (fail "Unexpected end of file.") | 'sym.text Cond { | (STRING.equal text "(") okay | (STRING.equal text "{") okay | (STRING.equal text "[") okay | (STRING.equal text "'") okay | (STRING.equal text "True") okay | (STRING.equal text "False") okay | (STRING.equal text "If") okay | (STRING.equal text "Cond") okay | (STRING.equal text "Match") okay | (STRING.equal text "Func") okay | (STRING.equal text "Package") okay | (STRING.equal text "Block") okay | (STRING.equal text "Iterate") okay | (STRING.equal text "Unfold") okay | (STRING.equal text "Begin") okay | (STRING.equal text "When") okay | (STRING.equal text "Prefix") okay | (STRING.equal text "Infix") okay | (STRING.equal text "Pattern") okay | True (fail "Unexpected token while parsing expression.") } | _ okay } Define (go token) Match token { | 'num.n (pure 'num.n) | 'str.s (pure 'str.s) | 'op.name (lift1 expr Func expr 'app.{'var.(STRING.append "Prefix_" name) [expr & 'nil]}) | 'id.name (chain 'var.name) | 'sym.text Cond { | (STRING.equal text "(") app | (STRING.equal text "{") record | (STRING.equal text "[") infix_app | (STRING.equal text "'") variant | (STRING.equal text "True") true | (STRING.equal text "False") false | (STRING.equal text "If") if | (STRING.equal text "Cond") cond | (STRING.equal text "Match") match | (STRING.equal text "Func") func | (STRING.equal text "Package") package | (STRING.equal text "Block") block_body | (STRING.equal text "Iterate") iterate | (STRING.equal text "Unfold") unfold | (STRING.equal text "Begin") begin_body | (STRING.equal text "When") when | (STRING.equal text "Prefix") prefix | (STRING.equal text "Infix") infix | (STRING.equal text "Pattern") pattern_matches } } In (ignore1 (bind1 peek check) (bind1 pop go)) Let binder_group (if_can_match_one_of binder_keywords (lift2 binder binder_group LIST.cons) (pure 'nil)) Let binder Let let_binder (lift2 (if_match "{" (lift1 (repeat simple_pattern follow_tuple_contents) Func vars Match (extract_singleton vars) { | 'nothing 'tuple.vars | 'just.name 'var.name }) (lift1 id Func name 'var.name)) block_body Func {pat expr} 'let.{pat expr}) Let define_binder (lift2 define_pattern block_body Func {{pat pats_chain} expr} Let expr (LIST.reduce pats_chain expr Func {expr pats} 'func.{pats expr}) In 'let.{pat expr}) Let open_binder Let subpat Let terminators [":" & "}" & 'nil] Let op_keywords ["Prefix" & "Infix" & 'nil] Define (op_label keyword op) (STRING.concat [keyword & "_" & op & 'nil]) In (ignore1 (match ":") (if_match_one_of op_keywords Func keyword (bind1 op Func op1 Let label (op_label keyword op1) In (if_can_match_one_of terminators (pure {label label}) (lift1 op Func op2 {label (op_label keyword op2)}))) (bind1 id Func label (if_can_match_one_of terminators (pure {label label}) (lift1 id Func var {label var}))))) In (lift2 (if_match "Package" (lift1 string Func s 'package.(strip_quotes s)) (lift1 id Func var 'var.var)) (ignore1 (match "{") (repeat subpat follow_record_init)) Func {expr pairs} 'open.{expr pairs}) In (bind1 peek Func token Let maybe_binder If Pattern 'sym.s Matches token Cond { | (STRING.equal s "Let") 'just.let_binder | (STRING.equal s "Define") 'just.define_binder | (STRING.equal s "Open") 'just.open_binder | True 'nothing } 'nothing In Match maybe_binder { | 'nothing (fail "Expected binder.") | 'just.binder (ignore1 pop binder) }) Let block_body (if_can_match_one_of binder_keywords (lift2 binder_group (ignore1 (match "In") block_body) Func {binders expr} 'block.{(LIST.reverse binders) expr}) expr) Let stmt (if_can_match_one_of binder_keywords binder expr) Let begin_body Let statements Define (combine_statements stmts) Let stmts (LIST.reverse stmts) In Match stmts { | 'nil empty_tuple | 'cons.{final_term definite_stmts} Let {stmts expr} Match final_term { | 'let._ {stmts empty_tuple} | _ {definite_stmts final_term} } In Iterate {expr stmts binders} From {expr stmts 'nil} Match stmts { | 'nil Match binders { | 'nil expr | 'cons._ 'block.{(LIST.reverse binders) expr} } | 'cons.{stmt stmts} Match stmt { | 'let._ Let expr Match binders { | 'nil expr | 'cons._ 'block.{(LIST.reverse binders) expr} } In Let expr 'block.{[stmt & 'nil] expr} In (Continue expr stmts 'nil) | _ Let binder 'let.{empty_tuple stmt} In (Continue expr stmts [binder & binders]) } } } In (lift1 (repeat stmt follow_stmt) combine_statements) In Let cond_clause (ignore1 (match "|") (lift2 expr statements Func {test body} {test body})) Let match_clause (ignore1 (match "|") (lift2 match_pattern statements Func {pat body} {pat body})) Define (ensure_completeness mode clauses) Let clauses (LIST.reverse clauses) In Match mode { | 'cond Match clauses { | 'nil [{'true empty_tuple} & 'nil] | 'cons.{clause _} Let {test _} clause In (LIST.reverse If Pattern 'true Matches test clauses [{'true empty_tuple} & clauses]) } | 'match Match clauses { | 'nil [{'default empty_tuple} & 'nil] | 'cons.{clause _} Let {pat _} clause In (LIST.reverse If Pattern 'default Matches pat clauses [{'default empty_tuple} & clauses]) } } In (if_match "Cond" (ignore1 (match "{") (lift1 (repeat cond_clause follow_cond_clauses) Func clauses 'cond.(ensure_completeness 'cond clauses))) (if_match "Match" (bind1 expr Func expr (ignore1 (match "{") (lift1 (repeat match_clause follow_match_clauses) Func clauses Let clauses (ensure_completeness 'match clauses) In 'match.{expr clauses}))) (ignore1 (match "{") (lift2 statements (match "}") Func {expr _} expr)))) Where Let binder_keywords ["Let" & "Define" & "Open" & 'nil] Define (special_app_parser s) Define (and expr conj) If Pattern 'true Matches conj expr 'and.{expr conj} Define (or expr disj) If Pattern 'false Matches disj expr 'or.{expr disj} In Cond { | (STRING.equal s "Prim") Let parser (lift2 id (repeat expr follow_args) Func {name args} 'app.{'prim.name args}) In 'just.parser | (STRING.equal s "Continue") Let parser (lift1 (repeat expr follow_args) Func exprs 'continue.exprs) In 'just.parser | (STRING.equal s "Fold") Let parser (lift1 (repeat expr follow_args) Func exprs 'fold.exprs) In 'just.parser | (STRING.equal s "Reduce") Let parser (bind2 op (repeat expr follow_args) Func {op exprs} Match exprs { | 'nil (fail "Missing arguments.") | 'cons.{left rights} Match rights { | 'nil (pure left) | 'cons._ (pure 'app_infix.{op left rights}) } }) In 'just.parser | (STRING.equal s "And") Let parser (lift1 (repeat expr follow_args) Func exprs (LIST.fold exprs 'true and)) In 'just.parser | (STRING.equal s "Or") Let parser (lift1 (repeat expr follow_args) Func exprs (LIST.fold exprs 'false or)) In 'just.parser | True 'nothing } Let match_pattern Let vars (if_match "{" (lift1 (repeat simple_pattern follow_tuple_contents) 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 peek Func token Match token { | 'sym.s Cond { | (STRING.equal s "_") (ignore1 pop (pure 'default)) | (STRING.equal s "'") (ignore1 pop (lift2 id (if_match "." vars (pure empty_tuple)) Func {label vars} 'labeled.{label vars})) | True (fail "Malformed Match pattern.") } | 'eof (fail "Unexpected end of file.") | _ (fail "Malformed Match pattern.") }) Let define_pattern Let define_subpattern (lift2 define_pattern (repeat pattern follow_args) Func {{pat more_pats} pats} {pat [pats & more_pats]}) Let infix_arg_subpattern (if_match "[" (bind1 pattern Func p (ignore1 (match "]") (pure 'nesting.p))) (lift1 pattern Func p 'single.p)) In Let infix_subpattern (lift3 (match "[") (lift1 (bind2 infix_arg_subpattern op Func {p op} Match p { | 'single.p (lift1 infix_arg_subpattern Func q Match q { | 'single.q {'not p op q} | 'nesting.q {'right p op q} }) | 'nesting.p (lift1 pattern Func q {'left p op q}) }) Func {assoc p op q} {'infix_op.{op assoc} [[p & q & 'nil] & 'nil]}) (match "]") Func {_ pat _} pat) In (if_match "(" (if_can_match "(" define_subpattern (if_can_match "[" define_subpattern (lift2 id (repeat pattern follow_args) Func {name pats} {'var.name [pats & 'nil]}))) (bind1 peek Func token If Pattern 'op._ Matches token (lift2 op pattern Func {op p} {'prefix_op.op [[p & 'nil] & 'nil]}) infix_subpattern)) Where Let string (bind1 peek Func token If Pattern 'str.s Matches token (ignore1 pop (pure s)) (fail "Expected a string.")) Let op (bind1 peek Func token If Pattern 'op.s Matches token (ignore1 pop (pure s)) (fail "Expected an operator.")) Let pattern (if_match "{" (lift1 (repeat simple_pattern follow_tuple_contents) Func pats Match (extract_singleton pats) { | 'nothing 'tuple.pats | 'just.name 'var.name }) (if_match "_" (pure 'ignore) (lift1 id Func name 'var.name))) Where Let simple_pattern (if_match "_" (pure "_") id) Define (repeat parser follow) (bind1 peek Func token Match follow { | 'symbol.s If (And [Pattern 'sym.t Matches token] (STRING.equal s t)) (ignore1 pop (pure 'nil)) (lift2 parser (repeat parser follow) LIST.cons) | 'symbol_set.strings If (And [Pattern 'sym.s Matches token] [s ? strings]) (pure 'nil) (lift2 parser (repeat parser follow) LIST.cons) | 'eof If Pattern 'eof Matches token (pure 'nil) (lift2 parser (repeat parser follow) LIST.cons) }) Define (chain prefix) (if_match "." (bind1 id Func field (chain 'record_fetch.{prefix field})) (pure prefix)) Where Let id (bind1 peek Func token Match token { | 'id.name (ignore1 pop (pure name)) | 'eof (fail "Unexpected end of file.") | _ (fail "Unexpected token.") }) Where Define (match s) (if_can_match s pop (fail (STRING.concat ["Expected \"" & s & "\"." & 'nil]))) Define (if_match s then else) (if_can_match s (ignore1 pop then) else) Where Define (if_can_match s then else) (bind1 peek Func token If (And [Pattern 'sym.t Matches token] (STRING.equal s t)) then else) Define (if_match_one_of strings then else) (bind1 peek Func token If Pattern 'sym.s Matches token If [s ? strings] (ignore1 pop (then s)) else else) Define (if_can_match_one_of strings then else) (bind1 peek Func token If (And [Pattern 'sym.s Matches token] [s ? strings]) then else) Where Define [s ? strings] Iterate strings (And [Pattern 'cons.{t strings} Matches strings] (Or (STRING.equal s t) (Continue strings))) Define (extract_singleton items) Match items { | 'nil 'nothing | 'cons.{item more_items} Match more_items { | 'nil 'just.item | 'cons._ 'nothing } } Define (strip_quotes s) (STRING.clip s 1 [(STRING.length s) - 1]) Let empty_tuple 'tuple.'nil Where Let follow_args 'symbol.")" Let follow_record_init 'symbol."}" Let follow_tuple_contents 'symbol."}" Let follow_infix_contents 'symbol."]" Let follow_cond_clauses 'symbol."}" Let follow_match_clauses 'symbol."}" Let follow_stmt 'symbol_set.["|" & "}" & 'nil] Define (repeat parser follow) (rule 'repeat.{parser follow}) Let file_block (rule 'file_block) Let expr (rule 'expr) Let binder_group (rule 'binder_group) Let binder (rule 'binder) Let block_body (rule 'block_body) Let stmt (rule 'stmt) Let begin_body (rule 'begin_body) Define (chain prefix) (rule 'chain.prefix) Let define_pattern (rule 'define_pattern) Where Define (lift3 p1 p2 p3 f) (bind1 p1 Func x1 (bind1 p2 Func x2 (bind1 p3 Func x3 (pure (f x1 x2 x3))))) Define (lift2 p1 p2 f) (bind1 p1 Func x1 (bind1 p2 Func x2 (pure (f x1 x2)))) Define (lift1 p1 f) (bind1 p1 Func x1 (pure (f x1))) Define (bind2 p1 p2 f) (bind1 p1 Func x1 (bind1 p2 Func x2 (f x1 x2))) Define (ignore1 p1 p2) (bind1 p1 Func _ p2) Where Let pop 'pop Let peek 'peek Define (rule term) 'rule.term Define (fail message) 'fail.message Define (pure x) 'pure.x Define (bind1 p1 f) 'bind1.{p1 f} Where Open Z { :Infix != :Infix - } Open LIST {:Infix &} Where Let LIST Package "list" Let OS Package "os" Let SCAN Package "scan" Let STDIO Package "stdio" Let STRING Package "string" Let Z Package "z"