Language 84

File

language84-0.5/parse.84

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