207 lines
6.9 KiB
Text
207 lines
6.9 KiB
Text
import init.lean.parser.macro init.lean.parser.identifier system.io
|
||
import .macro1
|
||
|
||
set_option eqn_compiler.lemmas false
|
||
|
||
attribute [instance] lean.name.has_lt_quick
|
||
open lean.parser
|
||
open lean.parser.monad_parser
|
||
|
||
def test {α} [decidable_eq α] (p : parser α) (s : string) (e : α) : io unit :=
|
||
match parser_t.parse p s with
|
||
| except.ok a := if a = e then return () else io.print_ln "unexpected result"
|
||
| except.error e := io.print_ln (e.to_string s)
|
||
|
||
def test_failure {α} (p : parser α) (s : string) : io unit :=
|
||
match parser_t.parse p s with
|
||
| except.ok a := io.print_ln "unexpected success"
|
||
| except.error e := return ()
|
||
|
||
def show_result {α} [has_to_string α] (s : string) (p : except message α) : io unit :=
|
||
match p with
|
||
| except.ok a := io.print_ln "result: " >> io.print_ln (to_string a)
|
||
| except.error e := io.print_ln (e.to_string s)
|
||
|
||
namespace lean.parser.syntax.combinators
|
||
variables {m : Type → Type} [monad m]
|
||
|
||
def ident : parser_t m syntax :=
|
||
do start ← pos,
|
||
n ← identifier,
|
||
stop ← pos,
|
||
whitespace,
|
||
pure $ syntax.ident ⟨some ⟨start, stop⟩, n, none, none⟩
|
||
|
||
def sym (sym : string) : parser_t m syntax :=
|
||
do start ← pos,
|
||
str sym,
|
||
stop ← pos,
|
||
whitespace,
|
||
pure $ syntax.atom ⟨some ⟨start, stop⟩, atomic_val.string sym⟩
|
||
|
||
def num : parser_t m syntax :=
|
||
do start ← pos,
|
||
n ← monad_parser.num,
|
||
stop ← pos,
|
||
whitespace,
|
||
pure $ syntax.atom ⟨some ⟨start, stop⟩, atomic_val.number n⟩
|
||
|
||
def node (n : name) (ps : list (parser_t m syntax)) : parser_t m syntax :=
|
||
do args ← ps.mmap id,
|
||
pure $ syntax.node ⟨n, args⟩
|
||
|
||
def many (p : parser_t m syntax) : parser_t m syntax :=
|
||
do args ← many p,
|
||
pure $ syntax.node ⟨name.anonymous, args⟩
|
||
|
||
def wrap_with_node (n : name) (stx : syntax) : syntax :=
|
||
syntax.node ⟨n, [stx]⟩
|
||
|
||
end lean.parser.syntax.combinators
|
||
|
||
namespace lisp
|
||
open lean.parser
|
||
open lean.parser.syntax.combinators
|
||
|
||
abbreviation read_m := parser syntax
|
||
abbreviation ws {m} [monad m] : parser_t m unit := whitespace
|
||
|
||
def parse_list (parse : read_m) : read_m :=
|
||
(node `list [sym "(", many parse, sym ")"] <|>
|
||
node `list [sym "[", many parse, sym "]"]) <?> "list"
|
||
|
||
def parse : ℕ → read_m
|
||
| 0 := unexpected "nesting limit exceeded"
|
||
| (n+1) := ident <|> num <|> parse_list (parse n)
|
||
|
||
def let_macro := {macro .
|
||
name := `let,
|
||
expand := some $ λ node,
|
||
match node.args with
|
||
| [syntax.node ⟨name.anonymous, clauses⟩, body] :=
|
||
do clauses ← clauses.mmap (λ cl, match cl with
|
||
| syntax.node ⟨name.anonymous, [v, e]⟩ := some (v, e)
|
||
| stx := none),
|
||
let ⟨vars, exprs⟩ := clauses.unzip,
|
||
syntax.node {macro := `let_core, args := [
|
||
syntax.node ⟨name.anonymous, exprs⟩,
|
||
syntax.node {macro := `bind, args := [
|
||
syntax.node {macro := name.anonymous, args := vars},
|
||
body
|
||
]}
|
||
]}
|
||
| _ := none}
|
||
|
||
def mk_list_stx (args : list syntax) : syntax :=
|
||
syntax.node ⟨`list, [
|
||
syntax.atom ⟨none, atomic_val.string "("⟩,
|
||
syntax.node ⟨name.anonymous, args⟩,
|
||
syntax.atom ⟨none, atomic_val.string ")"⟩]⟩
|
||
|
||
def mk_ident (n : name) : syntax :=
|
||
syntax.ident ⟨none, n, none, none⟩
|
||
|
||
def match_list_stx : syntax → option (list syntax)
|
||
| (syntax.node ⟨`list, [lp, syntax.node ⟨name.anonymous, args⟩, rp]⟩) := some args
|
||
| _ := none
|
||
|
||
/- From "Macros that Work Together" -/
|
||
def or_macro := {macro .
|
||
name := `or,
|
||
expand := some $ λ n,
|
||
-- '(or e1 e2)'
|
||
do [e1, e2] ← pure n.args | none,
|
||
-- '(let ([tmp e1]) (if tmp tmp e2))'
|
||
mk_list_stx [
|
||
mk_ident `let,
|
||
mk_list_stx [mk_list_stx [mk_ident `tmp, e1]],
|
||
mk_list_stx [mk_ident `if, mk_ident `tmp, mk_ident `tmp, e2]]}
|
||
|
||
/-- Recognizes and translates calls to built-in macros -/
|
||
def list_macro := {macro .
|
||
name := `list,
|
||
expand := some $ λ n,
|
||
match match_list_stx (syntax.node n) with
|
||
| some [syntax.ident {name := `lambda, ..}, vars, body] :=
|
||
do vars ← match_list_stx vars,
|
||
syntax.node ⟨`lambda, [syntax.node ⟨name.anonymous, vars⟩, body]⟩
|
||
| some (syntax.ident {name := `or, ..}::args) :=
|
||
syntax.node ⟨`or, args⟩
|
||
| some (syntax.ident {name := `if, ..}::args) :=
|
||
syntax.node ⟨`if, args⟩
|
||
| some [syntax.ident {name := `let, ..}, clauses, body] :=
|
||
do clauses ← match_list_stx clauses,
|
||
clauses ← clauses.mmap (λ cl, match match_list_stx cl with
|
||
| some cl := some $ syntax.node ⟨name.anonymous, cl⟩
|
||
| none := none),
|
||
syntax.node ⟨`let, [syntax.node ⟨name.anonymous, clauses⟩, body]⟩
|
||
| _ := none}
|
||
|
||
inductive value
|
||
| number (n : nat)
|
||
| list (l : list value)
|
||
| closure (env : list value) (code : syntax)
|
||
|
||
-- TODO(Sebastian): shouldn't be meta
|
||
meta def value.to_string : value → string
|
||
| (value.number n) := to_string n
|
||
| (value.list l) := (l.map (λ v, value.to_string v)).to_string
|
||
| (value.closure _ _) := "#<function>"
|
||
|
||
meta def eval : nat → syntax → list value → except string value
|
||
| _ (syntax.atom ⟨_, atomic_val.number n⟩) env := except.ok $ value.number n
|
||
| _ (syntax.ident {res := some {decl := sum.inl idx, ..}, ..}) env :=
|
||
(match env.nth idx with
|
||
| some v := except.ok v
|
||
| none := throw "aaah")
|
||
| _ (syntax.node ⟨`lambda_core, [syntax.node ⟨`bind, [_, body]⟩]⟩) env :=
|
||
except.ok $ value.closure env body
|
||
| (fuel+1) (syntax.node ⟨`let_core, [syntax.node ⟨_, [expr]⟩, syntax.node ⟨`bind, [_, body]⟩]⟩) env :=
|
||
do v ← eval fuel expr env,
|
||
eval fuel body (v::env)
|
||
| (fuel+1) (syntax.node ⟨`if, [cond, t, e]⟩) env :=
|
||
do cond ← eval fuel cond env,
|
||
eval fuel (match cond with
|
||
| value.number 0 := e
|
||
| value.list [] := e
|
||
| _ := t) env
|
||
| (fuel+1) (syntax.node ⟨`list, [lp, syntax.node ⟨_, f::args⟩, rp]⟩) env :=
|
||
do f ← eval fuel f env,
|
||
args.mfoldl (λ f arg,
|
||
do value.closure cenv code ← pure f |
|
||
throw $ "not a function: " ++ f.to_string,
|
||
arg ← eval fuel arg env,
|
||
eval fuel code (arg::cenv)) f
|
||
| _ stx env := throw $ "cannot evaluate " ++ to_string stx
|
||
|
||
def cfg := {macro1.cfg with macros :=
|
||
((macro1.cfg.macros.insert `list list_macro)
|
||
.insert `let let_macro)
|
||
.insert `or or_macro}
|
||
meta def go (s) : tactic unit :=
|
||
match ((parse 1000).parse_with_eoi s).run with
|
||
| except.error e := tactic.trace (e.to_string s)
|
||
| except.ok stx :=
|
||
tactic.trace (to_fmt "reader: " ++ to_fmt stx) >>
|
||
match (expand' stx).run' cfg () with
|
||
| except.error e := tactic.fail e
|
||
| except.ok stx :=
|
||
tactic.trace (to_fmt "expander: " ++ to_fmt stx) >>
|
||
match (resolve' stx).run' cfg () with
|
||
| except.error e := tactic.fail e
|
||
| except.ok stx :=
|
||
tactic.trace (to_fmt "resolver: " ++ to_fmt stx) >>
|
||
match eval 1000 stx [] with
|
||
| except.error e := tactic.fail e
|
||
| except.ok val :=
|
||
tactic.trace (to_fmt "evaluator: " ++ val.to_string)
|
||
|
||
|
||
#eval go "()"
|
||
#eval go "((lambda [x] x) 1)"
|
||
#eval go "((lambda [x y] x) 1 2)"
|
||
#eval go "(let ([x 1]) x)"
|
||
|
||
#eval go "(let ([tmp 5]) (or 0 tmp))"
|
||
|
||
end lisp
|