Skip to content

Commit

Permalink
add while
Browse files Browse the repository at this point in the history
  • Loading branch information
@joongwon
joongwon committed Jan 7, 2025
1 parent fae9a18 commit 4e73c97
Show file tree
Hide file tree
Showing 2 changed files with 169 additions and 17 deletions.
126 changes: 111 additions & 15 deletions lib/js_syntax.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,14 +95,12 @@ let expr_is_unit = function
| Syntax.Expr.Const Syntax.Expr.Unit -> true
| _ -> false

(* return a wrapped expression that always returns a completion object *)
let wrap_cpl (cpl : completion) (expr : Syntax.Expr.hook_free_t) :
Syntax.Expr.hook_free_t =
let cpl_literal_expr =
let open Syntax.Expr in
match cpl with
| CDet CNormal ->
function
| (CNormal, None) ->
let obj_var = fresh () in
let cpl_literal = Let
Let
{
id = obj_var;
bound = Alloc;
Expand All @@ -116,11 +114,8 @@ let wrap_cpl (cpl : completion) (expr : Syntax.Expr.hook_free_t) :
},
Var obj_var );
}
in
if expr_is_unit expr then cpl_literal else Seq ( expr, cpl_literal )
| CDet CBreak label ->
| (CBreak label, None) ->
let obj_var = fresh () in
let cpl_literal =
Let
{
id = obj_var;
Expand All @@ -142,9 +137,7 @@ let wrap_cpl (cpl : completion) (expr : Syntax.Expr.hook_free_t) :
},
Var obj_var ) );
}
in
if expr_is_unit expr then cpl_literal else Seq ( expr, cpl_literal )
| CDet CReturn ->
| (CReturn, Some expr) ->
let obj_var = fresh () in
Let
{
Expand All @@ -167,6 +160,18 @@ let wrap_cpl (cpl : completion) (expr : Syntax.Expr.hook_free_t) :
},
Var obj_var ) );
}
| _ -> raise (Invalid_argument "cpl_literal_expr : expr should be present iff CReturn is used")

(* return a wrapped expression that always returns a completion object *)
let wrap_cpl (cpl : completion) (expr : Syntax.Expr.hook_free_t) :
Syntax.Expr.hook_free_t =
let open Syntax.Expr in
match cpl with
| CDet ((CNormal | CBreak _) as cpl) ->
let cpl_literal = cpl_literal_expr (cpl, None) in
if expr_is_unit expr then cpl_literal else Seq ( expr, cpl_literal )
| CDet CReturn ->
cpl_literal_expr (CReturn, Some expr)
| CIndet _ -> expr

let convert_seq ((e1, cpl1) : Syntax.Expr.hook_free_t * completion)
Expand Down Expand Up @@ -226,10 +231,101 @@ let convert_cond
in
(Cond { pred = test; con; alt }, cpl)

let convert_repeat _label ((_body, _cpl) : Syntax.Expr.hook_free_t * completion) :
let convert_repeat label ((body, cpl) : Syntax.Expr.hook_free_t * completion) :
Syntax.Expr.hook_free_t * completion =
(* use my repeat desugar *)
raise NotImplemented (* TODAY TODO *)
let open Syntax.Expr in
match cpl with
| CDet CNormal ->
let func_name = fresh () in
let param_name = fresh () in
(
App {
fn = Fn {
self = Some func_name;
param = param_name;
body = Seq (
body,
App {
fn = Var func_name;
arg = Const Unit;
}
)
};
arg = Const Unit
}
,
CDet CNormal (* TODO: replace with (CIndet []) ? *)
)
| CDet (CBreak label') when equal_label label label' ->
(body, CDet CNormal)
| CDet (CBreak _ | CReturn) ->
(body, cpl)
| CIndet cpls ->
let cpls' = cpls |> List.filter_map ~f:(fun cpl ->
match cpl with
| CNormal -> None
| (CBreak label') when equal_label label label' -> Some CNormal
| _ -> Some cpl
) |> List.dedup_and_sort ~compare:compare_flat_completion
in
let func_name = fresh () in
let param_name = fresh () in
let cpl_name = fresh () in
(* (fix f x.
let c = <body> in
if c.tag = "BRK" && c.label = <label> then
{ tag: "NRM" }
else if c.tag = "NRM" then
f x
else
c) () *)
(
App {
fn = Fn {
self = Some func_name;
param = param_name;
body =
Let {
id = cpl_name;
bound = body;
body =
Cond {
pred = Bop {
op = And;
left = Bop {
op = Eq;
left = Get { obj = Var cpl_name; idx = Const (String "tag") };
right = Const (String "BRK");
};
right = Bop {
op = Eq;
left = Get { obj = Var cpl_name; idx = Const (String "label") };
right = Const (String (string_of_label label));
};
};
con = cpl_literal_expr (CNormal, None);
alt =
Cond {
pred = Bop {
op = Eq;
left = Get { obj = Var cpl_name; idx = Const (String "tag") };
right = Const (String "NRM");
};
con = App {
fn = Var func_name;
arg = Const Unit;
};
alt = Var cpl_name;
}
}
}
};
arg = Const Unit
}
,
CIndet cpls'
)

let rec convert_stat_list (body : (Loc.t, Loc.t) Flow_ast.Statement.t list) :
Syntax.Expr.hook_free_t * completion =
Expand Down
60 changes: 58 additions & 2 deletions test/test_react_trace.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -535,11 +535,66 @@ let js_fn () =

let js_rec () =
let open Syntax in
let js, _ = parse_js "let f = (function(x) { return f(x); })" in
let js, _ = parse_js "let t = (function f(x) { return f(x); })" in
let prog = Js_syntax.convert js in
Alcotest.(check' (of_pp Sexp.pp_hum))
~msg:"convert recursive function" ~actual:(Prog.sexp_of_t prog)
~expected:(parse_prog "let f = fun x -> f x in ()" |> Prog.sexp_of_t)
~expected:(parse_prog "let t = (rec f = fun x -> f x) in ()" |> Prog.sexp_of_t)

let js_while () =
let open Syntax in
let js, _ = parse_js "let a = true; let b = (function(x){}); while (a) { b(0) }" in
let prog = Js_syntax.convert js in
Alcotest.(check' (of_pp Sexp.pp_hum))
~msg:"convert while" ~actual:(Prog.sexp_of_t prog)
~expected:(parse_prog {|
let a = true in
let b = fun x -> () in
(rec Fbrk = fun Xbrk ->
let Cbrk = (rec Fcont = fun Xcont ->
let Ccont =
let Cif =
if a then
let Ctrue = {} in
Ctrue["tag"] := "NRM";
Ctrue
else
let Cfalse = {} in
Cfalse["tag"] := "BRK";
Cfalse["label"] := brk;
Cfalse
in
if Cif["tag"] = "NRM" then (
b 0;
let Cbody = {} in
Cbody["tag"] := "NRM";
Cbody
) else
Cif
in
if Ccont["tag"] = "BRK" &&
Ccont["label"] = "con" then
let CFnrm = {} in
CFnrm["tag"] := "NRM";
CFnrm
else if Ccont["tag"] = NRM then
Fcont ()
else
Ccont)
()
in
if Cbrk["tag"] = "BRK" &&
Cbrk["label"] = "brk" then
let CFnrm2 = {} in
CFnrm2["tag"] := "NRM";
CFnrm2
else if Cbrk["tag"] = "NRM" then
Fbrk ()
else Cbrk)
()
|}
|> alpha_conv_prog Fun.id prog
|> Prog.sexp_of_t)

let js_literal () =
let open Syntax in
Expand Down Expand Up @@ -1044,6 +1099,7 @@ let () =
test_case "var" `Quick js_var;
test_case "function" `Quick js_fn;
test_case "recursive function" `Quick js_rec;
test_case "while" `Quick js_while;
test_case "literal" `Quick js_literal;
test_case "jsx" `Quick js_jsx;
test_case "binop" `Quick js_op;
Expand Down

0 comments on commit 4e73c97

Please sign in to comment.