Initial Commit

.gitignore

@@ -0,0 +1 @@
+_build

ast.ml

@@ -0,0 +1,52 @@
+type _ typ =
+  | Int : int -> int typ
+  | Unit : unit typ
+
+let typ_to_string : type a. a typ -> string = function
+  | Int n -> Printf.sprintf "%d" n
+  | Unit -> "()"
+
+type (_, _) binop =
+  | Add : (int, int) binop
+  | Sub : (int, int) binop
+  | Mul : (int, int) binop
+  | Div : (int, int) binop
+
+let binop_to_string : type a b. (a, b) binop -> string = function
+  | Add -> "+"
+  | Sub -> "-"
+  | Mul -> "*"
+  | Div -> "/"
+
+type _ t =
+  | Value : 'a typ -> 'a t
+  | Binop : 'a t * ('a, 'b) binop * 'a t -> 'b t
+  | Set_binop_pre : ('a, 'b) binop * int t -> unit t
+
+let value v = Value v
+
+let binop left op right =
+  Binop (left, op, right)
+
+let set_binop_pre op pre =
+  Set_binop_pre (op, pre)
+
+(* print ast LISP style. *)
+let print ast =
+  let pr = Printf.printf in
+  let pv v = pr "%s" @@ typ_to_string v in
+  let rec aux : type a. a t -> unit = function
+    | Value n -> pv n
+    | Binop (left, op, right) -> begin
+        pr "(%s " @@ binop_to_string op;
+        aux left;
+        pr " ";
+        aux right;
+        pr ")";
+      end
+    | Set_binop_pre (op, pre) ->
+      pr "(set_pre %s " (binop_to_string op);
+      aux pre;
+      pr ")"
+  in
+  aux ast; pr "\n"

dune

@@ -0,0 +1,2 @@
+(executable
+  (name main))

dune-project

@@ -0,0 +1 @@
+(lang dune 2.9)

eval.ml

@@ -0,0 +1,18 @@
+open Ast
+
+let binop_to_func : type a b. (a, b) Ast.binop -> (a -> a -> b) = function
+  | Add -> Int.add
+  | Sub -> Int.sub
+  | Mul -> Int.mul
+  | Div -> Int.div
+  | Eq -> (=)
+
+let rec eval : type a. a Ast.t -> a = function
+  | Value (Int t) -> t
+  | Value Unit -> ()
+  | Binop (l, op, r) ->
+    let f = binop_to_func op in
+    f (eval l) (eval r)
+  | Set_binop_pre (op, l) ->
+    Hashtbl.replace Parser.precedence
+      (Ast.binop_to_string op) (eval l)

lex.ml

@@ -0,0 +1,57 @@
+type tokens = Token.t Seq.t
+
+let either f g c =
+  f c || g c
+
+let is_digit c =
+  '0' <= c && c <= '9'
+
+let is_num = function
+  | 'x' -> true
+  | c -> is_digit c
+
+let is_whitespace = function
+  | ' ' | '\t' | '\n' -> true
+  | _ -> false
+
+let is_alpha c =
+  'A' <= c && c <= 'Z' && 'a' <= c && c <= 'z'
+
+let is_ident_start =
+  either is_alpha ((=) '_')
+
+let is_ident =
+  either is_ident_start is_digit
+
+(* same as take_while f seq, drop_while f seq *)
+let rec partition_while f seq : 'a Seq.t * 'a Seq.t =
+  match seq () with
+  | Seq.Nil -> Seq.empty, seq
+  | Seq.Cons (x, seq) ->
+    if f x then
+      let n, s = partition_while f seq in
+      Seq.cons x n, s
+    else
+      Seq.(empty, cons x seq)
+
+let tokenize (str : string) : tokens =
+  let seq = String.to_seq str in
+  let rec aux seq =
+    let open Token in
+    match seq () with
+    | Seq.Nil -> Seq.empty
+    | Seq.Cons (x, s) ->
+      if is_whitespace x then
+        aux s
+      else if is_digit x then
+        let n, s = partition_while is_num s in
+        let n = String.of_seq @@ Seq.cons x n in
+        Seq.cons (of_string n) (aux s)
+      else if is_ident_start x then
+        let id, s = partition_while is_ident s in
+        let id = String.of_seq @@ Seq.cons x id in
+        Seq.cons (Ident id) (aux s)
+      else
+        Seq.cons (of_char x) (aux s)
+  in
+  aux seq

main.ml

@@ -0,0 +1,14 @@
+(* simple REPL *)
+let rec repl () : unit =
+  Printf.printf "> ";
+  let line = read_line () in
+  if line <> "quit" then begin
+    line
+    |> Lex.tokenize
+    |> Parser.parse
+    |> Eval.eval
+    |> Printf.printf "%d\n";
+    repl ()
+  end
+
+let () = repl ()

parser.ml

@@ -0,0 +1,90 @@
+open Ast
+
+exception Expected of string
+exception Unexpected_token of string
+
+let expected t =
+  raise (Expected t)
+
+let unexpected_token t =
+  raise @@ Unexpected_token (Token.to_string t)
+
+let precedence = [
+  "+", 10;
+  "-", 10;
+  "*", 20;
+  "/", 20;
+] |> List.to_seq |> Hashtbl.of_seq
+
+let precedence_of op =
+  Hashtbl.find precedence (Ast.binop_to_string op)
+
+let token_to_op = function
+  | Token.Plus -> Add
+  | Minus -> Sub
+  | Asterisk -> Mul
+  | Slash -> Div
+  | _ -> failwith "Parser.token_to_op"
+
+let parse : type a. Token.t Seq.t -> a Ast.t = fun ts ->
+  (* value := int | ( expr ) *)
+  let rec value seq =
+    match seq () with
+    | Seq.Nil -> assert false
+    | Seq.Cons (x, seq) -> begin match x with
+        | Token.Int n -> Value (Int n), seq
+        | LParen -> expr seq
+        | _ -> unexpected_token x
+      end
+
+  (* binop := binop op binop *)
+  and binop pre left seq =
+    match seq () with
+    | Seq.Nil -> left, Seq.empty
+    | Seq.Cons (x, seq) -> begin match x with
+        | Token.Plus | Minus | Asterisk | Slash as op ->
+          let op = token_to_op op in
+          let o = precedence_of op in 
+          if o > pre then
+            let v, seq = value seq in
+            let right, seq = binop o v seq in
+            binop pre (Ast.binop left op right) seq
+          else
+            left, Seq.cons x seq
+        | RParen -> left, seq
+        | _ -> unexpected_token x
+      end
+
+  and operator seq =
+    match seq () with
+    | Seq.Nil -> expected "operator"
+    | Seq.Cons (x, seq) ->
+      try token_to_op x, seq with
+      | _ -> expected "operator"
+
+  and set_conf seq =
+    match seq () with
+    | Seq.Nil -> expected "ident"
+    | Seq.Cons (x, seq) -> begin match x with
+        | Token.Ident "level" ->
+          let op, seq = operator seq in
+          let v, seq = value seq in
+          Set_binop_pre (op, v), seq
+        | _ -> expected "argument"
+      end
+
+  and expr seq =
+    match seq () with
+    | Seq.Nil -> Value Unit (* nop *)
+    | Seq.Cons (x, s) -> begin match x with
+        | Ident "set" -> set_conf s
+        | _ ->
+          let left, seq = value seq in
+          binop ~-1 left seq
+      end
+  in
+  let ast, _ = expr ts in
+  (*
+  if rest () <> Seq.Nil then failwith "Parser.parse";
+     *)
+  ast

test.ml

@@ -0,0 +1,5 @@
+
+let test_lex =
+  let open Token in
+  let t = Lex.tokenize "10 + 20 30/40" |> List.of_seq in
+  assert (t = [Int 10; Plus; Int 20; Int 30; Slash; Int 40])

token.ml

@@ -0,0 +1,37 @@
+type t =
+  | Int of int
+  | Ident of string
+  | Plus
+  | Minus
+  | Asterisk
+  | Slash
+  | LParen
+  | RParen
+
+let of_char = function
+  | '+' -> Plus
+  | '-' -> Minus
+  | '*' -> Asterisk
+  | '/' -> Slash
+  | '(' -> LParen
+  | ')' -> RParen
+  | _ -> invalid_arg "Token.of_char"
+
+let of_string str =
+  let fc = Char.code str.[0] in
+  if Char.(code '0' <= fc && fc <= code '9') then
+    Int (int_of_string str)
+  else
+    match str with
+    | _ when String.length str = 1 -> of_char str.[0]
+    | _ -> failwith "Token.of_string"
+
+let to_string = function
+  | Int n -> string_of_int n
+  | Ident s -> s
+  | Plus -> "+"
+  | Minus -> "-"
+  | Asterisk -> "*"
+  | Slash -> "/"
+  | LParen -> "("
+  | RParen -> ")"