Language 84

File

language84-0.7/parse.84

{
: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 chain
    | '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 'expr 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
            (if_match "."
                (lift1 chain
                    Func chain 'chain.{'var.name chain})
                (pure '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
    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 "If") okay
            | (STRING.equal text "Cond") okay
            | (STRING.equal text "Match") 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
            | True (fail "Unexpected token while parsing statement.")
            }
        | _ (fail "Unexpected token while parsing statement.")
        }
    Define (go token)
        Match token {
        | 'sym.text
            Cond {
            | (STRING.equal text "(")
                (bind1 (ignore1 pop peek)
                    Func token
                        Let maybe_parser
                            If Pattern 'sym.s Matches token
                                (special_app_parser 'stmt s)
                                'nothing
                        In
                        Match maybe_parser {
                        | 'just.parser
                            (ignore1 pop parser)
                        | 'nothing
                            (lift2 expr (repeat expr follow_args)
                                Func {func args} 'app.{func args})
                        })
            | True expr
            }
        }
    In
    (if_can_match_one_of binder_keywords
        binder
        (ignore1 (bind1 peek check) (bind1 peek go)))

Let begin_body
    Let statements
        Define (combine_statements stmts)
            Match (LIST.reverse stmts) {
            | 'nil empty_tuple
            | 'cons.{final_term definite_stmts}
                Let {stmts expr}
                    Match final_term {
                    | 'return.exprs
                        {
                            definite_stmts
                            Match (extract_singleton exprs) {
                            | 'nothing 'tuple.exprs
                            | 'just.expr expr
                            }
                        }
                    | 'continue._
                        {
                            definite_stmts
                            final_term
                        }
                    | 'let.{pat expr}
                        {
                            definite_stmts
                            expr
                        }
                    | _
                        {
                            'cons.{final_term definite_stmts}
                            empty_tuple
                        }
                    }
                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 mode 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}
    Let maybe_parser
        Match mode {
        | 'stmt
            Cond {
            | (STRING.equal s "Return")
                Let parser
                    (lift1 (repeat expr follow_args)
                        Func exprs 'return.exprs)
                In
                'just.parser
            | True 'nothing
            }
        | 'expr 'nothing
        }
    In
    Match maybe_parser {
    | 'just._ maybe_parser
    | 'nothing
        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)
            })

Let chain
    (bind1 peek
        Func token
            Let access
                Match token {
                | 'id.name (ignore1 pop (pure 'id.name))
                | 'num.n (ignore1 pop (pure 'num.n))
                | 'eof (fail "Unexpected end of file.")
                | _ (fail "Unexpected token.")
                }
            In
            (lift2 access (if_match "." chain (pure 'nil))
                Func {access chain} [access & chain]))

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)

Let chain (rule 'chain)

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"