Adds lists, although they don't evaluate yet.

3 files changed, 34 insertions, 12 deletions

diff --git a/discocaml/ast.ml b/discocaml/ast.ml
index 3ba3f63..f3606cf 100644
--- a/discocaml/ast.ml
+++ b/discocaml/ast.ml
@@ -20,8 +20,10 @@ type 'a prim =
 
 and expr =
   | App of expr index * expr index
+  | Cons of expr index * expr index
   | Int of int
   | Lam of string * expr index
+  | Nil
   | Prim : 'a prim * 'a -> expr
   | Var of string
 
@@ -70,6 +72,11 @@ let add_expr_to_ast (ast : 'a ast) : Parsetree.expression -> expr index =
             | _ -> raise_unsupported_expr expr)
           (loop f) xs
     | Pexp_constant (Pconst_integer (n, None)) -> add (Int (int_of_string n))
+    | Pexp_construct
+        ({ txt = Lident "::"; _ }, Some { pexp_desc = Pexp_tuple [ hd; tl ]; _ })
+      ->
+        add (Cons (loop hd, loop tl))
+    | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> add Nil
     | Pexp_fun (Nolabel, None, arg_pat, body) -> (
         match arg_pat.ppat_desc with
         | Ppat_var { txt = name; _ } -> add (Lam (name, loop body))
@@ -131,6 +138,13 @@ let parsetree_of_subexpr (ast : 'a ast) : expr -> Parsetree.expression =
         let f, xs = list_of_apps expr in
         let xs = List.map (fun x -> (Asttypes.Nolabel, loop (subexpr x))) xs in
         Wrap.expression (Pexp_apply (loop f, xs))
+    | Cons (hd, tl) ->
+        Wrap.expression
+          (Pexp_construct
+             ( Wrap.ident "::",
+               Some
+                 (Wrap.expression
+                    (Pexp_tuple [ loop (subexpr hd); loop (subexpr tl) ])) ))
     | Int n ->
         Wrap.expression (Pexp_constant (Pconst_integer (Int.to_string n, None)))
     | Lam (x, b) ->
@@ -140,6 +154,7 @@ let parsetree_of_subexpr (ast : 'a ast) : expr -> Parsetree.expression =
                None,
                Wrap.pattern (Ppat_var (Wrap.var x)),
                loop (subexpr b) ))
+    | Nil -> Wrap.expression (Pexp_construct (Wrap.ident "[]", None))
     | Prim (Add, (l, r)) ->
         Wrap.expression
           (Pexp_apply
diff --git a/discocaml/draw_tree.ml b/discocaml/draw_tree.ml
index 3d01412..4b1688b 100644
--- a/discocaml/draw_tree.ml
+++ b/discocaml/draw_tree.ml
@@ -7,8 +7,16 @@ let add_node (fmt : Format.formatter) (i : expr index) (expr : expr) : unit =
       Format.fprintf fmt
         "  expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"apply\"];\n"
         i.index
+  | Cons _ ->
+      Format.fprintf fmt
+        "  expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"::\"];\n"
+        i.index
   | Int n -> Format.fprintf fmt "  expr%d [label=\"%d\"];\n" i.index n
   | Lam _ -> Format.fprintf fmt "  expr%d [label=\"λ\"];\n" i.index
+  | Nil ->
+      Format.fprintf fmt
+        "  expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"[]\"];\n"
+        i.index
   | Prim (Add, _) -> Format.fprintf fmt "  expr%d [label=\"+\"];\n" i.index
   | Prim (Sub, _) -> Format.fprintf fmt "  expr%d [label=\"-\"];\n" i.index
   | Prim (Mul, _) -> Format.fprintf fmt "  expr%d [label=\"*\"];\n" i.index
@@ -26,7 +34,9 @@ let add_expr_edges (ast : 'a ast) (fmt : Format.formatter)
     | App (f, x) ->
         edge_to f;
         edge_to x
-    | Int _ -> ()
+    | Cons (hd, tl) ->
+        edge_to hd;
+        edge_to tl
     | Lam (x, b) ->
         Format.fprintf fmt "  expr%d -> expr%d_var;\n" i.index i.index;
         Format.fprintf fmt "  expr%d_var [label=%S];\n" i.index x;
@@ -41,6 +51,7 @@ let add_expr_edges (ast : 'a ast) (fmt : Format.formatter)
         edge_to l;
         edge_to r
     | Var _ -> ()
+    | Int _ | Nil -> ()
   in
   loop
 
diff --git a/discocaml/eval.ml b/discocaml/eval.ml
index 5e2cae4..3957531 100644
--- a/discocaml/eval.ml
+++ b/discocaml/eval.ml
@@ -6,13 +6,12 @@ let check_redex (ast : expr ast) (i : expr index) : unit =
   match get_subexpr ast i with
   | App (f, _) -> (
       match get_subexpr ast f with Lam _ -> raise (FoundRedex i) | _ -> ())
-  | Int _ -> ()
-  | Lam _ -> ()
   | Prim (Add, (l, r)) | Prim (Sub, (l, r)) | Prim (Mul, (l, r)) -> (
       match (get_subexpr ast l, get_subexpr ast r) with
       | Int _, Int _ -> raise (FoundRedex i)
       | _ -> ())
   | Var _ -> ()
+  | Cons _ | Int _ | Lam _ | Nil -> ()
 
 let find_redex_cbv_in (ast : expr ast) : expr index -> unit =
   let rec loop (i : expr index) : unit =
@@ -20,12 +19,11 @@ let find_redex_cbv_in (ast : expr ast) : expr index -> unit =
     | App (f, x) ->
         loop f;
         loop x
-    | Int _ -> ()
-    | Lam _ -> ()
     | Prim (Add, (l, r)) | Prim (Sub, (l, r)) | Prim (Mul, (l, r)) ->
         loop l;
         loop r
-    | Var _ -> ());
+    | Var _ -> ()
+    | Cons _ | Int _ | Lam _ | Nil -> ());
     check_redex ast i
   in
   loop
@@ -37,12 +35,11 @@ let find_redex_cbn_in (ast : expr ast) : expr index -> unit =
     | App (f, x) ->
         loop f;
         loop x
-    | Int _ -> ()
-    | Lam _ -> ()
     | Prim (Add, (l, r)) | Prim (Sub, (l, r)) | Prim (Mul, (l, r)) ->
         loop l;
         loop r
     | Var _ -> ()
+    | Cons _ | Int _ | Lam _ | Nil -> ()
   in
   loop
 
@@ -71,10 +68,9 @@ let subst (ast : expr ast) (from : string) (to_ : expr index) :
         { index }
     in
     match get_subexpr ast i with
-    | App (f, x) ->
-        let f' = loop f and x' = loop x in
-        add (App (f', x'))
-    | Int _ -> i
+    | App (f, x) -> add (App (loop f, loop x))
+    | Cons (hd, tl) -> add (Cons (loop hd, loop tl))
+    | Int _ | Nil -> i
     | Lam (x, b) -> if String.equal from x then i else add (Lam (x, loop b))
     | Prim (Add, (l, r)) -> add (Prim (Add, (loop l, loop r)))
     | Prim (Sub, (l, r)) -> add (Prim (Sub, (loop l, loop r)))