From 663999268562da72ee4a08fa049b544e69a9bf5e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Abigail=20Magalh=C3=A3es?=
 <magalhaes.alcantara@pucpr.edu.br>
Date: Mon, 18 May 2020 01:10:33 -0300
Subject: [PATCH] Initial commit

---
 assemble.ml    |  52 +++++++++++
 compile.ml     | 105 ++++++++++++++++++++++
 driver.ml      |  50 +++++++++++
 lang.ml        |  69 +++++++++++++++
 lexer.ml       | 133 ++++++++++++++++++++++++++++
 lib/monads.ml  |  42 +++++++++
 lib/parsers.ml | 232 +++++++++++++++++++++++++++++++++++++++++++++++++
 parser.ml      |  69 +++++++++++++++
 preamble.lua   |  68 +++++++++++++++
 test.hs        |   6 ++
 10 files changed, 826 insertions(+)
 create mode 100644 assemble.ml
 create mode 100644 compile.ml
 create mode 100644 driver.ml
 create mode 100644 lang.ml
 create mode 100644 lexer.ml
 create mode 100644 lib/monads.ml
 create mode 100644 lib/parsers.ml
 create mode 100644 parser.ml
 create mode 100644 preamble.lua
 create mode 100644 test.hs

diff --git a/assemble.ml b/assemble.ml
new file mode 100644
index 0000000..992d134
--- /dev/null
+++ b/assemble.ml
@@ -0,0 +1,52 @@
+include import "./compile.ml"
+open import "prelude.ml"
+open import "lua/io.ml"
+
+let resolve_addr = function
+  | Combinator n -> n ^ "_combinator"
+  | Arg i -> "stack[sp - " ^ show (i + 1) ^ "][3]"
+
+let gm2lua = function
+  | Push addr -> "  stack[sp + 1] = " ^ resolve_addr addr ^ "; sp = sp + 1"
+  | Pop n -> "  sp = sp - " ^ show n
+  | Update n -> "  stack[sp - " ^ show (n + 1) ^ "] = { I, stack[sp] }; sp = sp - 1"
+  | Mkap -> "  stack[sp - 1] = { A, stack[sp - 1], stack[sp] }; sp = sp - 1"
+  | Unwind -> "  return unwind()"
+
+let compute_local_set xs =
+  let rec go i (s : S.t string) = function
+    | Cons ((name, _, _), xs) ->
+      if i >= 100 then
+        s
+      else
+        go (i + 2) (S.insert name (S.insert (name ^ "_combinator") s)) xs
+    | Nil -> s
+  go 1 S.empty xs
+
+let sc2lua (name, arity, body) =
+  let body =
+    body
+      |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function()\n")
+      |> (^ "end")
+  let dec =
+    name ^ "_combinator = { F, " ^ name ^ ", " ^ show arity ^ ", " ^ show name ^ " };"
+  body ^ "\n" ^ dec
+
+let preamble =
+  let f = open_for_reading "preamble.lua"
+  let x = read_all f
+  close_file f
+  match x with
+  | Some s -> s
+  | None -> error "no preamble.lua"
+
+let assm_program decs =
+  match decs with
+  | [] -> error "empty program"
+  | _ ->
+    let Cons (local1, locals) =
+      compute_local_set decs |> S.members
+    let local_decs =
+      foldl (fun x v -> x ^ ", " ^ v) ("local " ^ local1) locals
+    let body = foldl (fun x s -> x ^ sc2lua s ^ "\n") "" decs
+    preamble ^ local_decs ^ "\n" ^ body ^ "stack[sp] = { A, main_combinator, 0 }; unwind()"
diff --git a/compile.ml b/compile.ml
new file mode 100644
index 0000000..359fcbd
--- /dev/null
+++ b/compile.ml
@@ -0,0 +1,105 @@
+module M = import "data/map.ml"
+module S = import "data/set.ml"
+
+open import "prelude.ml"
+open import "./lang.ml"
+open import "./lib/monads.ml"
+
+type addr =
+  | Combinator of string
+  | Arg of int
+
+type gm_code =
+  | Push of addr
+  | Update of int
+  | Pop of int
+  | Unwind
+  | Mkap
+
+instance show gm_code begin
+  let show = function
+    | Mkap -> "Mkap"
+    | Unwind -> "Unwind"
+    | Push (Combinator k) -> "Push " ^ k
+    | Push (Arg i) -> "Arg " ^ show i
+    | Update n -> "Update " ^ show n
+    | Pop n -> "Pop " ^ show n
+end
+
+let rec lambda_lift = function
+  | Ref v -> pure (Ref v)
+  | App (f, x) -> (| app (lambda_lift f) (lambda_lift x) |)
+  | Lam (v, x) ->
+    let! body = lambda_lift x
+    let! (i, defs, known_sc) = get
+
+    let vars =
+      x |> free_vars
+        |> S.delete v
+        |> flip S.difference known_sc
+        |> S.members
+
+    let def = ("Lam" ^ show i, vars ++ [v], body)
+    let app = foldl (fun f -> app f # Ref) (Ref ("Lam" ^ show i)) vars
+
+    put (i + 1, Decl def :: defs, known_sc)
+      |> map (const app)
+  | Case (sc, alts) ->
+      alts
+        |> map (fun (_, x) -> x)
+        |> foldl app sc
+        |> lambda_lift
+
+let rec eta_contract = function
+  | Decl (n, a, e) as dec ->
+    match a, e with
+    | [], _ -> dec
+    | xs, App (f, Ref v) ->
+      if v == last xs && not (S.member v (free_vars f)) then
+        eta_contract (Decl (n, init a, f))
+      else
+        dec
+    | _, _ -> dec
+  | Data c -> Data c
+
+let rec lambda_lift_sc = function
+  | Decl (n, a, e) ->
+    match e with
+    | Lam (v, e) -> lambda_lift_sc (Decl (n, a ++ [v], e))
+    | _ ->
+      let! e = lambda_lift e
+      let! _ = modify (fun (a, b, s) -> (a, b, S.insert n s))
+      pure (Decl (n, a, e))
+  | Data c -> Data c |> pure
+
+type dlist 'a <- list 'a -> list 'a
+
+let rec compile (env : M.t string int) = function
+  | Ref v ->
+    match M.lookup v env with
+    | Some i -> (Push (Arg i) ::)
+    | None -> (Push (Combinator v) ::)
+
+  | App (f, x) ->
+    let f = compile env f
+    let x = compile (map (1 +) env) x
+    f # x # (Mkap ::)
+
+  | Lam _ -> error "Can not compile lambda expression, did you forget to lift?"
+  | Case _ -> error "Can not compile case expression, did you forget to lift?"
+
+let supercomb (_, args, exp) =
+  let env = M.from_list (zip args [0..length args])
+  let k = compile (M.from_list (zip args [0..length args])) exp
+  k [Update (length env), Pop (length env), Unwind]
+
+let known_scs = S.from_list [ "getchar", "putchar" ]
+
+let program decs =
+  let (decs, (_, lams, _)) =
+    run_state (traverse (lambda_lift_sc # eta_contract) decs) (0, [], known_scs)
+  flip map (lams ++ decs) @@ function
+    | Decl ((nm, args, _) as sc) ->
+      let code = supercomb sc
+      (nm, length args, code)
+    | Data _ -> error "data declaration in compiler"
diff --git a/driver.ml b/driver.ml
new file mode 100644
index 0000000..714ab42
--- /dev/null
+++ b/driver.ml
@@ -0,0 +1,50 @@
+module C = import "./compile.ml"
+module A = import "./assemble.ml"
+open import "./parser.ml"
+open import "prelude.ml"
+open import "lua/io.ml"
+
+let go infile outfile =
+  let infile = open_for_reading infile
+  let outfile = open_file outfile Write_m
+  match read_all infile with
+  | Some str ->
+    match lex prog str with
+    | Right (ds, _) ->
+      ds
+        |> ds_prog
+        |> C.program
+        |> A.assm_program
+        |> write_bytes outfile
+    | Left e -> print e
+  | _ -> ()
+  close_file infile
+  close_file outfile
+
+let test str =
+  match lex prog str with
+  | Right (ds, _) ->
+      ds
+        |> ds_prog
+        |> C.program
+        |> A.assm_program
+        |> put_line
+  | Left e -> print e
+
+let test_file infile =
+  let infile = open_for_reading infile
+  match read_all infile with
+  | Some str -> test str
+  | None -> ()
+  close_file infile
+
+
+external val args : string * string =
+  "{ _1 = select(1, ...), _2 = select(2, ...) }"
+external val has_args : bool = "select('#', ...) ~= 0"
+
+let () =
+  if has_args then
+    let (from, into) = args
+    go from into
+  else ()
diff --git a/lang.ml b/lang.ml
new file mode 100644
index 0000000..c9cb2b8
--- /dev/null
+++ b/lang.ml
@@ -0,0 +1,69 @@
+open import "prelude.ml"
+module S = import "data/set.ml"
+module M = import "data/map.ml"
+
+type expr =
+  | Ref of string
+  | App of expr * expr
+  | Lam of string * expr
+  | Case of expr * list (string * expr)
+
+let app = curry App
+let lam = curry Lam
+
+let rec free_vars = function
+  | Ref v -> S.singleton v
+  | App (f, x) -> S.union (free_vars f) (free_vars x)
+  | Lam (v, x) -> v `S.delete` free_vars x
+  | Case (e, bs) ->
+      bs
+        |> map (fun (_, e) -> free_vars e)
+        |> foldl S.union S.empty
+        |> S.union (free_vars e)
+
+let rec subst m = function
+  | Ref v ->
+    match M.lookup v m with
+    | Some s -> s
+    | None -> Ref v
+  | App (f, x) -> App (subst m f, subst m x)
+  | Lam (v, x) -> Lam (v, subst (M.delete v m) x)
+  | Case (e, xs) -> Case (subst m e, map (second (subst m)) xs)
+
+type hstype =
+  | Tycon of string
+  | Tyvar of string
+  | Tyapp of hstype * hstype
+
+type constr = Constr of string * list hstype
+
+type decl =
+  | Decl of string * list string * expr
+  | Data of string * list string * list constr
+
+type prog <- list decl
+
+let rec xs !! i =
+  match xs, i with
+  | Cons (x, _), 0 -> x
+  | Cons (_, xs), i when i > 0 -> xs !! (i - 1)
+  | _, _ -> error "empty list and/or negative index"
+
+let ds_data (_, _, cs) =
+  let ncons = length cs
+  let alts = map (("c" ^) # show) [1..ncons]
+  let ds_con i (Constr (n, args)) =
+    let arity = length args
+    let alt = alts !! i
+    let args = map (("x" ^) # show) [1..arity]
+    Decl (n, args, foldr lam (foldl app (Ref alt) (map Ref args)) alts)
+  let rec go i = function
+    | [] -> []
+    | Cons (x, xs) -> ds_con i x :: go (i + 1) xs
+  go 0 cs
+
+let ds_prog prog =
+  let! c = prog
+  match c with
+  | Data c -> ds_data c
+  | Decl (n, args, e) -> [Decl (n, args, e)]
diff --git a/lexer.ml b/lexer.ml
new file mode 100644
index 0000000..a1a1c7c
--- /dev/null
+++ b/lexer.ml
@@ -0,0 +1,133 @@
+include import "./lib/parsers.ml"
+open import "prelude.ml"
+
+let lex = run_parser
+
+let line_comment () =
+  let! _ = symbol "--"
+  let rec go =
+    let! x = map (const "\n") eof <|> char
+    if x == "\n" then
+      pure ()
+    else
+      go
+  go
+
+let whitepiece : forall 'm. monad 'm => parser_t 'm () =
+  (try (void @@ one_of " \n\v\t\r") <|> try (line_comment ()))
+    <?> "white space"
+
+let whitespace : forall 'm. monad 'm => parser_t 'm () =
+  void (many whitepiece)
+
+let lexeme p =
+  let! _ = whitespace
+  p
+
+let oparen  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "(")
+let cparen  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ")")
+let comma   : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ",")
+let semi    : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol ";")
+let osquare : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "[")
+let csquare : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "]")
+let obrace  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "{")
+let cbrace  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "}")
+let back    : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "\\")
+let arrow   : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "->")
+let darrow  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "=>")
+let equals  : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "=")
+let pipe    : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (symbol "|")
+
+let small : forall 'm. monad 'm => parser_t 'm string =
+  try (satisfy (fun c -> "a" <= c && c <= "z") <|> symbol "_") <?> "small letter"
+
+let big : forall 'm. monad 'm => parser_t 'm string =
+  try (satisfy (fun c -> "A" <= c && c <= "Z")) <?> "big letter"
+
+let iskw = function
+  | "case"
+  | "class"
+  | "data"
+  | "default"
+  | "deriving"
+  | "do"
+  | "else"
+  | "if"
+  | "import"
+  | "in"
+  | "infix"
+  | "infixl"
+  | "infixr"
+  | "instance"
+  | "let"
+  | "module"
+  | "newtype"
+  | "of"
+  | "then"
+  | "type"
+  | "where"
+  | "_" -> true
+  | _ -> false
+
+let isreserved = function
+  | "=" | "=>" | "->" | "|" -> true
+  | _ -> false
+
+let varid : forall 'm. monad 'm => parser_t 'm string =
+  flip (<?>) "variable name" # lexeme @@
+    let! c = small
+    let! cs =
+      many_fold (^) "" (small <|> big <|> try (symbol "'"))
+        <|> pure ""
+    let id = c ^ cs
+    if iskw id then
+      unexpected id
+    else
+      pure id
+
+let conid : forall 'm. monad 'm => parser_t 'm string =
+  flip (<?>) "constructor name" # lexeme @@
+    let! c = big
+    let! cs =
+      many_fold (^) "" (small <|> big <|> try (symbol "'"))
+        <|> pure ""
+    pure (c ^ cs)
+
+let tyvar = varid
+let tycon = conid
+let tycls = conid
+
+let keyword c = lexeme (symbol c) <?> "``" ^ c ^ "''"
+
+let operator : forall 'm. monad 'm => parser_t 'm string =
+  flip (<?>) "operator" # lexeme @@
+    let! c = one_of "!#$%&*+./<=>?@\\^|-~"
+    let! cs = many_fold (^) "" (one_of ":!#$%&*+./<=>?@\\^|-~")
+    let op = c ^ cs
+    if isreserved op then
+      unexpected op
+    else
+      pure op
+
+let digit : forall 'm. monad 'm => parser_t 'm string =
+  satisfy (fun c -> "0" <= c && c <= "9") <?> "digit"
+
+let hexit : forall 'm. monad 'm => parser_t 'm string =
+  digit
+    <|> satisfy (fun c -> "a" <= c && c <= "f")
+    <|> satisfy (fun c -> "A" <= c && c <= "F")
+
+let integer : forall 'm. monad 'm => parser_t 'm int =
+  let decimal =
+    let! c = digit
+    let! cs = many_fold (^) "" digit
+    pure (c ^ cs)
+  let hexadecimal =
+    let! _ = symbol "0x"
+    let! c = hexit
+    let! cs = many_fold (^) "" hexit
+    pure ("0x" ^ c ^ cs)
+  let! c = (try hexadecimal <|> decimal) <?> "hex or decimal integer"
+  match parse_int c with
+  | None -> error "no parse"
+  | Some x -> pure x
diff --git a/lib/monads.ml b/lib/monads.ml
new file mode 100644
index 0000000..75d6eae
--- /dev/null
+++ b/lib/monads.ml
@@ -0,0 +1,42 @@
+open import "prelude.ml"
+
+type identity 'a = Id of 'a
+
+instance functor identity begin
+  let f <$> Id x = Id (f x)
+end
+
+instance applicative identity begin
+  let pure = Id
+  let Id f <*> Id x = Id (f x)
+end
+
+instance monad identity begin
+  let Id x >>= f = f x
+end
+
+type state 's 'a = State of 's -> 'a * 's
+
+let run_state (State k) = k
+
+instance functor (state 's) begin
+  let f <$> State x = State (first f # x)
+end
+
+instance applicative (state 's) begin
+  let pure x = State (x,)
+  let State f <*> State x = State @@ fun s ->
+    let (f, s) = f s
+    let (x, s) = x s
+    (f x, s)
+end
+
+instance monad (state 's) begin
+  let State x >>= f = State @@ fun s ->
+    let (x, s) = x s
+    run_state (f x) s
+end
+
+let get = State (fun s -> (s, s))
+let put x = State (fun _ -> ((), x))
+let modify f = State (fun s -> ((), f s))
diff --git a/lib/parsers.ml b/lib/parsers.ml
new file mode 100644
index 0000000..0fd067d
--- /dev/null
+++ b/lib/parsers.ml
@@ -0,0 +1,232 @@
+open import "prelude.ml"
+open import "./monads.ml"
+
+private type consumed = C | E
+
+private type error = Unexpected of string * list string
+
+instance show error begin
+  let show = function
+    | Unexpected (s, []) -> s
+    | Unexpected (s, ms) ->
+      "Unexpected " ^ s ^ "\n"
+        ^ "Expecting one of " ^ foldl (^) "" ms
+end
+
+private type result 'a =
+  | Ok  of consumed * 'a    * string
+  | Err of consumed * error * string
+
+let join_consumed x y =
+  match x with
+  | C -> C
+  | E -> y
+
+type parser_t 'm 'a = private P of string -> 'm (result 'a)
+type parser <- parser_t identity
+
+instance functor 'm => functor (parser_t 'm) begin
+  let f <$> P x = P @@ fun i ->
+    flip map (x i) @@ fun p ->
+    match p with
+    | Ok (c, x, i) -> Ok (c, f x, i)
+    | Err e -> Err e
+end
+
+instance monad 'm => applicative (parser_t 'm) begin
+  let pure x = P (fun s -> pure (Ok (E, x, s)))
+  let P f <*> P x = P @@ fun s ->
+    let! f = f s
+    match f with
+    | Ok (c, f, s) ->
+      let! x = x s
+      match x with
+      | Ok (c', x, s) -> pure @@ Ok (join_consumed c c', f x, s)
+      | Err (c', p) -> pure @@ Err (join_consumed c c', p)
+    | Err e -> pure @@ Err e
+end
+
+let x *> y = (fun _ x -> x) <$> x <*> y
+let x <* y = (| const x y |)
+
+instance monad 'm => monad (parser_t 'm) begin
+  let P x >>= f = P @@ fun s ->
+    let! x = x s
+    match x with
+    | Ok (c, x, s) ->
+      let P kont = f x
+      let! x = kont s
+      match x with
+      | Ok (c', x, s) -> pure @@ Ok (join_consumed c c', x, s)
+      | Err (c', p) -> pure @@ Err (join_consumed c c', p)
+    | Err e -> pure @@ Err e
+end
+
+let private fail e = P (fun s -> pure (Err (E, e, s)))
+
+let empty : forall 'm 'a. monad 'm => parser_t 'm 'a =
+  fail (Unexpected ("empty parse", []))
+
+let unexpected e =
+  fail (Unexpected (e, []))
+
+let alt_err (Unexpected (u, xs)) (Unexpected (_, ys)) =
+  Unexpected (u, xs ++ ys)
+
+let P x <|> P y = P @@ fun s ->
+  let! x = x s
+  match x with
+  | Ok x -> pure (Ok x)
+  | Err (c, m, s) ->
+    let! y = y s
+    match y with
+    | Ok (c', x, s) -> pure (Ok (join_consumed c c', x, s))
+    | Err (c', m', s) -> pure (Err (join_consumed c c', alt_err m m', s))
+
+let P x <+> y = P @@ fun s ->
+  let! x = x s
+  match x with
+  | Ok x -> pure (Ok x)
+  | Err (c, m, s) ->
+    let P y = force y
+    let! y = y s
+    match y with
+    | Ok (c', x, s) -> pure (Ok (join_consumed c c', x, s))
+    | Err (c', m', s) -> pure (Err (join_consumed c c', alt_err m m', s))
+
+private module S = import "lua/string.ml"
+
+let char : forall 'm. applicative 'm => parser_t 'm string =
+  P @@ fun s ->
+    let x = S.substring s 1 1
+    if x <> "" then
+      let r = S.substring s 2 (S.length s)
+      pure @@ Ok (C, x, r)
+    else
+      pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s)
+
+let eof : forall 'm. applicative 'm => parser_t 'm () =
+  P @@ fun s ->
+    if s == "" then
+      pure @@ Ok (E, (), s)
+    else
+      pure @@ Err (E, Unexpected (S.substring s 1 1, ["end-of-file"]), s)
+
+let satisfy p = P @@ fun s ->
+  let x = S.substring s 1 1
+  if x <> "" && p x then
+    pure @@ Ok (C, x, S.substring s 2 (S.length s))
+  else
+    let m =
+      if x == "" then
+        "end of file"
+      else x
+    pure @@ Err (E, Unexpected (m, ["character"]), s)
+
+let P k <?> m = P @@ fun s ->
+  let! x = k s
+  match x with
+  | Ok e -> pure (Ok e)
+  | Err (c, Unexpected (u, _), s) -> pure (Err (c, Unexpected (u, [m]), s))
+
+let many_fold k z (P x) =
+  let rec go consumed kont s =
+    let! x = x s
+    match x with
+    | Err ((c, _, s) as p) ->
+      match c with
+      | C -> pure (Err p)
+      | E -> kont consumed z s
+    | Ok (c, x, s) ->
+      match c with
+      | E -> error @@ "many: got parser that accepts the empty string"
+      | C -> go C (fun c -> kont c # k x) s
+  P (go E (fun c z s -> pure (Ok (c, z, s))))
+
+let many p = many_fold (::) [] p
+let some p =
+  let! x = p
+  (x ::) <$> many p
+
+let sep_by_1 sep p =
+  let! x = p
+  let! xs = many (sep *> p)
+  pure (x :: xs)
+
+let sep_by sep p = sep_by_1 sep p <|> pure []
+external private val is_infix_of : string -> string -> bool =
+  "function(s, s2) return s2:find(s) ~= nil end"
+
+external private val is_prefix_of : string -> string -> bool =
+  "function(s, s2) return (s2:find(s)) == 1 end"
+
+let one_of chs =
+  let len = S.length chs
+  let rec loop ch i =
+    if i > len then
+      fail @@ Unexpected (ch, ["one of \"" ^ chs ^ "\""])
+    else if ch == S.substring chs i i then
+      pure ch
+    else
+      loop ch (i + 1)
+  let! ch = char
+  loop ch 1
+
+let symbol str =
+  let len = S.length str
+  let rec loop acc i =
+    if i > len then
+      pure acc
+    else
+      let! c = char <?> S.substring str i i
+      if c == S.substring str i i then
+        loop (acc ^ c) (i + 1)
+      else
+        fail @@ Unexpected (acc ^ c, [S.substring str 1 i])
+  loop "" 1
+
+let between o c p =
+  let! _ = o
+  let! x = p
+  let! _ = c
+  pure x
+
+let try (P x) = P @@ fun s ->
+  let! x = x s
+  match x with
+  | Ok c -> pure (Ok c)
+  | Err (_, p, _) -> pure (Err (E, p, s))
+
+let optionally p = map Some (try p) <|> pure None
+
+
+let rec sep_end_by_1 sep p =
+  let! x = p
+  ( let! _ = sep
+    let! xs = sep_end_by sep p
+    pure (x :: xs)
+  ) <|> pure [x]
+and sep_end_by sep p =
+  sep_end_by_1 sep p <|> pure []
+
+
+let parse (P x) s =
+  let! x = x s
+  match x with
+  | Ok (_, x, r) -> pure @@ Right (x, r)
+  | Err (_, m, _) -> pure @@ Left m
+
+let run_parser p s =
+  let Id x = parse p s
+  x
+
+let run_parser' (P x) s =
+  let Id x = x s
+  x
+
+let lift m = P @@ fun s ->
+  let! x = m
+  pure @@ Ok (E, x, s)
+
+let morph (k : forall 'a. 'm 'a -> 'n 'a) (P x) = P @@ fun s -> k (x s)
+let void x = map (const ()) x
diff --git a/parser.ml b/parser.ml
new file mode 100644
index 0000000..3db7426
--- /dev/null
+++ b/parser.ml
@@ -0,0 +1,69 @@
+include import "./lang.ml"
+include import "./lexer.ml"
+open import "prelude.ml"
+
+let parse = lex
+
+let laid_out_block p = between obrace cbrace (sep_end_by_1 semi p)
+
+let rec atom : forall 'm. monad 'm => parser_t 'm expr =
+  map Ref (try varid)
+    <+> map Ref (try conid)
+    <+> between (try oparen) cparen expr
+and fexp : forall 'm. monad 'm => parser_t 'm expr =
+  let! a = atom
+  let! ats = many atom
+  pure (foldl (curry App) a ats)
+and expr : forall 'm. monad 'm => parser_t 'm expr =
+  let lam =
+    let! _  = back
+    let! vs = many (try varid)
+    let! _  = arrow
+    let! b  = expr
+    pure (foldr ((Lam #) # curry id) b vs)
+  let case =
+    let! _ = keyword "case"
+    let! e = fexp
+    let! _ = keyword "of"
+    let! arms =
+      laid_out_block (
+        let! c = conid
+        let! vs = many (try varid)
+        let! _ = arrow
+        let! e = expr
+        pure (c, foldr ((Lam #) # curry id) e vs)
+      )
+    pure (Case (e, arms))
+  try lam <|> try case <+> fexp
+
+let rec ty_atom : forall 'm. monad 'm => parser_t 'm hstype =
+  map Tyvar (try varid)
+    <|> map Tycon (try conid)
+    <+> between (try oparen) cparen ty_exp
+and ty_exp : forall 'm. monad 'm => parser_t 'm hstype =
+  let! a = ty_atom
+  let! ats = many ty_atom
+  pure (foldl (curry Tyapp) a ats)
+
+let datadec : forall 'm. monad 'm => parser_t 'm decl =
+  let! _ = keyword "data"
+  let datacon =
+    let! nm = conid
+    let! args = many ty_atom
+    pure (Constr (nm, args))
+  let! nm = conid
+  let! args = many (try varid)
+  let! _ = equals
+  let! c = sep_by_1 pipe (try datacon)
+  pure (Data (nm, args, c))
+
+let dec : forall 'm. monad 'm => parser_t 'm decl =
+  let func =
+    let! nm = varid
+    let! args = many (try varid)
+    let! _ = equals
+    map (fun e -> Decl (nm, args, e)) expr
+  try datadec <|> func
+
+let prog : forall 'm. monad 'm => parser_t 'm prog =
+  sep_end_by_1 semi dec <* eof
diff --git a/preamble.lua b/preamble.lua
new file mode 100644
index 0000000..68979c4
--- /dev/null
+++ b/preamble.lua
@@ -0,0 +1,68 @@
+local A, F, I = {}, {}, {}
+
+local stack = {}
+local sp = 1
+
+local function repr(x)
+  if type(x) == 'table' then
+    if x[1] == F then
+      return x[4]
+    elseif x[1] == A then
+      return repr(x[2]) .. '(' .. repr(x[3]) .. ')'
+    elseif x[1] == I then
+      return '&' .. repr(x[2])
+    end
+  else
+    return tostring(x)
+  end
+end
+
+local function unwind()
+  local x = stack[sp]
+  if type(x) == 'table' then
+    if x[1] == A then
+      stack[sp + 1] = x[2]; sp = sp + 1
+      return unwind()
+    elseif x[1] == I then
+      stack[sp] = x[2]
+      return unwind()
+    elseif x[1] == F then
+      if sp - 1 >= x[3] then
+        return x[2]()
+      else
+        print("insufficient arguments for supercombinator " .. x[4])
+        print 'stack dump:'
+        for k, v in pairs(stack) do
+          print(sp - k, repr(v))
+        end
+        error()
+      end
+    end
+  else
+    os.exit(x)
+  end
+end
+
+local function getchar()
+  local k = stack[sp - 1][3]; sp = sp - 1
+  local knil = stack[sp - 1][3]; sp = sp - 1
+  local ch = io.read(1)
+  if ch then
+    stack[sp] = { A, k, ch:byte() }
+  else
+    stack[sp] = { A, knil, 0 }
+  end
+  return unwind()
+end
+
+local getchar_combinator = { F, getchar, 2 }
+
+local function putchar()
+  local ch = stack[sp - 1][3];
+  local k = stack[sp - 2][3]; sp = sp - 1
+  io.write(string.char(ch))
+  stack[sp] = { A, k, ch }
+  return unwind()
+end
+
+local putchar_combinator = { F, putchar, 2 }
diff --git a/test.hs b/test.hs
new file mode 100644
index 0000000..772a3b3
--- /dev/null
+++ b/test.hs
@@ -0,0 +1,6 @@
+data List a = Nil | Cons a (List a);
+map f xs = case xs of { Nil -> Nil; Cons x xs -> Cons (f x) (map f xs) };
+readall k = getchar (\ch -> readall (\xs -> k (Cons ch xs))) (\ch -> k Nil);
+putall x xs = case xs of { Nil -> x; Cons x xs -> putchar x (\ch -> putall x xs) };
+id x = x;
+main x = readall (putall x);