From 920f09719d78e984ae81fb8e5d8e90c9a6e6b367 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=EC=95=88=EC=A4=91=EC=9B=90?= Date: Mon, 23 Sep 2024 17:57:18 +0900 Subject: [PATCH] Basic JS Conversion (#3) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * ✨ Basic features of convert function * ✨ Add export statements, remove unnecessary names for binding * Add js mem * Add update without set test * Add js array expression conversion * Add js syntax conversion tests * Add more js conversion tests * Add more conversion * Add string * Update &&, ||, ?? conversion * Add alpha conversion in test * - Remove T.memory - Rename Loc to Addr - Add exceptions --- bin/main.ml | 6 +- lib/concrete_domains.ml | 31 +++ lib/domains.ml | 46 ++++ lib/interp.ml | 122 +++++++--- lib/js_syntax.ml | 465 +++++++++++++++++++++++++++++++++++++++ lib/lexer.mll | 20 ++ lib/logger.ml | 70 ++++-- lib/parser.mly | 8 + lib/syntax.ml | 20 +- samples/record.ml | 6 + samples/simple.tsx | 3 + test/test_react_trace.ml | 440 ++++++++++++++++++++++++++++++++++++ 12 files changed, 1176 insertions(+), 61 deletions(-) create mode 100644 samples/record.ml create mode 100644 samples/simple.tsx diff --git a/bin/main.ml b/bin/main.ml index bab69cc..2ec9158 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -58,9 +58,11 @@ let () = in Arg.parse speclist (fun x -> filename := x) usage_msg; if String.is_empty !filename then Arg.usage speclist usage_msg - else if !opt_parse_js then + else if !opt_parse_js then ( let js_syntax, _ = Js_syntax.parse !filename in - print_endline (Js_syntax.show js_syntax) + print_endline (Js_syntax.show js_syntax); + let prog = Js_syntax.convert js_syntax in + Sexp.pp_hum Stdlib.Format.std_formatter (Syntax.Prog.sexp_of_t prog)) else ( Fmt_tty.setup_std_outputs (); Logs.set_reporter (Logs_fmt.reporter ()); diff --git a/lib/concrete_domains.ml b/lib/concrete_domains.ml index e31dd6f..7c5ed56 100644 --- a/lib/concrete_domains.ml +++ b/lib/concrete_domains.ml @@ -5,6 +5,8 @@ module M : Domains.S = struct module rec T : (Domains.T with type path = int) = struct type path = Path.t [@@deriving sexp_of] type env = Env.t [@@deriving sexp_of] + type addr = Addr.t [@@deriving sexp_of] + type obj = Obj.t [@@deriving sexp_of] type st_store = St_store.t [@@deriving sexp_of] type job_q = Job_q.t [@@deriving sexp_of] @@ -15,6 +17,8 @@ module M : Domains.S = struct | Unit | Bool of bool | Int of int + | String of string + | Addr of addr | View_spec of view_spec list | Clos of clos | Set_clos of set_clos @@ -59,6 +63,29 @@ module M : Domains.S = struct let extend env ~id ~value = Map.set env ~key:id ~data:value end + and Addr : (Domains.Addr with type t = T.addr) = Int + + and Obj : (Domains.Obj with type value = T.value and type t = T.obj) = struct + type value = T.value [@@deriving sexp_of] + type t = value Id.Map.t [@@deriving sexp_of] + + let empty = Id.Map.empty + let lookup obj ~field = Map.find obj field |> Option.value ~default:T.Unit + let update obj ~field ~value = Map.set obj ~key:field ~data:value + end + + and Memory : (Domains.Memory with type obj = T.obj and type addr = T.addr) = + struct + type obj = T.obj [@@deriving sexp_of] + type addr = T.addr [@@deriving sexp_of] + type t = obj Map.M(Addr).t [@@deriving sexp_of] + + let empty = Map.empty (module Addr) + let alloc = Map.length + let lookup memory ~addr = Map.find_exn memory addr + let update memory ~addr ~obj = Map.set memory ~key:addr ~data:obj + end + and St_store : (Domains.St_store with type value = T.value @@ -149,10 +176,13 @@ module M : Domains.S = struct module Value = struct type nonrec view_spec = view_spec type nonrec clos = clos + type nonrec addr = addr type t = value let to_bool = function Bool b -> Some b | _ -> None let to_int = function Int i -> Some i | _ -> None + let to_string = function String s -> Some s | _ -> None + let to_addr = function Addr l -> Some l | _ -> None let to_vs = function | Unit -> Some Vs_null @@ -168,6 +198,7 @@ module M : Domains.S = struct | Unit, Unit -> true | Bool b1, Bool b2 -> Bool.(b1 = b2) | Int i1, Int i2 -> i1 = i2 + | Addr l1, Addr l2 -> Addr.(l1 = l2) | _, _ -> false let ( = ) = equal diff --git a/lib/domains.ml b/lib/domains.ml index f528d09..f48d9c1 100644 --- a/lib/domains.ml +++ b/lib/domains.ml @@ -4,6 +4,8 @@ open Syntax module type T = sig type path type env + type addr + type obj type st_store type job_q type clos = { param : Id.t; body : Expr.hook_free_t; env : env } @@ -14,6 +16,8 @@ module type T = sig | Unit | Bool of bool | Int of int + | String of string + | Addr of addr | View_spec of view_spec list | Clos of clos | Set_clos of set_clos @@ -49,6 +53,8 @@ module type T = sig val sexp_of_part_view : part_view -> Sexp.t val sexp_of_tree : tree -> Sexp.t val sexp_of_entry : entry -> Sexp.t + val sexp_of_addr : addr -> Sexp.t + val sexp_of_obj : obj -> Sexp.t end module type Path = sig @@ -72,6 +78,39 @@ module type Env = sig val sexp_of_t : t -> Sexp.t end +module type Addr = sig + type t + type comparator_witness + + val comparator : (t, comparator_witness) Comparator.t + val sexp_of_t : t -> Sexp.t + val equal : t -> t -> bool + val ( = ) : t -> t -> bool + val ( <> ) : t -> t -> bool +end + +module type Obj = sig + type value + type t + + val empty : t + val lookup : t -> field:Id.t -> value + val update : t -> field:Id.t -> value:value -> t + val sexp_of_t : t -> Sexp.t +end + +module type Memory = sig + type obj + type addr + type t + + val empty : t + val alloc : t -> addr + val lookup : t -> addr:addr -> obj + val update : t -> addr:addr -> obj:obj -> t + val sexp_of_t : t -> Sexp.t +end + module type St_store = sig type value type job_q @@ -110,10 +149,13 @@ end module type Value = sig type view_spec type clos + type addr type t val to_bool : t -> bool option val to_int : t -> int option + val to_string : t -> string option + val to_addr : t -> addr option val to_vs : t -> view_spec option val to_vss : t -> view_spec list option val to_clos : t -> clos option @@ -143,6 +185,9 @@ module type S = sig include T module Path : Path with type t = path module Env : Env with type value = value and type t = env + module Addr : Addr with type t = addr + module Obj : Obj with type value = value and type t = obj + module Memory : Memory with type obj = obj and type addr = addr module St_store : St_store @@ -166,6 +211,7 @@ module type S = sig with type view_spec = view_spec and type clos = clos and type t = value + and type addr = addr module Phase : Phase with type t = phase module Decision : Decision with type t = decision diff --git a/lib/interp.ml b/lib/interp.ml index 59a4b99..cb6dc8c 100644 --- a/lib/interp.ml +++ b/lib/interp.ml @@ -16,7 +16,13 @@ type _ Stdlib.Effect.t += | Rd_env : Env.t t | In_env : Env.t -> (('b -> 'a) -> 'b -> 'a) t -(* memory effects in eval/eval_mult *) +(* memory effects *) +type _ Stdlib.Effect.t += + | Alloc_addr : obj -> Addr.t t + | Lookup_addr : Addr.t -> obj t + | Update_addr : Addr.t * obj -> unit t + +(* tree memory effects in eval/eval_mult *) type _ Stdlib.Effect.t += | Lookup_st : Path.t * Label.t -> (value * Job_q.t) t | Update_st : (Path.t * Label.t * (value * Job_q.t)) -> unit t @@ -24,7 +30,7 @@ type _ Stdlib.Effect.t += | Set_dec : Path.t * decision -> unit t | Enq_eff : Path.t * clos -> unit t -(* memory effects in render *) +(* tree memory effects in render *) type _ Stdlib.Effect.t += | Alloc_pt : Path.t t | Lookup_ent : Path.t -> entry t @@ -102,51 +108,82 @@ let mem_h = Logger.mem mem `Ret; (v, mem)); exnc = raise; + effc = + (fun (type a) (eff : a t) -> + match eff with + | Alloc_addr obj -> + Some + (fun (k : (a, _) continuation) ~(mem : Memory.t) -> + Logger.mem mem `Alloc_addr; + let addr = Memory.alloc mem in + let mem = Memory.update mem ~addr ~obj in + continue k addr ~mem) + | Lookup_addr addr -> + Some + (fun (k : (a, _) continuation) ~(mem : Memory.t) -> + Logger.mem mem (`Lookup_addr addr); + continue k (Memory.lookup mem ~addr) ~mem) + | Update_addr (addr, v) -> + Some + (fun (k : (a, _) continuation) ~(mem : Memory.t) -> + Logger.mem mem (`Update_addr (addr, v)); + continue k () ~mem:(Memory.update mem ~addr ~obj:v)) + | _ -> None); + } + +let treemem_h = + { + retc = + (fun v ~treemem -> + Logger.treemem treemem `Ret; + (v, treemem)); + exnc = raise; effc = (fun (type a) (eff : a t) -> match eff with (* in eval *) | Lookup_st (path, label) -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Lookup_st (path, label)); - continue k (Tree_mem.lookup_st mem ~path ~label) ~mem) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Lookup_st (path, label)); + continue k (Tree_mem.lookup_st treemem ~path ~label) ~treemem) | Update_st (path, label, (v, q)) -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Update_st (path, label, (v, q))); - continue k () ~mem:(Tree_mem.update_st mem ~path ~label (v, q))) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Update_st (path, label, (v, q))); + continue k () + ~treemem:(Tree_mem.update_st treemem ~path ~label (v, q))) | Get_dec path -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Get_dec path); - continue k (Tree_mem.get_dec mem ~path) ~mem) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Get_dec path); + continue k (Tree_mem.get_dec treemem ~path) ~treemem) | Set_dec (path, dec) -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Set_dec (path, dec)); - continue k () ~mem:(Tree_mem.set_dec mem ~path dec)) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Set_dec (path, dec)); + continue k () ~treemem:(Tree_mem.set_dec treemem ~path dec)) | Enq_eff (path, clos) -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Enq_eff (path, clos)); - continue k () ~mem:(Tree_mem.enq_eff mem ~path clos)) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Enq_eff (path, clos)); + continue k () ~treemem:(Tree_mem.enq_eff treemem ~path clos)) (* in render *) | Alloc_pt -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem `Alloc_pt; - continue k (Tree_mem.alloc_pt mem) ~mem) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem `Alloc_pt; + continue k (Tree_mem.alloc_pt treemem) ~treemem) | Lookup_ent path -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Lookup_ent path); - continue k (Tree_mem.lookup_ent mem ~path) ~mem) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Lookup_ent path); + continue k (Tree_mem.lookup_ent treemem ~path) ~treemem) | Update_ent (path, ent) -> Some - (fun (k : (a, _) continuation) ~(mem : Tree_mem.t) -> - Logger.mem mem (`Update_ent (path, ent)); - continue k () ~mem:(Tree_mem.update_ent mem ~path ent)) + (fun (k : (a, _) continuation) ~(treemem : Tree_mem.t) -> + Logger.treemem treemem (`Update_ent (path, ent)); + continue k () ~treemem:(Tree_mem.update_ent treemem ~path ent)) | _ -> None); } @@ -155,6 +192,8 @@ let value_exn exn v = let int_of_value_exn v = v |> Value.to_int |> value_exn Type_error let bool_of_value_exn v = v |> Value.to_bool |> value_exn Type_error +let string_of_value_exn v = v |> Value.to_string |> value_exn Type_error +let addr_of_value_exn v = v |> Value.to_addr |> value_exn Type_error let vs_of_value_exn v = v |> Value.to_vs |> value_exn Type_error let vss_of_value_exn v = v |> Value.to_vss |> value_exn Type_error let clos_of_value_exn v = v |> Value.to_clos |> value_exn Type_error @@ -256,6 +295,7 @@ let rec eval : type a. a Expr.t -> value = | Const Unit -> Unit | Const (Bool b) -> Bool b | Const (Int i) -> Int i + | Const (String s) -> String s | Var id -> let env = perform Rd_env in Env.lookup_exn env ~id @@ -361,6 +401,22 @@ let rec eval : type a. a Expr.t -> value = | Minus, Int i1, Int i2 -> Int (i1 - i2) | Times, Int i1, Int i2 -> Int (i1 * i2) | _, _, _ -> raise Type_error) + | Alloc -> + let addr = perform (Alloc_addr Obj.empty) in + Addr addr + | Get { obj; idx } -> + let addr = eval obj |> addr_of_value_exn in + let i = eval idx |> string_of_value_exn in + let obj = perform (Lookup_addr addr) in + Obj.lookup obj ~field:i + | Set { obj; idx; value } -> + let addr = eval obj |> addr_of_value_exn in + let i = eval idx |> string_of_value_exn in + let old_obj = perform (Lookup_addr addr) in + let value = eval value in + let new_obj = Obj.update old_obj ~field:i ~value in + perform (Update_addr (addr, new_obj)); + Unit let rec eval_mult : type a. ?re_render:int -> a Expr.t -> value = fun ?(re_render = 1) expr -> @@ -548,7 +604,7 @@ let step_path (path : Path.t) : bool = has_updates -type run_info = { steps : int; mem : Tree_mem.t } +type run_info = { steps : int; mem : Memory.t; treemem : Tree_mem.t } let run ?(fuel : int option) ?(report : bool = false) (prog : Prog.t) : run_info = @@ -568,10 +624,8 @@ let run ?(fuel : int option) ?(report : bool = false) (prog : Prog.t) : run_info loop (); !cnt in - - let steps, mem = - match_with - (fun () -> try_with driver () (Report_box.log_h report)) - () mem_h ~mem:Tree_mem.empty - in - { steps; mem } + let driver () = match_with driver () mem_h ~mem:Memory.empty in + let driver () = match_with driver () treemem_h ~treemem:Tree_mem.empty in + let driver () = try_with driver () (Report_box.log_h report) in + let (steps, mem), treemem = driver () in + { steps; mem; treemem } diff --git a/lib/js_syntax.ml b/lib/js_syntax.ml index 606b0c0..79b6633 100644 --- a/lib/js_syntax.ml +++ b/lib/js_syntax.ml @@ -1,5 +1,8 @@ open! Core +exception NotImplemented +exception Unreachable + type js_ast = (Loc.t, Loc.t) Flow_ast.Program.t let parse (filename : string) : js_ast * (Loc.t * Parse_error.t) list = @@ -11,3 +14,465 @@ let parse (filename : string) : js_ast * (Loc.t * Parse_error.t) list = contents (Some (File_key.SourceFile filename)) let show (js_ast : js_ast) : string = Flow_ast.Program.show Loc.pp Loc.pp js_ast + +let some_seq e1 e2 = + let open Syntax.Expr in + match (hook_free e1, hook_free e2) with + | Some e1, Some e2 -> Ex (Seq (e1, e2)) + | _, _ -> Ex (Seq (hook_full e1, hook_full e2)) + +let fresh = + let counter = ref 0 in + fun () -> + let n = !counter in + incr counter; + "@@" ^ Int.to_string n +(* convert_pattern: converts js pattern declaration to a list of (name, expr) pairs. + e. g. + JS: let {x, y} = f(); ... + 1. call convert_pattern {x, y} ~base_name:"@@temp1" + -> [("x", @@temp1.x); ("y", @@temp1.y)] + 2. build expression + -> let @@temp1 = f() in + let x = @@temp1.x in + let y = @@temp1.y in ... +*) +[@@ocamlformat "wrap-comments=false"] + +let rec convert_pattern ((_, pattern) : (Loc.t, Loc.t) Flow_ast.Pattern.t) + ~(base_expr : Syntax.Expr.hook_free_t) : + (string * Syntax.Expr.hook_free_t) list = + let open Syntax.Expr in + match pattern with + | Identifier { name = _, { name; _ }; _ } -> [ (name, base_expr) ] + | Object { properties; _ } -> + let base_name = fresh () in + (base_name, base_expr) + :: List.concat_map properties ~f:(function + | Property (_, { key; pattern; default = None; _ }) -> + let key = + match key with + | StringLiteral (_, { value; _ }) -> Const (String value) + | NumberLiteral (_, { value; _ }) -> + Const (Int (Int.of_float value)) + | BigIntLiteral _ -> raise NotImplemented + | Identifier (_, { name; _ }) -> Const (String name) + | Computed _ -> raise NotImplemented + in + convert_pattern pattern + ~base_expr:(Get { obj = Var base_name; idx = key }) + | Property (_, { default = Some _; _ }) -> raise NotImplemented + | RestElement _ -> raise NotImplemented) + | Array { elements; _ } -> + let base_name = fresh () in + (base_name, base_expr) + :: List.concat_mapi elements ~f:(fun i -> function + | Element (_, { argument; default = None }) -> + convert_pattern argument + ~base_expr:(Get { obj = Var base_name; idx = Const (Int i) }) + | Element (_, { default = Some _; _ }) -> raise NotImplemented + | RestElement _ -> raise NotImplemented + | Hole _ -> []) + | Expression _ -> raise Unreachable + +let convert_bop (bop : Flow_ast.Expression.Binary.operator) : Syntax.Expr.bop = + let open Syntax.Expr in + match bop with + | Equal -> raise NotImplemented + | NotEqual -> raise NotImplemented + | StrictEqual -> Eq + | StrictNotEqual -> Ne + | LessThan -> Lt + | LessThanEqual -> Le + | GreaterThan -> Gt + | GreaterThanEqual -> Ge + | LShift -> raise NotImplemented + | RShift -> raise NotImplemented + | RShift3 -> raise NotImplemented + | Plus -> Plus + | Minus -> Minus + | Mult -> Times + | Exp -> raise NotImplemented + | Div -> raise NotImplemented + | Mod -> raise NotImplemented + | BitOr -> raise NotImplemented + | Xor -> raise NotImplemented + | BitAnd -> raise NotImplemented + | In -> raise NotImplemented + | Instanceof -> raise NotImplemented + +let rec convert_stat_list (body : (Loc.t, Loc.t) Flow_ast.Statement.t list) : + Syntax.Expr.hook_free_t = + let open Syntax.Expr in + let rec convert_stat tail ((_, stmt) : (Loc.t, Loc.t) Flow_ast.Statement.t) = + match stmt with + | Block { body; _ } -> + let body = convert_stat_list body in + Seq (body, tail) + | Break _ -> raise NotImplemented + | ClassDeclaration _ -> raise NotImplemented + | ComponentDeclaration _ -> raise NotImplemented + | Continue _ -> raise NotImplemented + | Debugger _ -> tail + | DeclareClass _ | DeclareComponent _ | DeclareEnum _ + | DeclareExportDeclaration _ | DeclareFunction _ | DeclareInterface _ + | DeclareModule _ | DeclareModuleExports _ | DeclareNamespace _ + | DeclareTypeAlias _ | DeclareOpaqueType _ | DeclareVariable _ -> + (* flow statements starting with 'declare' *) + tail + | DoWhile _ -> raise NotImplemented + | Empty _ -> tail + | EnumDeclaration _ -> raise NotImplemented + | ExportDefaultDeclaration { declaration; _ } -> ( + (* TODO: handle export default declaration *) + match declaration with + | Declaration stmt -> + (* delegate to var and function declaration *) + convert_stat tail stmt + | Expression expr -> Seq (convert_expr expr, tail)) + | ExportNamedDeclaration { declaration; _ } -> ( + (* TODO: handle export named declaration, especially those without + declaration *) + match declaration with + | Some stmt -> + (* delegate to var and function declaration *) + convert_stat tail stmt + | None -> tail) + | Expression { expression; _ } -> + let expr = convert_expr expression in + Seq (expr, tail) + | For _ -> raise NotImplemented + | ForIn _ -> raise NotImplemented + | ForOf _ -> raise NotImplemented + | FunctionDeclaration f -> ( + let expr = convert_func f in + match f.id with + | Some (_, { name; _ }) -> Let { id = name; bound = expr; body = tail } + | None -> Seq (expr, tail)) + | If { test; consequent; alternate; _ } -> + let test = convert_expr test in + let consequent = convert_stat (Const Unit) consequent in + let alternate = + match alternate with + | Some (_, { body; _ }) -> convert_stat (Const Unit) body + | None -> Const Unit + in + Seq (Cond { pred = test; con = consequent; alt = alternate }, tail) + | ImportDeclaration _ -> raise NotImplemented + | InterfaceDeclaration _ -> raise NotImplemented + | Labeled _ -> + (* TODO: handle labeled statement *) + tail + | Return _ -> raise NotImplemented + | Switch _ -> raise NotImplemented + | Throw _ -> raise NotImplemented + | Try _ -> raise NotImplemented + | TypeAlias _ | OpaqueType _ -> + (* flow type declaration *) + tail + | VariableDeclaration { declarations; _ } -> + let decls = + List.concat_map declarations ~f:(fun (_, { id; init; _ }) -> + let init = + match init with + | Some expr -> convert_expr expr + | None -> Const Unit + in + convert_pattern id ~base_expr:init) + in + decls |> List.rev + |> List.fold ~init:tail ~f:(fun tail (name, expr) -> + Let { id = name; bound = expr; body = tail }) + | While _ -> raise NotImplemented + | With _ -> raise NotImplemented + in + List.rev body |> List.fold ~init:(Const Unit) ~f:convert_stat + +and convert_func ({ params; body; _ } : (Loc.t, Loc.t) Flow_ast.Function.t) : + Syntax.Expr.hook_free_t = + (* TODO: handle recursive binding *) + let open Syntax.Expr in + let param = + match params with + | _, { params = [ (_, { argument; default = None }) ]; _ } -> argument + | _ -> raise NotImplemented (* non-single or optional parameter *) + in + let param_name, param_bindings = + match param with + | _, Identifier { name = _, { name; _ }; _ } -> (name, []) + | _ -> + let param_name = fresh () in + let param_bindings = + convert_pattern param ~base_expr:(Var param_name) + in + (param_name, param_bindings) + in + let body = + match body with + | BodyBlock (_, { body; _ }) -> convert_stat_list body + | BodyExpression expr -> convert_expr expr + in + let body = + List.rev param_bindings + |> List.fold ~init:body ~f:(fun last_expr (name, expr) -> + Let { id = name; bound = expr; body = last_expr }) + in + Fn { param = param_name; body } + +and convert_call (callee : Syntax.Expr.hook_free_t) + ((_, { arguments; _ }) : (Loc.t, Loc.t) Flow_ast.Expression.ArgList.t) : + Syntax.Expr.hook_free_t = + let argument = + match arguments with + | [ Expression expr ] -> convert_expr expr + | _ -> raise NotImplemented (* non-single or spread arguments *) + in + App { fn = callee; arg = argument } + +and convert_member (obj : Syntax.Expr.hook_free_t) + (property : (Loc.t, Loc.t) Flow_ast.Expression.Member.property) : + Syntax.Expr.hook_free_t = + let open Syntax.Expr in + match property with + | PropertyIdentifier (_, { name; _ }) -> + Get { obj; idx = Const (String name) } + | PropertyPrivateName _ -> raise NotImplemented + | PropertyExpression expr -> Get { obj; idx = convert_expr expr } + +and convert_expr ((_, expr) : (Loc.t, Loc.t) Flow_ast.Expression.t) : + Syntax.Expr.hook_free_t = + let open Syntax.Expr in + match expr with + | Array { elements; _ } -> + (* [e0, e1] -> (let arr = {} in arr[0] := e0; arr[1] := e1; arr) *) + let arr = fresh () in + let asgns = + List.mapi elements ~f:(fun i element -> + match element with + | Expression expr -> + let elem = convert_expr expr in + Set { obj = Var arr; idx = Const (Int i); value = elem } + | _ -> raise NotImplemented) + in + let asgns = + asgns |> List.rev + |> List.fold ~init:(Var arr) ~f:(fun last_expr asgn -> + Seq (asgn, last_expr)) + in + Let { id = arr; bound = Alloc; body = asgns } + | Function f | ArrowFunction f -> convert_func f + | AsConstExpression { expression; _ } -> convert_expr expression + | AsExpression { expression; _ } -> convert_expr expression + | Assignment _ -> raise NotImplemented + | Binary { operator; left; right; _ } -> + let left = convert_expr left in + let right = convert_expr right in + Bop { op = convert_bop operator; left; right } + | Call { callee; arguments; _ } -> + let callee = convert_expr callee in + convert_call callee arguments + | Class _ -> raise NotImplemented + | Conditional { test; consequent; alternate; _ } -> + let test = convert_expr test in + let consequent = convert_expr consequent in + let alternate = convert_expr alternate in + Cond { pred = test; con = consequent; alt = alternate } + | Identifier (_, { name; _ }) -> Var name + | Import _ -> raise NotImplemented + | JSXElement { opening_element = _, { name; _ }; _ } -> + (* TODO: handle opening and attributes and children *) + let name = + match name with + | Identifier (_, { name; _ }) -> name + | _ -> raise NotImplemented (* non-identifier JSX element name *) + in + View [ App { fn = Var name; arg = Const Unit } ] + | JSXFragment _ -> + (* TODO *) + View [ Const Unit ] + | StringLiteral _ -> raise NotImplemented + | BooleanLiteral { value; _ } -> Const (Bool value) + | NullLiteral _ -> + (* TODO: discriminate null and undefined *) + Const Unit + | NumberLiteral { value; _ } -> + (* TODO: handle non-int value *) + Const (Int (Int.of_float value)) + | BigIntLiteral _ -> raise NotImplemented + | RegExpLiteral _ -> raise NotImplemented + | ModuleRefLiteral _ -> raise NotImplemented + | Logical { operator; left; right; _ } -> ( + let left = convert_expr left in + let right = convert_expr right in + match operator with + | Or -> + (* a || b --> let a' = a in (if a' then a' else b) *) + let name = fresh () in + Let + { + id = name; + bound = left; + body = Cond { pred = Var name; con = Var name; alt = right }; + } + | And -> + (* a && b --> let a' = a in (if a' then b else a') *) + let name = fresh () in + Let + { + id = name; + bound = left; + body = Cond { pred = Var name; con = right; alt = Var name }; + } + | NullishCoalesce -> + (* a ?? b --> let a' = a in (if a' = () then b else a') *) + let name = fresh () in + Let + { + id = name; + bound = left; + body = + Cond + { + pred = Bop { op = Eq; left = Var name; right = Const Unit }; + con = right; + alt = Var name; + }; + }) + | Member { _object; property; _ } -> + let obj = convert_expr _object in + convert_member obj property + | MetaProperty _ -> raise NotImplemented + | New _ -> raise NotImplemented + | Object { properties; _ } -> + (* { a: x, b: y } --> (let obj = {} in obj.a := x; obj.b := y; obj) *) + let obj = fresh () in + let convert_key_to_set prop_value = function + | Flow_ast.Expression.Object.Property.StringLiteral (_, { value; _ }) -> + Set + { obj = Var obj; idx = Const (String value); value = prop_value } + | NumberLiteral (_, { value; _ }) -> + Set + { + obj = Var obj; + idx = Const (Int (Int.of_float value)); + value = prop_value; + } + | BigIntLiteral _ -> raise NotImplemented + | Identifier (_, { name; _ }) -> + Set { obj = Var obj; idx = Const (String name); value = prop_value } + | PrivateName _ -> raise NotImplemented + | Computed _ -> raise NotImplemented + in + let asgns = + List.map properties ~f:(function + | Property (_, Init { key; value; _ }) -> + let value = convert_expr value in + convert_key_to_set value key + | Property (_, Method { key; value = _, value; _ }) -> + let value = convert_func value in + convert_key_to_set value key + | Property (_, Get _) -> raise NotImplemented + | Property (_, Set _) -> raise NotImplemented + | SpreadProperty _ -> raise NotImplemented) + in + let body = + asgns |> List.rev + |> List.fold ~init:(Var obj) ~f:(fun last_expr asgn -> + Seq (asgn, last_expr)) + in + Let { id = obj; bound = Alloc; body } + | OptionalCall { optional; call = { callee; arguments; _ }; _ } -> + (* f?.(x) --> let f' = f in (if f' = () then () else (f' x)) *) + let callee = convert_expr callee in + let name = fresh () in + if optional then + Let + { + id = name; + bound = callee; + body = + Cond + { + pred = Bop { op = Eq; left = Var name; right = Const Unit }; + con = Const Unit; + alt = convert_call (Var name) arguments; + }; + } + else convert_call callee arguments + | OptionalMember { optional; member; _ } -> + (* obj?.x --> let obj' = obj in (if obj' = () then () else obj'.x) *) + let obj = convert_expr member._object in + if optional then + let name = fresh () in + Let + { + id = name; + bound = obj; + body = + Cond + { + pred = Bop { op = Eq; left = Var name; right = Const Unit }; + con = Const Unit; + alt = convert_member (Var name) member.property; + }; + } + else convert_member obj member.property + | Sequence { expressions; _ } -> + List.fold expressions ~init:(Const Unit) ~f:(fun left right -> + Seq (left, convert_expr right)) + | Super _ -> raise NotImplemented + | TaggedTemplate _ -> raise NotImplemented + | TemplateLiteral _ -> raise NotImplemented + | This _ -> raise NotImplemented + | TypeCast { expression; _ } -> convert_expr expression + | TSSatisfies { expression; _ } -> convert_expr expression + | Unary { operator; argument; _ } -> ( + let argument = convert_expr argument in + let open Syntax.Expr in + match operator with + | Minus -> Uop { op = Uminus; arg = argument } + | Plus -> Uop { op = Uplus; arg = argument } + | Not -> Uop { op = Not; arg = argument } + | BitNot -> raise NotImplemented + | Typeof -> raise NotImplemented + | Void -> Seq (argument, Const Unit) + | Delete -> raise NotImplemented + | Await -> raise NotImplemented) + | Update _ -> raise NotImplemented + | Yield _ -> raise NotImplemented + +let convert (js_ast : js_ast) : Syntax.Prog.t = + let _, { Flow_ast.Program.statements; _ } = js_ast in + let comps, stats = + List.partition_map statements ~f:(fun stmt -> + let _, stmt' = stmt in + match stmt' with + (* (* component declaration *) | ComponentDeclaration { id = _, { name; + _ }; params = _, params; body = _, { body; _ }; _; } -> First { name; + param = "@@param"; Syntax.Prog.body = body |> convert_stat_list |> + Syntax.Expr.hook_full; } (* function declaration, name starting with + uppercase, with single parameter *) | FunctionDeclaration { id = Some + (_, { name; _ }); params = ( _, { params = [ (_, { argument; default + = None }) ]; this_ = None; rest = None; _; } ); body; _; } when + String.get name 0 |> Char.is_uppercase -> let param_name = fresh () + in let param_bindings = convert_pattern argument + ~base_name:param_name in (* js function body *) let body = match body + with | BodyBlock (_, { body; _ }) -> convert_stat_list body | + BodyExpression expr -> convert_expr expr in (* function body with + parameter destructuring *) let body = List.rev param_bindings |> + List.fold ~init:body ~f:(fun last_expr (name, expr) -> Ex (Let { id = + name; bound = expr; body = last_expr |> Syntax.Expr.hook_full; })) in + First { name; param = param_name; Syntax.Prog.body = body |> + Syntax.Expr.hook_full; } (* single variable declaration with function + expression *) | VariableDeclaration { declarations = [ ( _, { id = _, + Identifier { name = _, { name; _ }; _ }; init = Some (_, Function { + body; _ }); } ); ]; _; } -> let body = match body with | BodyBlock + (_, { body; _ }) -> convert_stat_list body | BodyExpression expr -> + convert_expr expr in First { name; body = body |> + Syntax.Expr.hook_full } *) + | _ -> Second stmt) + in + let last_expr = stats |> convert_stat_list in + List.rev comps + |> List.fold ~init:(Syntax.Prog.Expr last_expr) ~f:(fun last_expr comp -> + Syntax.Prog.Comp (comp, last_expr)) diff --git a/lib/lexer.mll b/lib/lexer.mll index 4668bb2..e706b28 100644 --- a/lib/lexer.mll +++ b/lib/lexer.mll @@ -23,8 +23,23 @@ let keywords = ("useEffect", EFF); ]; tbl + +let unescape_string s = + let rec loop s = + match s |> Seq.uncons with + | Some ('\\', rest) -> + (match Seq.uncons rest with + | Some ('\\', rest) -> "\\" ^ loop rest + | Some ('"', rest) -> "\"" ^ loop rest + | _ -> raise (SyntaxError "Invalid escape sequence")) + | Some (c, rest) -> String.make 1 c ^ loop rest + | None -> "" + in + loop (String.to_seq s) } +let escape_seq = "\\\\" | "\\\"" +let ordinary_char = [^ '\\' '"' '\r' '\n'] let blank = [' ' '\t']+ let newline = '\r' | '\n' | "\r\n" let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_' '\'']* @@ -33,6 +48,7 @@ let digit = ['0'-'9'] let int = digit+ let pow = ['e' 'E'] ['+' '-']? int let real = ((int '.'? | (digit* '.' int))) pow? +let str = '"' (escape_seq | ordinary_char)* '"' rule read = parse @@ -41,6 +57,10 @@ rule read = | "()" { UNIT } | int as n { INT (int_of_string n) } | id as s { match Hashtbl.find_opt keywords s with Some s -> s | None -> ID s } + | str as s { STRING (String.sub s 1 (String.length s - 2) |> unescape_string) } + | "{}" { RECORD } + | '.' { DOT } + | ":=" { ASSIGN } | '#' { comment lexbuf } | "->" { RARROW } | '=' { EQ } diff --git a/lib/logger.ml b/lib/logger.ml index d091d70..0d7b02b 100644 --- a/lib/logger.ml +++ b/lib/logger.ml @@ -31,44 +31,70 @@ let env env = function let mem mem = function | `Ret -> Logs.debug (fun m -> - m "mem_h Ret [mem: %a]" Sexp.pp_hum (Tree_mem.sexp_of_t mem)) + m "mem_h Ret [mem: %a]" Sexp.pp_hum (Memory.sexp_of_t mem)) + | `Lookup_addr addr -> + Logs.debug (fun m -> + m "mem_h Lookup_addr [mem: %a, addr: %a]" Sexp.pp_hum + (Memory.sexp_of_t mem) Sexp.pp_hum (Addr.sexp_of_t addr)) + | `Update_addr (addr, obj) -> + Logs.debug (fun m -> + m "mem_h Update_addr [mem: %a, addr: %a, obj: %a]" Sexp.pp_hum + (Memory.sexp_of_t mem) Sexp.pp_hum (Addr.sexp_of_t addr) Sexp.pp_hum + (Obj.sexp_of_t obj)) + | `Alloc_addr -> + Logs.debug (fun m -> + m "mem_h Alloc_addr [mem: %a]" Sexp.pp_hum (Memory.sexp_of_t mem)) + +let treemem treemem = function + | `Ret -> + Logs.debug (fun m -> + m "treemem_h Ret [treemem: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem)) | `Lookup_st (path, label) -> Logs.debug (fun m -> - m "mem_h Lookup_st [mem: %a, path: %a, label: %a]" Sexp.pp_hum - (Tree_mem.sexp_of_t mem) Sexp.pp_hum (Path.sexp_of_t path) - Sexp.pp_hum (Label.sexp_of_t label)) + m "treemem_h Lookup_st [treemem: %a, path: %a, label: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path) Sexp.pp_hum + (Label.sexp_of_t label)) | `Update_st (path, label, (v, q)) -> Logs.debug (fun m -> - m "mem_h Update_st [mem: %a, path: %a, label: %a, v: %a, q: %a]" - Sexp.pp_hum (Tree_mem.sexp_of_t mem) Sexp.pp_hum - (Path.sexp_of_t path) Sexp.pp_hum (Label.sexp_of_t label) - Sexp.pp_hum (sexp_of_value v) Sexp.pp_hum (Job_q.sexp_of_t q)) + m + "treemem_h Update_st [treemem: %a, path: %a, label: %a, v: %a, q: \ + %a]" + Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path) Sexp.pp_hum + (Label.sexp_of_t label) Sexp.pp_hum (sexp_of_value v) Sexp.pp_hum + (Job_q.sexp_of_t q)) | `Get_dec path -> Logs.debug (fun m -> - m "mem_h Get_dec [mem: %a, path: %a]" Sexp.pp_hum - (Tree_mem.sexp_of_t mem) Sexp.pp_hum (Path.sexp_of_t path)) + m "treemem_h Get_dec [treemem: %a, path: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path)) | `Set_dec (path, dec) -> Logs.debug (fun m -> - m "mem_h Set_dec [mem: %a, path: %a, dec: %a]" Sexp.pp_hum - (Tree_mem.sexp_of_t mem) Sexp.pp_hum (Path.sexp_of_t path) - Sexp.pp_hum (sexp_of_decision dec)) + m "treemem_h Set_dec [treemem: %a, path: %a, dec: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path) Sexp.pp_hum (sexp_of_decision dec)) | `Enq_eff (path, clos) -> Logs.debug (fun m -> - m "mem_h Enq_eff [mem: %a, path: %a, clos: %a]" Sexp.pp_hum - (Tree_mem.sexp_of_t mem) Sexp.pp_hum (Path.sexp_of_t path) - Sexp.pp_hum (sexp_of_clos clos)) + m "treemem_h Enq_eff [treemem: %a, path: %a, clos: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path) Sexp.pp_hum (sexp_of_clos clos)) | `Alloc_pt -> Logs.debug (fun m -> - m "mem_h Alloc_pt [mem: %a]" Sexp.pp_hum (Tree_mem.sexp_of_t mem)) + m "treemem_h Alloc_pt [treemem: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem)) | `Lookup_ent path -> Logs.debug (fun m -> - m "mem_h Lookup_ent [mem: %a, path: %a]" Sexp.pp_hum - (Tree_mem.sexp_of_t mem) Sexp.pp_hum (Path.sexp_of_t path)) + m "treemem_h Lookup_ent [treemem: %a, path: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path)) | `Update_ent (path, ent) -> Logs.debug (fun m -> - m "mem_h Update_ent [mem: %a, path: %a, ent: %a]" Sexp.pp_hum - (Tree_mem.sexp_of_t mem) Sexp.pp_hum (Path.sexp_of_t path) - Sexp.pp_hum (sexp_of_entry ent)) + m "treemem_h Update_ent [treemem: %a, path: %a, ent: %a]" Sexp.pp_hum + (Tree_mem.sexp_of_t treemem) + Sexp.pp_hum (Path.sexp_of_t path) Sexp.pp_hum (sexp_of_entry ent)) let eval expr = Logs.debug (fun m -> m "eval %a" Sexp.pp_hum (Expr.sexp_of_t expr)) diff --git a/lib/parser.mly b/lib/parser.mly index ca1f172..efe821c 100644 --- a/lib/parser.mly +++ b/lib/parser.mly @@ -17,6 +17,8 @@ and label_stts_expr label = function %token UNIT TRUE FALSE %token INT %token ID +%token STRING +%token RECORD DOT ASSIGN %token VIEW %token FUN LET STT IN EFF %token IF THEN ELSE @@ -30,6 +32,7 @@ and label_stts_expr label = function %nonassoc RARROW %nonassoc IN %right SEMI +%nonassoc ASSIGN %nonassoc EFF %nonassoc THEN /* below ELSE (if ... then ...) */ %nonassoc ELSE /* (if ... then ... else ...) */ @@ -76,6 +79,10 @@ expr_: | op = uop; expr_ = expr_ %prec prec_unary { Ex (Uop { op; arg = hook_free_exn expr_ }) } | left = expr_; op = bop; right = expr_ { Ex (Bop { op; left = hook_free_exn left; right = hook_free_exn right }) } + | RECORD { Ex (Alloc) } + | obj = expr_; LBRACK; index = expr_; RBRACK { Ex (Get { obj = hook_free_exn obj; idx = hook_free_exn index }) } + | obj = expr_; LBRACK; index = expr_; RBRACK; ASSIGN; value = expr_ + { Ex (Set { obj = hook_free_exn obj; idx = hook_free_exn index; value = hook_free_exn value }) } %inline uop: | NOT { Not } | PLUS { Uplus } @@ -100,6 +107,7 @@ atom: | TRUE { Ex (Const (Bool true)) } | FALSE { Ex (Const (Bool false)) } | n = INT { Ex (Const (Int n)) } + | s = STRING { Ex (Const (String s)) } | var = var { Ex (Var var) } | LPAREN; e = expr_; RPAREN { e } var: diff --git a/lib/syntax.ml b/lib/syntax.ml index 84e293d..1fffd33 100644 --- a/lib/syntax.ml +++ b/lib/syntax.ml @@ -11,7 +11,7 @@ module Label = Int module Expr = struct type hook_free = private Hook_free type hook_full = private Hook_full - type const = Unit | Bool of bool | Int of int + type const = Unit | Bool of bool | Int of int | String of string type uop = Not | Uplus | Uminus type bop = Eq | Lt | Gt | Ne | Le | Ge | And | Or | Plus | Minus | Times @@ -35,6 +35,9 @@ module Expr = struct | Seq : 'a t * 'a t -> 'a t | Uop : { op : uop; arg : hook_free t } -> _ t | Bop : { op : bop; left : hook_free t; right : hook_free t } -> _ t + | Alloc : _ t + | Get : { obj : hook_free t; idx : hook_free t } -> _ t + | Set : { obj : hook_free t; idx : hook_free t; value : hook_free t } -> _ t type hook_free_t = hook_free t type hook_full_t = hook_full t @@ -59,7 +62,10 @@ module Expr = struct | (Fn _ as e) | (App _ as e) | (Bop _ as e) - | (Uop _ as e) -> + | (Uop _ as e) + | (Alloc as e) + | (Get _ as e) + | (Set _ as e) -> Some e let hook_free_exn e = Option.value_exn (hook_free e) @@ -83,7 +89,10 @@ module Expr = struct | (Stt _ as e) | (Eff _ as e) | (Uop _ as e) - | (Bop _ as e) -> + | (Bop _ as e) + | (Alloc as e) + | (Get _ as e) + | (Set _ as e) -> e let string_of_uop = function Not -> "not" | Uplus -> "+" | Uminus -> "-" @@ -107,6 +116,7 @@ module Expr = struct | Const Unit -> a "()" | Const (Bool b) -> Bool.sexp_of_t b | Const (Int i) -> Int.sexp_of_t i + | Const (String s) -> String.sexp_of_t s | Var id -> Id.sexp_of_t id | View es -> l (a "View" :: List.map ~f:sexp_of_t es) | Cond { pred; con; alt } -> @@ -130,6 +140,10 @@ module Expr = struct | Uop { op; arg } -> l [ a "Uop"; a (string_of_uop op); sexp_of_t arg ] | Bop { op; left; right } -> l [ a "Bop"; a (string_of_bop op); sexp_of_t left; sexp_of_t right ] + | Alloc -> a "Alloc" + | Get { obj; idx } -> l [ a "Get"; sexp_of_t obj; sexp_of_t idx ] + | Set { obj; idx; value } -> + l [ a "Set"; sexp_of_t obj; sexp_of_t idx; sexp_of_t value ] let sexp_of_hook_free_t = sexp_of_t let sexp_of_hook_full_t = sexp_of_t diff --git a/samples/record.ml b/samples/record.ml new file mode 100644 index 0000000..2004a7b --- /dev/null +++ b/samples/record.ml @@ -0,0 +1,6 @@ +let C x = + stt s, setS = (let r = {} in r.x := 42; r) in + eff (if s.x <= 45 then setS (fun s -> (let r = {} in r.x := s.x + 1; r))); + view [()] +;; +view [C ()] diff --git a/samples/simple.tsx b/samples/simple.tsx new file mode 100644 index 0000000..d70a300 --- /dev/null +++ b/samples/simple.tsx @@ -0,0 +1,3 @@ +const x = 3; +const f = (z) => z + x; +f(x) diff --git a/test/test_react_trace.ml b/test/test_react_trace.ml index eabf0c3..101b449 100644 --- a/test/test_react_trace.ml +++ b/test/test_react_trace.ml @@ -12,6 +12,189 @@ let parse_expr s = let lexbuf = Lexing.from_string s in Parser.expr Lexer.read lexbuf +let parse_js s = + Parser_flow.program_file ~fail:false + ~parse_options: + (Some { Parser_env.default_parse_options with components = true }) + s None + +let rec alpha_conv_expr_blind : + type a. (string -> string) -> a Syntax.Expr.t -> a Syntax.Expr.t = + let open Syntax.Expr in + fun bindings -> function + | Const c -> Const c + | Var x -> Var (bindings x) + | View es -> View (List.map es ~f:(alpha_conv_expr_blind bindings)) + | Cond { pred; con; alt } -> + Cond + { + pred = alpha_conv_expr_blind bindings pred; + con = alpha_conv_expr_blind bindings con; + alt = alpha_conv_expr_blind bindings alt; + } + | Fn { param; body } -> + Fn { param; body = alpha_conv_expr_blind bindings body } + | App { fn; arg } -> + App + { + fn = alpha_conv_expr_blind bindings fn; + arg = alpha_conv_expr_blind bindings arg; + } + | Let { id; bound; body } -> + Let + { + id = bindings id; + bound = alpha_conv_expr_blind bindings bound; + body = alpha_conv_expr_blind bindings body; + } + | Stt { stt; set; init; body; label } -> + Stt + { + stt = bindings stt; + set = bindings set; + init = alpha_conv_expr_blind bindings init; + body = alpha_conv_expr_blind bindings body; + label = bindings (Int.to_string label) |> Int.of_string; + } + | Eff e -> Eff (alpha_conv_expr_blind bindings e) + | Seq (e1, e2) -> + Seq + (alpha_conv_expr_blind bindings e1, alpha_conv_expr_blind bindings e2) + | Bop { left; right; op } -> + Bop + { + left = alpha_conv_expr_blind bindings left; + right = alpha_conv_expr_blind bindings right; + op; + } + | Uop { arg; op } -> Uop { arg = alpha_conv_expr_blind bindings arg; op } + | Alloc -> Alloc + | Set { obj; idx; value } -> + Set + { + obj = alpha_conv_expr_blind bindings obj; + idx = alpha_conv_expr_blind bindings idx; + value = alpha_conv_expr_blind bindings value; + } + | Get { obj; idx } -> + Get + { + obj = alpha_conv_expr_blind bindings obj; + idx = alpha_conv_expr_blind bindings idx; + } + +let rec alpha_conv_expr : + type a. + (string -> string) -> a Syntax.Expr.t -> a Syntax.Expr.t -> a Syntax.Expr.t + = + let open Syntax.Expr in + fun bindings base src -> + match (base, src) with + | Const _, Const _ -> src + | Var _, Var x' -> Var (bindings x') + | View es, View es' -> + let len = List.length es in + let len' = List.length es' in + if len < len' then + View + (List.map2_exn es (List.take es' len) ~f:(alpha_conv_expr bindings)) + else if len > len' then + View + (List.map2_exn (List.take es len') es' ~f:(alpha_conv_expr bindings)) + else View (List.map2_exn es es' ~f:(alpha_conv_expr bindings)) + | Cond { pred; con; alt }, Cond { pred = pred'; con = con'; alt = alt' } -> + Cond + { + pred = alpha_conv_expr bindings pred pred'; + con = alpha_conv_expr bindings con con'; + alt = alpha_conv_expr bindings alt alt'; + } + | Fn { param; body }, Fn { param = param'; body = body' } -> + let bindings' x = if String.(x = param') then param else bindings x in + Fn { param; body = alpha_conv_expr bindings' body body' } + | App { fn; arg }, App { fn = fn'; arg = arg' } -> + App + { + fn = alpha_conv_expr bindings fn fn'; + arg = alpha_conv_expr bindings arg arg'; + } + | Let { id; bound; body }, Let { id = id'; bound = bound'; body = body' } -> + let bindings' x = if String.(x = id') then id else bindings x in + Let + { + id; + bound = alpha_conv_expr bindings bound bound'; + body = alpha_conv_expr bindings' body body'; + } + | ( Stt { stt; set; init; body; label }, + Stt + { stt = stt'; set = set'; init = init'; body = body'; label = label' } + ) -> + let bindings' x = + if String.(x = stt') then stt + else if String.(x = set') then set + else if String.(x = Int.to_string label') then Int.to_string label + else bindings x + in + Stt + { + stt; + set; + init = alpha_conv_expr bindings init init'; + body = alpha_conv_expr bindings' body body'; + label; + } + | Eff e, Eff e' -> Eff (alpha_conv_expr bindings e e') + | Seq (e1, e2), Seq (e1', e2') -> + Seq (alpha_conv_expr bindings e1 e1', alpha_conv_expr bindings e2 e2') + | Bop { left; right; _ }, Bop { left = left'; right = right'; op = op' } -> + Bop + { + left = alpha_conv_expr bindings left left'; + right = alpha_conv_expr bindings right right'; + op = op'; + } + | Uop { arg; _ }, Uop { arg = arg'; op = op' } -> + Uop { arg = alpha_conv_expr bindings arg arg'; op = op' } + | Alloc, Alloc -> Alloc + | Set { obj; idx; value }, Set { obj = obj'; idx = idx'; value = value' } -> + Set + { + obj = alpha_conv_expr bindings obj obj'; + idx = alpha_conv_expr bindings idx idx'; + value = alpha_conv_expr bindings value value'; + } + | Get { obj; idx }, Get { obj = obj'; idx = idx' } -> + Get + { + obj = alpha_conv_expr bindings obj obj'; + idx = alpha_conv_expr bindings idx idx'; + } + | _, _ -> alpha_conv_expr_blind bindings src + +let rec alpha_conv_prog_blind bindings src = + let open Syntax.Prog in + match src with + | Expr e -> Expr (alpha_conv_expr_blind bindings e) + | Comp ({ name; param; body }, e) -> + let bindings' x = if String.(x = name) then name else bindings x in + Comp + ( { name; param; body = alpha_conv_expr_blind bindings' body }, + alpha_conv_prog_blind bindings' e ) + +let rec alpha_conv_prog bindings base src = + let open Syntax.Prog in + match (base, src) with + | Expr e, Expr e' -> Expr (alpha_conv_expr bindings e e') + | ( Comp ({ name; param; body }, e), + Comp ({ name = name'; param = param'; body = body' }, e') ) -> + let body_bindings x = if String.(x = param') then param else bindings x in + let e_bindings x = if String.(x = name') then name else bindings x in + Comp + ( { name; param; body = alpha_conv_expr body_bindings body body' }, + alpha_conv_prog e_bindings e e' ) + | _, _ -> alpha_conv_prog_blind bindings src + let parse_unit () = let open Syntax in let (Ex expr) = parse_expr "()" in @@ -236,6 +419,212 @@ let parse_op () = right = Const (Bool true); })) +let parse_obj () = + let open Syntax in + let (Ex expr) = parse_expr {|let x = {} in x["y"] := 3; x["y"]|} in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Expr.sexp_of_t expr) + ~expected: + Expr.( + sexp_of_t + (Let + { + id = "x"; + bound = Alloc; + body = + Seq + ( Set + { + obj = Var "x"; + idx = Const (String "y"); + value = Const (Int 3); + }, + Get { obj = Var "x"; idx = Const (String "y") } ); + })) + +let parse_indexing () = + let open Syntax in + let (Ex expr) = parse_expr "let x = {} in x[2+2] := 1; x[4] + 1" in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Expr.sexp_of_t expr) + ~expected: + Expr.( + sexp_of_t + (Let + { + id = "x"; + bound = Alloc; + body = + Seq + ( Set + { + obj = Var "x"; + idx = + Bop + { + op = Plus; + left = Const (Int 2); + right = Const (Int 2); + }; + value = Const (Int 1); + }, + Bop + { + op = Plus; + left = Get { obj = Var "x"; idx = Const (Int 4) }; + right = Const (Int 1); + } ); + })) + +let parse_string () = + let open Syntax in + let (Ex expr) = parse_expr {|"hello world"; "\"\\ hello"|} in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse string" ~actual:(Expr.sexp_of_t expr) + ~expected: + Expr.( + sexp_of_t + (Seq (Const (String "hello world"), Const (String "\"\\ hello")))) + +let js_var () = + let open Syntax in + let js, _ = parse_js "x" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected:(parse_prog "x; ()" |> Prog.sexp_of_t) + +let js_literal () = + let open Syntax in + let js, _ = parse_js "42; true; null" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected:(parse_prog "42; true; (); ()" |> Prog.sexp_of_t) + +let js_jsx () = + let open Syntax in + let js, _ = parse_js "<>; " in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected:(parse_prog "view [()]; view [Comp ()]; ()" |> Prog.sexp_of_t) + +let js_op () = + let open Syntax in + let js, _ = + parse_js + {| +a || b; a && b; a ?? b; +a === b; a !== b; a < b; a <= b; a > b; a >= b; +a + b; a - b; a * b; +void a; -a; +a; !a|} + in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected: + (parse_prog + {| +(let a' = a in if a' then a' else b); +(let a'' = a in if a'' then b else a''); +(let a''' = a in if a''' = () then b else a'''); +a = b; a <> b; a < b; a <= b; a > b; a >= b; +a + b; a - b; a * b; +(a; ()); -a; +a; not a; ()|} + |> alpha_conv_prog Fun.id prog + |> Prog.sexp_of_t) + +let js_optcall () = + let open Syntax in + let js, _ = parse_js "a?.(b)" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected: + (parse_prog "(let a' = a in if a' = () then () else a'(b)); ()" + |> alpha_conv_prog Fun.id prog + |> Prog.sexp_of_t) + +let js_cond () = + let open Syntax in + let js, _ = parse_js "if (a) b; else c;" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected:(parse_prog "if a then (b; ()) else (c; ()); ()" |> Prog.sexp_of_t) + +let js_pattern_id () = + let open Syntax in + let js, _ = parse_js "let p = q;" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected:(parse_prog {|let p = q in ()|} |> Prog.sexp_of_t) + +let js_pattern_object () = + let open Syntax in + let js, _ = parse_js "let {x, y} = q;" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected: + (parse_prog {| +let q' = q in +let x = q'["x"] in +let y = q'["y"] in +()|} + |> alpha_conv_prog Fun.id prog + |> Prog.sexp_of_t) + +let js_pattern_array () = + let open Syntax in + let js, _ = parse_js "let [x, y, , z] = q;" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected: + (parse_prog + {| +let q' = q in + let x = q'[0] in + let y = q'[1] in + let z = q'[3] in +()|} + |> alpha_conv_prog Fun.id prog + |> Prog.sexp_of_t) + +let js_pattern_nested () = + let open Syntax in + let js, _ = parse_js "let {x: {y: [a, b]}} = q;" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected: + (parse_prog + {| +let q' = q in +let x = q'["x"] in +let y = x["y"] in +let a = y[0] in +let b = y[1] in +()|} + |> alpha_conv_prog Fun.id prog + |> Prog.sexp_of_t) + +let js_object () = + let open Syntax in + let js, _ = parse_js "let p = {y: 1, z: 2, 3: 4}; p.y; p[1+2]" in + let prog = Js_syntax.convert js in + Alcotest.(check' (of_pp Sexp.pp_hum)) + ~msg:"parse obj" ~actual:(Prog.sexp_of_t prog) + ~expected: + (parse_prog + {| +let p = (let obj = {} in obj["y"] := 1; obj["z"] := 2; obj[3] := 4; obj) in p["y"]; p[1+2]; ()|} + |> alpha_conv_prog Fun.id prog + |> Prog.sexp_of_t) + let no_side_effect () = let prog = parse_prog @@ -508,6 +897,36 @@ view [D ()] let { Interp.steps; _ } = Interp.run ~fuel prog in Alcotest.(check' int) ~msg:"step three times" ~expected:3 ~actual:steps +let set_in_effect_guarded_step_n_times_with_obj () = + let prog = + parse_prog + {| +let C x = + let (s, setS) = useState (let r = {} in r["x"] := 42; r) in + useEffect (if s["x"] <= 45 then setS (fun s -> (let r = {} in r["x"] := s["x"] + 1; r))); + view [()] +;; +view [C ()] +|} + in + let { Interp.steps; _ } = Interp.run ~fuel prog in + Alcotest.(check' int) ~msg:"step five times" ~expected:5 ~actual:steps + +let updating_obj_without_set_does_not_rerender () = + let prog = + parse_prog + {| +let C x = + let (s, setS) = useState (let r = {} in r["x"] := 42; r) in + useEffect (s["x"] := 43); + view [()] +;; +view [C ()] +|} + in + let { Interp.steps; _ } = Interp.run ~fuel prog in + Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps + let () = let open Alcotest in run "Interpreter" @@ -529,6 +948,23 @@ let () = test_case "eff" `Quick parse_eff; test_case "seq" `Quick parse_seq; test_case "op" `Quick parse_op; + test_case "obj" `Quick parse_obj; + test_case "indexing" `Quick parse_indexing; + test_case "string" `Quick parse_string; + ] ); + ( "convert", + [ + test_case "var" `Quick js_var; + test_case "literal" `Quick js_literal; + test_case "jsx" `Quick js_jsx; + test_case "binop" `Quick js_op; + test_case "optcall" `Quick js_optcall; + test_case "cond" `Quick js_cond; + test_case "id pattern" `Quick js_pattern_id; + test_case "object pattern" `Quick js_pattern_object; + test_case "array pattern" `Quick js_pattern_array; + test_case "nested pattern" `Quick js_pattern_nested; + test_case "object" `Quick js_object; ] ); ( "steps", [ @@ -561,5 +997,9 @@ let () = set_in_removed_child_step_two_times; test_case "Same child gets persisted" `Quick state_persists_in_child; test_case "New child steps again" `Quick new_child_steps_again; + test_case "Guarded set with obj in effect should step five times" + `Quick set_in_effect_guarded_step_n_times_with_obj; + test_case "Updating object without set should step one time" `Quick + updating_obj_without_set_does_not_rerender; ] ); ]