{
: 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"