Add Bool and If

ast.ml

@@ -2,6 +2,7 @@
 type t =
   | Nint of int
   | Nfloat of float
+  | Nbool of bool
   | Nstring of string
   | Nsymbol of string
   | Nfunction of string list * t
@@ -10,6 +11,7 @@ type t =
   | Let of string * t
   | Unary of operator * t
   | Binop of t * operator * t
+  | If of t * t * t (* cond then else *)
   | Apply of t * t list (* function application *)
   (* these will be seperated into (toplevel) directives. *)
   | Set_binop_pre of operator * t
@@ -44,12 +46,13 @@ let print ast =
   let rec aux = function
     | Nint n -> pr "%d" n
     | Nfloat n -> pr "%f" n
+    | Nbool b -> pr "%b" b
     | Nstring s -> pr "\"%s\"" s
     | Nsymbol s -> pr "#%s" s
     | Nfunction (args, e) ->
-      pr "lambda (%s" @@ List.hd args;
+      pr "(lambda (%s" @@ List.hd args;
       List.iter (pr " %s") @@ List.tl args;
-      pr ") ("; aux e; pr")"
+      pr ") "; aux e; pr ")"
     | Nexternal e -> pr "(extern %s)" e
     | Var v -> pr "%s" v
     | Let (v, e) ->
@@ -60,8 +63,11 @@ let print ast =
     | Binop (left, op, right) ->
       let op = op_to_string op in
       pr "(%s " op; aux left; pr " "; aux right; pr ")"
+    | If (co, th, el) ->
+      let f e = pr " "; aux e in
+      pr "(if"; f co; f th; f el; pr ")"
     | Apply (f, args) ->
-      pr "("; List.iter aux @@ f::args; pr ")"
+      pr "("; aux f; List.iter (fun a -> pr " "; aux a) args; pr ")"
 
     | Set_binop_pre (op, pre) ->
       pr "(set_pre %s " (op_to_string op);

eval.ml

@@ -1,8 +1,10 @@
 open Ast
 
+(* resulting value of eval *)
 type value =
   | Int of int
   | Float of float
+  | Bool of bool
   | String of string
   | Symbol of string
   | Function of string list * expr
@@ -11,6 +13,7 @@ type value =
 
 and expr = Ast.t
 
+(* environment for eval *)
 and env = {
   vars : (string, value) Hashtbl.t;
   parent : env option;
@@ -23,6 +26,7 @@ module Type = struct
   type t =
     | Int
     | Float
+    | Bool
     | String
     | Symbol
     | Function
@@ -33,6 +37,7 @@ module Type = struct
   let to_string = function
     | Int -> "int"
     | Float -> "float"
+    | Bool -> "bool"
     | String -> "string"
     | Symbol -> "symbol"
     | Function -> "fun"
@@ -49,6 +54,7 @@ module Value = struct
   let to_string = function
     | Int n -> string_of_int n
     | Float n -> string_of_float n
+    | Bool b -> string_of_bool b
     | String s -> "\"" ^ s ^ "\""
     | Symbol s -> "symbol " ^ s
     | Function (vars, _) ->
@@ -59,6 +65,7 @@ module Value = struct
   let typeof = function
     | Int _ -> Type.Int
     | Float _ -> Type.Float
+    | Bool _ -> Type.Bool
     | String _ -> Type.String
     | Symbol _ -> Type.Symbol
     | Function _ -> Type.Function
@@ -217,6 +224,7 @@ let rec eval env ast : string * value =
   let rec aux = function
     | Nint n -> Int n
     | Nfloat n -> Float n
+    | Nbool b -> Bool b
     | Nstring s -> String s
     | Nsymbol s -> Symbol s
     | Nfunction (args, e) -> Function (args, e)
@@ -232,6 +240,12 @@ let rec eval env ast : string * value =
     | Binop (l, op, r) ->
       let l = aux l and r = aux r in
       binop op l r
+    | If (co, th, el) ->
+      begin match aux co with
+        | Bool true -> aux th
+        | Bool false -> aux el
+        | v -> raise @@ Type.Invalid (Value.typeof v)
+      end
     | Apply (v, args) ->
       begin match aux v with
         | Function (vars, e) ->

main.ml

@@ -2,6 +2,7 @@ open Printf
 open Eval
 
 let version = "%%VERSION%%"
+let debug = ref false
 
 let error_to_string e =
   try raise e with
@@ -36,12 +37,9 @@ let rep env : unit =
   printf "> ";
   let line = read_line () in
   if line = "quit" then raise Exit;
-  let var, v =
-    line
-    |> Lex.tokenize
-    |> Parser.parse
-    |> Eval.eval env
-  in
+  let ast = line |> Lex.tokenize |> Parser.parse in
+  if !debug then Ast.print ast;
+  let var, v = Eval.eval env ast in
   match v with
   | Nop -> ()
   | _ ->

parser.ml

@@ -148,6 +148,14 @@ let rec decl seq =
     expr min_int;
   ]
 
+(* let_value := "let" ident "=" expr *)
+and let_value seq =
+  let _, seq = ident "let" seq in
+  let id, seq = any_ident seq in
+  let _, seq = token Token.Equal seq in
+  let e, seq = expr min_int seq in
+  Let (id, e), seq
+
 (* expr := level
  *       | assoc
  *       | apply
@@ -155,12 +163,13 @@ let rec decl seq =
 *)
 and expr pre seq =
   seq |> oneof [
+    (either unary value) @> binop pre;
+    ifexpr;
     level;
     assoc;
     lambda;
     extern_value;
     apply;
-    (either unary value) @> binop pre;
   ]
 
 (* level := "level" {"get" | "set"} [op] *)
@@ -189,14 +198,6 @@ and assoc seq =
   else
     failwith "Parser.assoc"
 
-(* let_value := "let" ident "=" expr *)
-and let_value seq =
-  let _, seq = ident "let" seq in
-  let id, seq = any_ident seq in
-  let _, seq = token Token.Equal seq in
-  let e, seq = expr min_int seq in
-  Let (id, e), seq
-
 (* lambda := "fun" [ident]+ "->" expr *)
 and lambda seq =
   let _, seq = ident "fun" seq in
@@ -206,6 +207,16 @@ and lambda seq =
   let e, seq = expr min_int seq in
   Nfunction (v0::vars, e), seq
 
+(* ifexpr := "if" expr "then" expr "else" expr *)
+and ifexpr seq =
+  let _, seq = ident "if" seq in
+  let co, seq = expr min_int seq in
+  let _, seq = ident "then" seq in
+  let th, seq = expr min_int seq in
+  let _, seq = ident "else" seq in
+  let el, seq = expr min_int seq in
+  If (co, th, el), seq
+
 (* apply := value [value]+ *)
 and apply seq =
   let v, seq = value seq in
@@ -237,7 +248,9 @@ and value seq =
   match seq () with
   | Seq.Nil -> raise End_of_tokens
   | Seq.Cons (x, seq) -> begin match x with
-      | Token.Ident id -> Var id, seq
+      | Ident "true" -> Nbool true, seq
+      | Ident "false" -> Nbool false, seq
+      | Ident id -> Var id, seq
       | Int x -> Nint x, seq
       | Float x -> Nfloat x, seq
       | String x -> Nstring x, seq
@@ -268,7 +281,8 @@ and binop pre left seq =
         else
           left, Seq.cons x seq
 
-      | Token.RParen -> left, Seq.cons x seq
+      | RParen | Ident "then" | Ident "else" ->
+        left, Seq.cons x seq
       | _ -> unexpected_token x
     end