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