aboutsummaryrefslogtreecommitdiff
path: root/discocaml
diff options
context:
space:
mode:
Diffstat (limited to 'discocaml')
-rw-r--r--discocaml/ast.ml14
-rw-r--r--discocaml/draw_tree.ml8
-rw-r--r--discocaml/eval.ml24
3 files changed, 40 insertions, 6 deletions
diff --git a/discocaml/ast.ml b/discocaml/ast.ml
index 025fa24..8e9c0c9 100644
--- a/discocaml/ast.ml
+++ b/discocaml/ast.ml
@@ -20,7 +20,9 @@ type 'a prim =
and expr =
| App of expr index * expr index
+ | Bool of bool
| Cons of expr index * expr index
+ | If of expr index * expr index * expr index
| Int of int
| Lam of string * expr index
| Let of bool * string * expr index * expr index
@@ -78,6 +80,8 @@ let add_expr_to_ast (ast : 'a ast) : Parsetree.expression -> expr index =
->
add (Cons (loop hd, loop tl))
| Pexp_construct ({ txt = Lident "[]"; _ }, None) -> add Nil
+ | Pexp_construct ({ txt = Lident "false"; _ }, None) -> add (Bool false)
+ | Pexp_construct ({ txt = Lident "true"; _ }, None) -> add (Bool true)
| Pexp_fun (Nolabel, None, arg_pat, body) -> (
match arg_pat.ppat_desc with
| Ppat_var { txt = name; _ } -> add (Lam (name, loop body))
@@ -86,6 +90,8 @@ let add_expr_to_ast (ast : 'a ast) : Parsetree.expression -> expr index =
| Pexp_ident { txt = Lident "-"; _ } -> binop Sub
| Pexp_ident { txt = Lident "*"; _ } -> binop Mul
| Pexp_ident { txt = Lident name; _ } -> add (Var name)
+ | Pexp_ifthenelse (cond, then_, Some else_) ->
+ add (If (loop cond, loop then_, loop else_))
| Pexp_let
( recursive,
[
@@ -153,6 +159,8 @@ 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))
+ | Bool b ->
+ Wrap.expression (Pexp_construct (Wrap.ident (string_of_bool b), None))
| Cons (hd, tl) ->
Wrap.expression
(Pexp_construct
@@ -160,6 +168,12 @@ let parsetree_of_subexpr (ast : 'a ast) : expr -> Parsetree.expression =
Some
(Wrap.expression
(Pexp_tuple [ loop (subexpr hd); loop (subexpr tl) ])) ))
+ | If (cond, then_, else_) ->
+ Wrap.expression
+ (Pexp_ifthenelse
+ ( loop (subexpr cond),
+ loop (subexpr then_),
+ Some (loop (subexpr else_)) ))
| Int n ->
Wrap.expression (Pexp_constant (Pconst_integer (Int.to_string n, None)))
| Lam (x, b) ->
diff --git a/discocaml/draw_tree.ml b/discocaml/draw_tree.ml
index 3429a71..08a8288 100644
--- a/discocaml/draw_tree.ml
+++ b/discocaml/draw_tree.ml
@@ -7,10 +7,12 @@ 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
+ | Bool b -> Format.fprintf fmt " expr%d [label=\"%b\"];\n" i.index b
| Cons _ ->
Format.fprintf fmt
" expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"::\"];\n"
i.index
+ | If (_, _, _) -> Format.fprintf fmt " expr%d [label=\"if\"];\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
| Let (recursive, _, _, _) ->
@@ -40,6 +42,10 @@ let add_expr_edges (ast : 'a ast) (fmt : Format.formatter)
| Cons (hd, tl) ->
edge_to hd;
edge_to tl
+ | If (cond, then_, else_) ->
+ edge_to cond;
+ edge_to then_;
+ edge_to else_
| 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;
@@ -59,7 +65,7 @@ let add_expr_edges (ast : 'a ast) (fmt : Format.formatter)
edge_to l;
edge_to r
| Var _ -> ()
- | Int _ | Nil -> ()
+ | Bool _ | Int _ | Nil -> ()
in
loop
diff --git a/discocaml/eval.ml b/discocaml/eval.ml
index 81709e6..f1e5a2b 100644
--- a/discocaml/eval.ml
+++ b/discocaml/eval.ml
@@ -9,10 +9,14 @@ let has_free_var (ast : expr ast) (i : expr index) (name : string) : bool =
| App (f, x) ->
loop f;
loop x
+ | Bool _ | Int _ | Nil -> ()
| Cons (hd, tl) ->
loop hd;
loop tl
- | Int _ | Nil -> ()
+ | If (cond, then_, else_) ->
+ loop cond;
+ loop then_;
+ loop else_
| Lam (x, b) -> if not (String.equal name x) then loop b
| Let (recursive, name', bound, body) ->
if not (String.equal name name') then loop body;
@@ -64,13 +68,15 @@ 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) | _ -> ())
+ | If (cond, _, _) -> (
+ match get_subexpr ast cond with Bool _ -> raise (FoundRedex i) | _ -> ())
| Let (_, _, _, _) -> raise (FoundRedex i)
| 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 -> ()
+ | Bool _ | Cons _ | Int _ | Lam _ | Nil -> ()
let find_redex_cbv_in (ast : expr ast) : expr index -> unit =
let rec loop (i : expr index) : unit =
@@ -78,12 +84,13 @@ let find_redex_cbv_in (ast : expr ast) : expr index -> unit =
| App (f, x) ->
loop f;
loop x
+ | If (cond, _, _) -> loop cond
| Let (_, _, bound, _) -> loop bound
| Prim (Add, (l, r)) | Prim (Sub, (l, r)) | Prim (Mul, (l, r)) ->
loop l;
loop r
| Var _ -> ()
- | Cons _ | Int _ | Lam _ | Nil -> ());
+ | Bool _ | Cons _ | Int _ | Lam _ | Nil -> ());
check_redex ast i
in
loop
@@ -95,12 +102,13 @@ let find_redex_cbn_in (ast : expr ast) : expr index -> unit =
| App (f, x) ->
loop f;
loop x
+ | If (cond, _, _) -> loop cond
| Let (_, _, _, body) -> loop body
| Prim (Add, (l, r)) | Prim (Sub, (l, r)) | Prim (Mul, (l, r)) ->
loop l;
loop r
| Var _ -> ()
- | Cons _ | Int _ | Lam _ | Nil -> ()
+ | Bool _ | Cons _ | Int _ | Lam _ | Nil -> ()
in
loop
@@ -131,8 +139,9 @@ let subst (ast : expr ast) (from : string) (to_ : expr index) :
in
match get_subexpr ast i with
| App (f, x) -> add (App (loop f, loop x))
+ | Bool _ | Int _ | Nil -> i
| Cons (hd, tl) -> add (Cons (loop hd, loop tl))
- | Int _ | Nil -> i
+ | If (cond, then_, else_) -> add (If (loop cond, loop then_, loop else_))
| Lam (x, b) -> if String.equal from x then i else add (Lam (x, loop b))
| Let (false, name, bound, body) ->
add
@@ -156,6 +165,11 @@ let reduce (ast : expr ast) (i : expr index) : expr ast =
match get_subexpr ast f with
| Lam (x', b) -> get_subexpr ast (subst ast x' x b)
| _ -> fail ())
+ | If (cond, then_, else_) -> (
+ match get_subexpr ast cond with
+ | Bool true -> get_subexpr ast then_
+ | Bool false -> get_subexpr ast else_
+ | _ -> fail ())
| Let (_, name, _, body) when not (has_free_var ast body name) ->
get_subexpr ast body
| Let (recursive, name, bound, body) ->
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-28 21:38:22 +0000