parse.84

{
: file
}

Where

Define (file text)
    (parse text expand (rule 'file_block))

Where

Define (parse text expand parser)
    Let {i token} (SCAN.token text (SCAN.whitespace text 0))
    In
    Iterate {parser cont peek i} From {parser 'halt 'pure.token i}
        Match parser {
        | 'rule.term (Continue (expand term) cont peek i)
        | 'fail.message 'fail.{message i}
        | 'peek (Continue peek cont peek i)
        | 'pop
            Let {i token} (SCAN.token text (SCAN.whitespace text i))
            In
            (Continue peek cont 'pure.token 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 {
    | 'file_block file_block
    | 'expr expr
    | 'binder_group binder_group
    | 'binder binder
    | 'block_body block_body
    | 'stmt stmt
    | 'begin_body begin_body
    | 'sequence2.{parser termination_check} (sequence2 parser termination_check)
    | 'sequence.{parser maybe_terminator} (sequence parser maybe_terminator)
    | 'chain chain
    | 'define_pattern define_pattern
    }

Where

Let file_block
    (lift2 (rule 'expr)
        (sequence (ignore1 (match "Where") (rule 'binder_group)) 'nothing)
        Func {expr binder_groups}
            (LIST.reduce binder_groups expr
                Func {expr binders}
                    'block.{(LIST.reverse binders) expr}))

Let expr
    Let okay (pure {})
    In
    Define (check token)
        Match token {
        | 'eof (fail "Unexpected end of file.")
        | 'op.name
            If (Or (STRING.equal name "-") (STRING.equal name "!"))
                okay
                (fail "Unexpected unary operator.")
        | '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
            | 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
            Cond {
            | (STRING.equal name "-")
                (lift1 (rule 'expr)
                    Func expr 'app.{'prim."negate" [expr & 'nil]})
            | (STRING.equal name "!")
                (lift1 (rule 'expr)
                    Func expr 'if.{expr 'false 'true})
            }
        | 'id.name
            (if_match "."
                (lift1 chain
                    Func chain 'chain.{'var.name chain})
                (pure 'var.name))
        | 'sym.text
            Cond {
            | (STRING.equal text "(")
                (bind1 peek
                    Func token
                        Let maybe_parser
                            Match token {
                            | 'sym.s (special_app_parser 'expr s)
                            | _ 'nothing
                            }
                        In
                        Match maybe_parser {
                        | 'just.parser
                            (ignore1 pop parser)
                        | 'nothing
                            (lift2 (rule 'expr) (sequence (rule 'expr) 'just.")")
                                Func {func args} 'app.{func args})
                        })
            | (STRING.equal text "{")
                Let record_init
                    (bind2
                        (ignore1 (match ":") id)
                        (lift1 peek
                            Func token
                                Match token {
                                | 'sym.s
                                    (Or (STRING.equal s ":") (STRING.equal s "}"))
                                | _ False
                                })
                        Func {name is_expr_omitted}
                            If is_expr_omitted
                                (pure {name 'var.name})
                                (lift1 (rule '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 (rule 'expr) 'just."}")
                        Func exprs
                            Match (extract_singleton exprs) {
                            | 'nothing 'tuple.exprs
                            | 'just.expr expr
                            }))
            | (STRING.equal text "[")
                (bind2 (rule 'expr)
                    (sequence 
                        (lift2 op (rule 'expr)
                            Func {op right} {op right})
                        'just."]")
                    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
                                (infix_expr op left [right & rights])
                                (fail "Ambiguous infix expression.")
                        })
            | (STRING.equal text "'")
                (lift2 id (if_match "." (rule 'expr) (pure empty_tuple))
                    Func {label expr} 'labeled.{label expr})
            | (STRING.equal text "True")
                (pure 'true)
            | (STRING.equal text "False")
                (pure 'false)
            | (STRING.equal text "If")
                (lift3 (rule 'expr) (rule 'expr) (rule 'expr)
                    Func {test then else} 'if.{test then else})
            | (STRING.equal text "Cond")
                Let cond_clause
                    (ignore1 (match "|")
                        (lift2 (rule 'expr) (rule 'block_body)
                            Func {test body} {test body}))
                In
                (ignore1 (match "{")
                    (lift1 (sequence cond_clause 'just."}")
                        Func clauses 'cond.clauses))
            | (STRING.equal text "Match")
                Let match_clause
                    (ignore1 (match "|")
                        (lift2 match_pattern (rule 'block_body)
                            Func {pat body} {pat body}))
                In
                (lift2 (rule 'expr)
                    (ignore1 (match "{") (sequence match_clause 'just."}"))
                    Func {expr clauses} 'match.{expr clauses})
            | (STRING.equal text "Func")
                (lift2
                    (if_match "{"
                        (sequence pattern 'just."}")
                        (if_match "_"
                            (pure ['ignore & 'nil])
                            (lift1 id
                                Func name ['var.name & 'nil])))
                    (rule 'block_body)
                    Func {pats body} 'func.{pats body})
            | (STRING.equal text "Package")
                (bind1 peek
                    Func token
                        Match token {
                        | 'str.s
                            Define (strip_quotes s)
                                (STRING.clip s 1 [(STRING.length s) - 1])
                            In
                            (ignore1 pop (pure 'package.(strip_quotes s)))
                        | _ (fail "Malformed Package expression.")
                        })
            | (STRING.equal text "Block")
                (rule 'block_body)
            | (STRING.equal text "Iterate")
                (bind2
                    (if_match "{"
                        (sequence simple_pattern 'just."}")
                        (lift1 id
                            Func name [name & 'nil]))
                    (if_match "From"
                        (lift1
                            (if_match "{"
                                (sequence (rule 'expr) 'just."}")
                                (lift1 (rule '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 (rule '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 (rule 'expr) 'just."}")
                                (lift1 (rule '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 (rule 'block_body)
                                Func expr 'unfold.{vars inits expr}))
            | (STRING.equal text "Begin")
                (rule 'begin_body)
            | (STRING.equal text "When")
                (lift2 (rule 'expr) (rule 'begin_body)
                    Func {test then} 'if.{test then empty_tuple})
            }
        }
    In
    (ignore1 (bind1 peek check) (bind1 pop go))

Let binder_group
    (bind1 peek
        Func token
            Let has_binder
                Match token {
                | 'sym.s (Or (STRING.equal s "Let") (STRING.equal s "Define"))
                | _ False
                }
            In
            If has_binder
                (lift2 (rule 'binder) (rule 'binder_group) LIST.cons)
                (pure 'nil))

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))
            (rule 'block_body)
            Func {pat expr} 'let.{pat expr})
    Let define_binder
        (lift2 (rule 'define_pattern) (rule 'block_body)
            Func {{name pats_chain} expr}
                Let expr
                    (LIST.reduce pats_chain expr
                        Func {expr pats} 'func.{pats expr})
                In
                'let.{'var.name expr})
    In
    (bind1 peek
        Func token
            Let maybe_binder
                Match token {
                | 'sym.s
                    Cond {
                    | (STRING.equal s "Let") 'just.let_binder
                    | (STRING.equal s "Define") 'just.define_binder
                    | True 'nothing
                    }
                | _ 'nothing
                }
            In
            Match maybe_binder {
            | 'nothing (fail "Expected binder.")
            | 'just.binder (ignore1 pop binder)
            })

Let block_body
    (bind1 peek
        Func token
            Let has_binder
                Match token {
                | 'sym.s (Or (STRING.equal s "Let") (STRING.equal s "Define"))
                | _ False
                }
            In
            If has_binder
                (lift2 (rule 'binder_group) (ignore1 (match "In") (rule 'block_body))
                    Func {binders expr} 'block.{(LIST.reverse binders) expr})
                (rule '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
            | 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
                            Match token {
                            | 'sym.s (special_app_parser 'stmt s)
                            | _ 'nothing
                            }
                        In
                        Match maybe_parser {
                        | 'just.parser
                            (ignore1 pop parser)
                        | 'nothing
                            (lift2 (rule 'expr) (sequence (rule 'expr) 'just.")")
                                Func {func args} 'app.{func args})
                        })
            | True (rule 'expr)
            }
        }
    In
    (bind1 peek
        Func token
            Let has_binder
                Match token {
                | 'sym.s (Or (STRING.equal s "Let") (STRING.equal s "Define"))
                | _ False
                }
            In
            If has_binder
                (rule 'binder)
                (ignore1 (bind1 peek check) (bind1 peek go)))

Let begin_body
    Let statements
        Define (termination_check token)
            Match token {
            | 'sym.s (Or (STRING.equal s "|") (STRING.equal s "}"))
            | _ False
            }
        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 (sequence2 (rule 'stmt) termination_check)
            combine_statements)
    In
    Let cond_clause
        (ignore1 (match "|")
            (lift2 (rule '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
                    Match test {
                    | 'true clauses
                    | _ [{'true empty_tuple} & clauses]
                    })
            }
        | 'match
            Match clauses {
            | 'nil [{'default empty_tuple} & 'nil]
            | 'cons.{clause _}
                Let {pat _} clause
                In
                (LIST.reverse
                    Match pat {
                    | 'default clauses
                    | _ [{'default empty_tuple} & clauses]
                    })
            }
        }
    In
    (if_match "Cond"
        (ignore1 (match "{")
            (lift1 (sequence cond_clause 'just."}")
                Func clauses 'cond.(ensure_completeness 'cond clauses)))
        (if_match "Match"
            (bind1 (rule 'expr)
                Func expr
                    (ignore1 (match "{")
                        (lift1 (sequence match_clause 'just."}")
                            Func clauses
                                Let clauses (ensure_completeness 'match clauses)
                                In
                                'match.{expr clauses})))
            (ignore1 (match "{")
                (lift2 statements (match "}")
                    Func {expr _} expr))))

Where

Define (special_app_parser mode s)
    Let maybe_parser
        Match mode {
        | 'stmt
            Cond {
            | (STRING.equal s "Return")
                Let parser
                    (lift1 (sequence (rule 'expr) 'just.")")
                        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 (sequence (rule 'expr) 'just.")")
                    Func {name args} 'app.{'prim.name args})
            In
            'just.parser
        | (STRING.equal s "Continue")
            Let parser
                (lift1 (sequence (rule 'expr) 'just.")")
                    Func exprs 'continue.exprs)
            In
            'just.parser
        | (STRING.equal s "Fold")
            Let parser
                (lift1 (sequence (rule 'expr) 'just.")")
                    Func exprs 'fold.exprs)
            In
            'just.parser
        | (STRING.equal s "Reduce")
            Let parser
                (bind2 op (sequence (rule 'expr) 'just.")")
                    Func {op exprs}
                        Match exprs {
                        | 'nil (fail "Missing arguments.")
                        | 'cons.{left rights}
                            Match rights {
                            | 'nil (pure left)
                            | 'cons._ (infix_expr op left rights)
                            }
                        })
            In
            'just.parser
        | (STRING.equal s "And")
            Let parser
                (lift1 (sequence (rule 'expr) 'just.")")
                    Func exprs
                        Match exprs {
                        | 'nil 'true
                        | 'cons.{expr exprs}
                            (LIST.reduce exprs expr
                                Func {conj expr} 'and.{conj expr})
                        })
            In
            'just.parser
        | (STRING.equal s "Or")
            Let parser
                (lift1 (sequence (rule 'expr) 'just.")")
                    Func exprs
                        Match exprs {
                        | 'nil 'false
                        | 'cons.{expr exprs}
                            (LIST.reduce exprs expr
                                Func {disj expr} 'or.{disj expr})
                        })
            In
            'just.parser
        | True
            'nothing
        }
    }

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 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
    (ignore1 (match "(")
        (if_can_match "("
            (lift2 (rule 'define_pattern) (sequence pattern 'just.")")
                Func {{name more_pats} pats}
                    {name [pats & more_pats]})
            (lift2 id (sequence pattern 'just.")")
                Func {name pats}
                    {name [pats & 'nil]})))

Where

Define (infix_expr op left rights)
    Define (app left op right)
        Cond {
        | (STRING.equal op "compose_left")
            'app.{'prim."compose" [left & right & 'nil]}
        | (STRING.equal op "compose_right")
            'app.{'prim."compose" [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 [left & right & 'nil]}
        }
    In
    Let assoc
        Cond {
        | (STRING.equal op "add") 'left
        | (STRING.equal op "subtract") 'not
        | (STRING.equal op "multiply") 'left
        | (STRING.equal op "quotient") 'not
        | (STRING.equal op "remainder") 'not
        | (STRING.equal op "less") 'not
        | (STRING.equal op "greater") 'not
        | (STRING.equal op "equal") 'not
        | (STRING.equal op "not_equal") 'not
        | (STRING.equal op "less_or_equal") 'not
        | (STRING.equal op "greater_or_equal") 'not
        | (STRING.equal op "cons") 'right
        | (STRING.equal op "compose_left") 'right
        | (STRING.equal op "compose_right") 'left
        | (STRING.equal op "apply_left") 'right
        | (STRING.equal op "apply_right") 'left
        }
    In
    Define (reduce_left op left rights)
        (pure
            (LIST.reduce rights left
                Func {left right} (app left op right)))
    Define (reduce_right op left rights)
        (pure
            Match (LIST.reverse [left & rights]) {
            | 'cons.{right lefts}
                (LIST.reduce lefts right
                    Func {right left} (app left op right))
            })
    Define (reduce_not op left rights)
        Match rights {
        | 'cons.{right rights}
            Match rights {
            | 'nil (pure (app left op right))
            | 'cons._ (fail "No associativity rule for operator.")
            }
        }
    In
    Let reduce
        Match assoc {
        | 'left reduce_left
        | 'right reduce_right
        | 'not reduce_not
        }
    In
    (reduce op left rights)

Let pattern
    (bind1 peek
        Func token
            Match token {
            | 'id.name (ignore1 pop (pure 'var.name))
            | 'sym.s
                Cond {
                | (STRING.equal s "{")
                    (ignore1 pop
                        (lift1 (sequence simple_pattern 'just."}")
                            Func pats 'tuple.pats))
                | (STRING.equal s "_") (ignore1 pop (pure 'ignore))
                | True (fail "Invalid pattern.")
                }
            | 'eof (fail "Unexpected end of file.")
            | _ (fail "Unexpected token while parsing pattern.")
            })

Where

Let simple_pattern
    (bind1 peek
        Func token
            Match token {
            | 'id.name (ignore1 pop (pure name))
            | 'sym.s
                Cond {
                | (STRING.equal s "_") (ignore1 pop (pure "_"))
                | True (fail "Invalid pattern.")
                }
            | 'eof (fail "Unexpected end of file.")
            | _ (fail "Unexpected token.")
            })

Define (sequence2 parser termination_check)
    (bind1 (lift1 peek termination_check)
        Func is_terminated
            If is_terminated
                (pure 'nil)
                (lift2 parser (rule 'sequence2.{parser termination_check})
                    LIST.cons))

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
    (bind1 check_for_termination
        Func is_terminated
            If is_terminated
                (ignore1 pop (pure 'nil))
                (lift2 parser (rule 'sequence.{parser maybe_terminator}) 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 "." (rule '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.")
            })

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 peek
        Func token
            Match token {
            | 'op.s (ignore1 pop (pure (long_name s)))
            | _ (fail "Unexpected token.")
            })

Where

Define (match s)
    (bind1 peek
        Func token
            If (is_symbol_with_text token s)
                pop
                (fail (STRING.concat ["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
        }
    }

Let empty_tuple 'tuple.'nil

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

Let LIST Package "list"
Let OS Package "os"
Let SCAN Package "scan"
Let STDIO Package "stdio"
Let STRING Package "string"