add a FFI and primitive supercombinators

assemble.ml

@@ -1,21 +1,45 @@
 include import "./compile.ml"
+module Strings = import "./lib/strings.ml"
 open import "prelude.ml"
 open import "lua/io.ml"
+open import "./lang.ml"
 
 let resolve_addr = function
   | Combinator n -> n ^ "_combinator"
   | Arg i -> "stack[sp - " ^ show (i + 1) ^ "][3]"
+  | Int i -> show i
 
-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 rec 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(stack, sp)"
+  | Eval -> "  stack[sp] = eval(stack[sp])"
+  | Add -> "  stack[sp - 1] = stack[sp - 1] + stack[sp]; sp = sp - 1"
+  | Sub -> "  stack[sp - 1] = stack[sp - 1] - stack[sp]; sp = sp - 1"
+  | Div -> "  stack[sp - 1] = stack[sp - 1] / stack[sp]; sp = sp - 1"
+  | Mul -> "  stack[sp - 1] = stack[sp - 1] * stack[sp]; sp = sp - 1"
+  | Iszero (yes, no) ->
+      "  if stack[sp] == 0 then\n"
+        ^ foldl (fun x i -> x ^ "  " ^ gm2lua i) "" yes ^ "\n"
+        ^ "  else\n"
+        ^ foldl (fun x i -> x ^ "  " ^ gm2lua i) "" no ^ "\n"
+        ^ "  end"
 
 let compute_local_set xs =
   let rec go i (s : S.t string) = function
-    | Cons ((name, _, _), xs) ->
+    | Cons (Fd (Fimport {var}), xs) ->
+      if i >= 100 then
+        s
+      else
+        go (i + 2) (S.insert (var ^ "_wrapper") (S.insert (var ^ "_combinator") s)) xs
+    | Cons (Sc (name, _), xs) ->
       if i >= 100 then
         s
       else
@@ -26,12 +50,52 @@ let compute_local_set xs =
 let sc2lua (name, arity, body) =
   let body =
     body
-      |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function()\n")
+      |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function(stack, sp)\n")
       |> (^ "end")
   let dec =
     name ^ "_combinator = { F, " ^ name ^ ", " ^ show arity ^ ", " ^ show name ^ " };"
   body ^ "\n" ^ dec
 
+let foreign2lua (Fimport { cc, fent = fspec, var, ftype }) =
+  let (file, fspec) =
+    match Strings.split_on " " fspec with
+    | [file, func] -> (Some file, func)
+    | [func] -> (None, func)
+    | _ -> error @@ "Foreign spec too big: " ^ fspec
+  match cc with
+  | Prim -> error "primitive definitions are in Gmcode"
+  | Lua ->
+    let arity = arity ftype
+    let args = map (fun i -> ("a" ^ show i, i)) [1..arity]
+    let fcall =
+      if arity == 0 then
+        fspec
+      else
+        let Cons ((a, _), args) = args
+        fspec ^ "(" ^ foldl (fun a (i, _) -> a ^ ", " ^ i) a args ^ ")"
+    let wrapper =
+      "local function " ^ var ^ "_wrapper(stack, sp)\n"
+      ^ foldl (fun x (a, i) -> x ^ "  local " ^ a ^ " = stack[sp - " ^ show i ^ "][3];\n") "" args
+      ^ "  stack[sp - " ^ show arity ^ "] = " ^ fcall ^ "\n"
+      ^ "  return unwind(stack, sp - " ^ show arity ^ ")\nend"
+    let dec =
+      var ^ "_combinator = { F, " ^ var ^ "_wrapper, " ^ show arity ^ ", '" ^ fspec ^ "' };"
+    let contents =
+      match file with
+      | Some path -> 
+        let f = open_for_reading path
+        let x = read_all f
+        close_file f
+        match x with
+        | Some s -> "--- " ^ path ^ "\n" ^ s ^ "\n"
+        | None -> ""
+      | None -> ""
+    contents ^ wrapper ^ "\n" ^ dec
+
+let codegen = function
+  | Sc t -> sc2lua t
+  | Fd i -> foreign2lua i
+
 let preamble =
   let f = open_for_reading "preamble.lua"
   let x = read_all f
@@ -48,5 +112,5 @@ let assm_program decs =
       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()"
+    let body = foldl (fun x s -> x ^ codegen s ^ "\n") "" decs
+    preamble ^ local_decs ^ "\n" ^ body ^ "unwind({{ A, main_combinator, 123 }}, 1)"

compile.ml

@@ -8,6 +8,7 @@ open import "./lib/monads.ml"
 type addr =
   | Combinator of string
   | Arg of int
+  | Int of int
 
 type gm_code =
   | Push of addr
@@ -15,6 +16,8 @@ type gm_code =
   | Pop of int
   | Unwind
   | Mkap
+  | Add | Sub | Mul | Div | Eval
+  | Iszero of list gm_code * list gm_code
 
 instance show gm_code begin
   let show = function
@@ -22,12 +25,24 @@ instance show gm_code begin
     | Unwind -> "Unwind"
     | Push (Combinator k) -> "Push " ^ k
     | Push (Arg i) -> "Arg " ^ show i
+    | Push (Int i) -> "Int " ^ show i
     | Update n -> "Update " ^ show n
     | Pop n -> "Pop " ^ show n
+    | Add  -> "Add"
+    | Mul  -> "Mul"
+    | Sub  -> "Sub"
+    | Div  -> "Div"
+    | Eval -> "Eval"
+    | Iszero p -> "Iszero " ^ show p
 end
 
+type program_item =
+  | Sc of string * int * list gm_code
+  | Fd of fdecl
+
 let rec lambda_lift = function
   | Ref v -> pure (Ref v)
+  | Lit v -> pure (Lit v)
   | App (f, x) -> (| app (lambda_lift f) (lambda_lift x) |)
   | Lam (v, x) ->
     let! body = lambda_lift x
@@ -61,6 +76,7 @@ let rec eta_contract = function
         dec
     | _, _ -> dec
   | Data c -> Data c
+  | Foreign i -> Foreign i
 
 let rec lambda_lift_sc = function
   | Decl (n, a, e) ->
@@ -71,9 +87,27 @@ let rec lambda_lift_sc = function
       let! _ = modify (fun (a, b, s) -> (a, b, S.insert n s))
       pure (Decl (n, a, e))
   | Data c -> Data c |> pure
+  | Foreign i -> Foreign i |> pure
 
 type dlist 'a <- list 'a -> list 'a
 
+let cg_prim (Fimport { var, fent }) =
+  let prim_math_op x =
+    [ Push (Arg 0), Eval, Push (Arg 2), Eval, x, Update 2, Pop 2, Unwind ]
+  let prim_equality =
+    [ Push (Arg 0), Eval (* x, arg0, arg1, arg2, arg3 *)
+    , Push (Arg 2), Eval (* y, x, arg0, arg1, arg2, arg3 *)
+    , Sub                (* y - x, arg0, arg1, arg2, arg3 *)
+    , Iszero ([ Push (Arg 3) ], [ Push (Arg 4) ])
+    , Push (Int 0), Mkap, Update 4, Pop 4, Unwind ]
+  match fent with
+  | "add" -> Sc (var, 2, prim_math_op Add)
+  | "sub" -> Sc (var, 2, prim_math_op Sub)
+  | "mul" -> Sc (var, 2, prim_math_op Mul)
+  | "div" -> Sc (var, 2, prim_math_op Div)
+  | "equ" -> Sc (var, 4, prim_equality)
+  | e -> error @@ "No such primitive " ^ e
+
 let rec compile (env : M.t string int) = function
   | Ref v ->
     match M.lookup v env with
@@ -85,8 +119,11 @@ let rec compile (env : M.t string int) = function
     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?"
+  | Lam _ ->
+      error "Can not compile lambda expression, did you forget to lift?"
+  | Case _ ->
+      error "Can not compile case expression, did you forget to lift?"
+  | Lit i -> (Push (Int i) ::)
 
 let supercomb (_, args, exp) =
   let env = M.from_list (zip args [0..length args])
@@ -98,8 +135,23 @@ 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"
+  let define nm =
+    let! x = get
+    if nm `S.member` x then
+      error @@ "Redefinition of value " ^ nm
+    else
+      modify (S.insert nm)
+
+  let go =
+    flip traverse (lams ++ decs) @@ function
+      | Decl ((nm, args, _) as sc) ->
+        let! _ = define nm
+        let code = supercomb sc
+        Sc (nm, length args, code) |> pure
+      | Data _ -> error "data declaration in compiler"
+      | Foreign (Fimport { cc = Prim, var } as fi) ->
+        let! _ = define var
+        pure (cg_prim fi)
+      | Foreign f -> pure (Fd f)
+  let (out, _) = run_state go S.empty
+  out

driver.ml

@@ -4,6 +4,10 @@ open import "./parser.ml"
 open import "prelude.ml"
 open import "lua/io.ml"
 
+let printerror (e, { line, col }) =
+  put_line @@ "line " ^ show line ^ ", col " ^ show col ^ ":"
+  print e
+
 let go infile outfile =
   let infile = open_for_reading infile
   let outfile = open_file outfile Write_m
@@ -16,7 +20,7 @@ let go infile outfile =
         |> C.program
         |> A.assm_program
         |> write_bytes outfile
-    | Left e -> print e
+    | Left e -> printerror e
   | _ -> ()
   close_file infile
   close_file outfile
@@ -29,7 +33,7 @@ let test str =
         |> C.program
         |> A.assm_program
         |> put_line
-  | Left e -> print e
+  | Left e -> printerror e
 
 let test_file infile =
   let infile = open_for_reading infile

lang.ml

@@ -3,10 +3,11 @@ 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
+  | Ref  of string
+  | App  of expr * expr
+  | Lam  of string * expr
   | Case of expr * list (string * expr)
+  | Lit  of int
 
 let app = curry App
 let lam = curry Lam
@@ -20,6 +21,7 @@ let rec free_vars = function
         |> map (fun (_, e) -> free_vars e)
         |> foldl S.union S.empty
         |> S.union (free_vars e)
+  | Lit _ -> S.empty
 
 let rec subst m = function
   | Ref v ->
@@ -29,17 +31,35 @@ let rec subst m = function
   | 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)
+  | Lit x -> Lit x
 
 type hstype =
   | Tycon of string
   | Tyvar of string
   | Tyapp of hstype * hstype
+  | Tyarr of hstype * hstype
+  | Tytup of list hstype
+
+let rec arity = function
+  | Tyarr (_, i) -> 1 + arity i
+  | _ -> 0
 
 type constr = Constr of string * list hstype
 
+type call_conv = Lua | Prim
+
+type fdecl =
+  Fimport of {
+    cc : call_conv,
+    fent : string,
+    ftype : hstype,
+    var : string
+  }
+
 type decl =
   | Decl of string * list string * expr
   | Data of string * list string * list constr
+  | Foreign of fdecl
 
 type prog <- list decl
 
@@ -67,3 +87,4 @@ let ds_prog prog =
   match c with
   | Data c -> ds_data c
   | Decl (n, args, e) -> [Decl (n, args, e)]
+  | Foreign d -> [Foreign d]

lexer.ml

@@ -37,6 +37,7 @@ let arrow   : forall 'm. monad 'm => parser_t 'm () = try @@ void @@ lexeme (sym
 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 dcolon  : 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"
@@ -63,6 +64,7 @@ let iskw = function
   | "module"
   | "newtype"
   | "of"
+  | "foreign"
   | "then"
   | "type"
   | "where"
@@ -127,7 +129,21 @@ let integer : forall 'm. monad 'm => parser_t 'm int =
     let! c = hexit
     let! cs = many_fold (^) "" hexit
     pure ("0x" ^ c ^ cs)
-  let! c = (try hexadecimal <|> decimal) <?> "hex or decimal integer"
+  let! c = (lexeme (try hexadecimal <|> decimal)) <?> "hex or decimal integer"
   match parse_int c with
   | None -> error "no parse"
   | Some x -> pure x
+
+let string : forall 'm. monad 'm => parser_t 'm string =
+  flip (<?>) "string literal" # lexeme @@
+    let parse_escape = function
+      | "n" -> pure "\n"
+      | "t" -> pure "\t"
+      | "\"" -> pure "\""
+      | a -> unexpected ("escape sequence " ^ a)
+    let str_ent =
+      satisfy (fun p -> p <> "\"" && p <> "\\")
+        <|> ( let! _ = try (symbol "\\")
+              let! e = char
+              parse_escape e)
+    symbol "\"" *> many_fold (^) "" str_ent <* symbol "\""

lib/parsers.ml

@@ -13,56 +13,59 @@ instance show error begin
         ^ "Expecting one of " ^ foldl (^) "" ms
 end
 
+private type pos <- { line : int, col : int }
+
 private type result 'a =
-  | Ok  of consumed * 'a    * string
-  | Err of consumed * error * string
+  | Ok  of consumed * 'a    * string * pos
+  | Err of consumed * error * string * pos
 
 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_t 'm 'a = private P of pos -> 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 ->
+  let f <$> P x = P @@ fun pos i ->
+    flip map (x pos 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
+  let pure x = P (fun p s -> pure (Ok (E, x, s, p)))
+  let P f <*> P x = P @@ fun p s ->
+    let! f = f p s
     match f with
-    | Ok (c, f, s) ->
-      let! x = x s
+    | Ok (c, f, s, p) ->
+      let! x = x p s
       match x with
-      | Ok (c', x, s) -> pure @@ Ok (join_consumed c c', f x, s)
+      | Ok (c', x, s, p) -> pure @@ Ok (join_consumed c c', f x, s, p)
       | 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 |)
+let x <$ a = map (const x) a
 
 instance monad 'm => monad (parser_t 'm) begin
-  let P x >>= f = P @@ fun s ->
-    let! x = x s
+  let P x >>= f = P @@ fun p s ->
+    let! x = x p s
     match x with
-    | Ok (c, x, s) ->
+    | Ok (c, x, s, p) ->
       let P kont = f x
-      let! x = kont s
+      let! x = kont p 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 private fail e = P (fun p s -> pure (Err (E, e, s, p)))
 
 let empty : forall 'm 'a. monad 'm => parser_t 'm 'a =
   fail (Unexpected ("empty parse", []))
@@ -73,23 +76,23 @@ let 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
+let P x <|> P y = P @@ fun p s ->
+  let! x = x p s
   match x with
   | Ok x -> pure (Ok x)
-  | Err (c, m, s) ->
-    let! y = y s
+  | Err (c, m, s, p) ->
+    let! y = y p 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
+let P x <+> y = P @@ fun p s ->
+  let! x = x p s
   match x with
   | Ok x -> pure (Ok x)
-  | Err (c, m, s) ->
+  | Err (c, m, s, p) ->
     let P y = force y
-    let! y = y s
+    let! y = y p 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))
@@ -97,51 +100,61 @@ let P x <+> y = P @@ fun s ->
 private module S = import "lua/string.ml"
 
 let char : forall 'm. applicative 'm => parser_t 'm string =
-  P @@ fun s ->
+  P @@ fun p 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)
+      if x == "\n" then
+        pure @@ Ok (C, x, r, { line = p.line + 1, col = 0 })
+      else
+        pure @@ Ok (C, x, r, { line = p.line, col = p.col + 1 })
     else
-      pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s)
+      pure @@ Err (E, Unexpected ("end-of-file", ["character"]), s, p)
 
 let eof : forall 'm. applicative 'm => parser_t 'm () =
-  P @@ fun s ->
+  P @@ fun p s ->
     if s == "" then
-      pure @@ Ok (E, (), s)
+      pure @@ Ok (E, (), s, p)
+    else
+      pure @@
+        Err (E, Unexpected (S.substring s 1 1, ["end-of-file"]), s, p)
+
+let satisfy pred =
+  P @@ fun p s ->
+    let x = S.substring s 1 1
+    if x <> "" && pred x then
+      let r = S.substring s 2 (S.length s)
+      if x == "\n" then
+        pure @@ Ok (C, x, r, { line = p.line + 1, col = 0 })
+      else
+        pure @@ Ok (C, x, r, { line = p.line, col = p.col + 1 })
     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
+      let m =
+        if x == "" then
+          "end of file"
+        else
+          x
+      pure @@ Err (E, Unexpected (m, ["character"]), s, p)
+
+let P k <?> m = P @@ fun p s ->
+  let! x = k p 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
+  let rec go consumed kont pos s =
+    let! x = x pos s
     match x with
-    | Err ((c, _, s) as p) ->
+    | Err ((c, _, s, pos) as p) ->
       match c with
       | C -> pure (Err p)
-      | E -> kont consumed z s
-    | Ok (c, x, s) ->
+      | E -> kont consumed z pos s
+    | Ok (c, x, s, pos) ->
       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))))
+      | C -> go C (fun c -> kont c # k x) pos s
+  P (go E (fun c z pos s -> pure (Ok (c, z, s, pos))))
 
 let many p = many_fold (::) [] p
 let some p =
@@ -191,11 +204,11 @@ let between o c p =
   let! _ = c
   pure x
 
-let try (P x) = P @@ fun s ->
-  let! x = x s
+let try (P x) = P @@ fun pos s ->
+  let! x = x pos s
   match x with
   | Ok c -> pure (Ok c)
-  | Err (_, p, _) -> pure (Err (E, p, s))
+  | Err (_, p, _) -> pure (Err (E, p, s, pos))
 
 let optionally p = map Some (try p) <|> pure None
 
@@ -209,24 +222,35 @@ let rec sep_end_by_1 sep p =
 and sep_end_by sep p =
   sep_end_by_1 sep p <|> pure []
 
+let chainr1 p op =
+  let rec scan =
+    let! x = p
+    rest x
+  and rest x =
+    ( let! f = op
+      let! y = scan
+      pure (f x y)
+    ) <|> pure x
+  let _ = rest (* shut up, amc *)
+  scan
 
 let parse (P x) s =
-  let! x = x s
+  let! x = x { line = 0, col = 0 } s
   match x with
   | Ok (_, x, r) -> pure @@ Right (x, r)
-  | Err (_, m, _) -> pure @@ Left m
+  | Err (_, m, _, p) -> pure @@ Left (m, p)
 
 let run_parser p s =
   let Id x = parse p s
   x
 
 let run_parser' (P x) s =
-  let Id x = x s
+  let Id x = x { line = 0, col = 0 } s
   x
 
-let lift m = P @@ fun s ->
+let lift m = P @@ fun pos s ->
   let! x = m
-  pure @@ Ok (E, x, s)
+  pure @@ Ok (E, x, s, pos)
 
 let morph (k : forall 'a. 'm 'a -> 'n 'a) (P x) = P @@ fun s -> k (x s)
 let void x = map (const ()) x

lib/strings.ml

@@ -0,0 +1,16 @@
+module S = import "lua/string.ml"
+open import "prelude.ml"
+
+let split_on ch str =
+  let len = S.length str
+  let rec go i acc acc' = 
+    if i > len then
+      reverse (acc :: acc')
+    else
+      let this = S.substring str i i
+      if this == ch then
+        go (i + 1) "" (acc :: acc')
+      else
+        go (i + 1) (acc ^ this) acc'
+  go 1 "" []
+

parser.ml

@@ -8,7 +8,8 @@ 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)
+    <|> map Ref (try conid)
+    <|> map Lit (try integer)
     <+> between (try oparen) cparen expr
 and fexp : forall 'm. monad 'm => parser_t 'm expr =
   let! a = atom
@@ -39,14 +40,18 @@ and expr : forall 'm. monad 'm => parser_t 'm expr =
 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 =
+    <+> between (try oparen) cparen ty_tup
+and ty_fexp : forall 'm. monad 'm => parser_t 'm hstype =
   let! a = ty_atom
   let! ats = many ty_atom
   pure (foldl (curry Tyapp) a ats)
+and ty_exp : forall 'm. monad 'm => parser_t 'm hstype =
+  chainr1 ty_fexp (map (const (curry Tyarr)) arrow)
+and ty_tup : forall 'm. monad 'm => parser_t 'm hstype =
+  Tytup <$> sep_by comma ty_exp
 
 let datadec : forall 'm. monad 'm => parser_t 'm decl =
-  let! _ = keyword "data"
+  let! _ = try (keyword "data")
   let datacon =
     let! nm = conid
     let! args = many ty_atom
@@ -57,13 +62,29 @@ let datadec : forall 'm. monad 'm => parser_t 'm decl =
   let! c = sep_by_1 pipe (try datacon)
   pure (Data (nm, args, c))
 
+let fdecl : forall 'm. monad 'm => parser_t 'm fdecl =
+  let! _ = try (keyword "import")
+  let! cc =
+      ( (Lua <$ try (keyword "lua"))
+    <|> (Prim <$ try (keyword "prim"))
+      )
+  let! fent = string
+  let! var = varid
+  let! _ = dcolon
+  let! ftype = ty_exp
+  pure (Fimport { cc, fent, var, ftype })
+
+let func : forall 'm. monad 'm => parser_t 'm decl =
+  let! nm = varid
+  let! args = many (try varid)
+  let! _ = equals
+  map (fun e -> Decl (nm, args, e)) expr
+
 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 foreign =
+    let! _ = try (keyword "foreign")
+    map Foreign fdecl
+  try datadec <|> try foreign <|> func
 
 let prog : forall 'm. monad 'm => parser_t 'm prog =
   sep_end_by_1 semi dec <* eof

preamble.lua

@@ -1,49 +1,47 @@
 local A, F, I = {}, {}, {}
 
-local stack = {}
-local sp = 1
-
-local function repr(x)
+local function unwind(stack, sp)
+  local x = stack[sp]
   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]) .. ')'
+    if x[1] == A then
+      stack[sp + 1] = x[2]
+      return unwind(stack, sp + 1)
     elseif x[1] == I then
-      return '&' .. repr(x[2])
+      stack[sp] = x[2]
+      return unwind(stack, sp)
+    elseif x[1] == F then
+      if sp - 1 >= x[3] then
+        return x[2](stack, sp)
+      else
+        error("insufficient arguments for supercombinator " .. x[4])
+      end
     end
   else
-    return tostring(x)
+    return x, stack, sp
   end
 end
 
-local function unwind()
-  local x = stack[sp]
+local function repr(x)
   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()
+      return repr(x[2]) .. '(' .. repr(x[3])
     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
+      return x[4]
+    elseif x[1] == I then
+      return '&' .. repr(x[2])
     end
+    return '<bad node>'
   else
-    os.exit(x)
+    return tostring(x)
   end
 end
 
-local function getchar()
+local function eval(node)
+  local stack, sp = { node }, 1
+  return (unwind(stack, sp))
+end
+
+local function getchar(stack, sp)
   local k = stack[sp - 1][3]; sp = sp - 1
   local knil = stack[sp - 1][3]; sp = sp - 1
   local ch = io.read(1)
@@ -52,7 +50,7 @@ local function getchar()
   else
     stack[sp] = { A, knil, 0 }
   end
-  return unwind()
+  return unwind(stack, sp)
 end
 
 local getchar_combinator = { F, getchar, 2 }
@@ -62,7 +60,7 @@ local function putchar()
   local k = stack[sp - 2][3]; sp = sp - 1
   io.write(string.char(ch))
   stack[sp] = { A, k, ch }
-  return unwind()
+  return unwind(stack, sp)
 end
 
 local putchar_combinator = { F, putchar, 2 }