From d95b99ae137c72ad6a15e27a4db5175d5d39323a Mon Sep 17 00:00:00 2001 From: Jay Lee Date: Thu, 28 Nov 2024 19:56:21 +0900 Subject: [PATCH] :sparkles: Add code location info --- bin/native/main.ml | 10 +- lib/interp.ml | 2 +- lib/js_syntax.ml | 785 ++++++++-------- lib/lexer.mll | 1 + lib/parser.mly | 81 +- lib/syntax.ml | 79 +- test/test_react_trace.ml | 1918 ++++++++++++++++++-------------------- 7 files changed, 1421 insertions(+), 1455 deletions(-) diff --git a/bin/native/main.ml b/bin/native/main.ml index 718a4f6..a8ece4f 100644 --- a/bin/native/main.ml +++ b/bin/native/main.ml @@ -58,11 +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 ( - let js_syntax, _ = Js_syntax.parse !filename in - 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 if !opt_parse_js then failwith "Not implemented" + (* (let js_syntax, _ = Js_syntax.parse !filename in *) + (* 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/interp.ml b/lib/interp.ml index 2027d82..24761d8 100644 --- a/lib/interp.ml +++ b/lib/interp.ml @@ -259,7 +259,7 @@ end let rec eval : type a. a Expr.t -> value = fun expr -> Logger.eval expr; - match expr with + match expr.desc with | Const Unit -> Unit | Const (Bool b) -> Bool b | Const (Int i) -> Int i diff --git a/lib/js_syntax.ml b/lib/js_syntax.ml index 79b6633..1ff54c4 100644 --- a/lib/js_syntax.ml +++ b/lib/js_syntax.ml @@ -17,9 +17,20 @@ 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 + let loc = + let (Ex e1) = e1 in + let (Ex e2) = e2 in + Location. + { + loc_start = e1.loc.loc_start; + loc_end = e2.loc.loc_end; + loc_ghost = true; + } + in + (* mk is polymorphic, so cannot locally bind `mk = mk ~loc` here *) match (hook_free e1, hook_free e2) with - | Some e1, Some e2 -> Ex (Seq (e1, e2)) - | _, _ -> Ex (Seq (hook_full e1, hook_full e2)) + | Some e1, Some e2 -> Ex (mk ~loc (Seq (e1, e2))) + | _, _ -> Ex (mk ~loc (Seq (hook_full e1, hook_full e2))) let fresh = let counter = ref 0 in @@ -43,6 +54,8 @@ 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 + let loc = { base_expr.loc with loc_ghost = true } in + match pattern with | Identifier { name = _, { name; _ }; _ } -> [ (name, base_expr) ] | Object { properties; _ } -> @@ -60,7 +73,13 @@ let rec convert_pattern ((_, pattern) : (Loc.t, Loc.t) Flow_ast.Pattern.t) | Computed _ -> raise NotImplemented in convert_pattern pattern - ~base_expr:(Get { obj = Var base_name; idx = key }) + ~base_expr: + (mk ~loc + (Get + { + obj = mk ~loc:Location.none (Var base_name); + idx = mk ~loc:Location.none key; + })) | Property (_, { default = Some _; _ }) -> raise NotImplemented | RestElement _ -> raise NotImplemented) | Array { elements; _ } -> @@ -69,7 +88,13 @@ let rec convert_pattern ((_, pattern) : (Loc.t, Loc.t) Flow_ast.Pattern.t) :: 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) }) + ~base_expr: + (mk ~loc + (Get + { + obj = mk ~loc:Location.none (Var base_name); + idx = mk ~loc:Location.none (Const (Int i)); + })) | Element (_, { default = Some _; _ }) -> raise NotImplemented | RestElement _ -> raise NotImplemented | Hole _ -> []) @@ -101,378 +126,380 @@ let convert_bop (bop : Flow_ast.Expression.Binary.operator) : Syntax.Expr.bop = | 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)) +(* 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 e426f07..f721f7b 100644 --- a/lib/lexer.mll +++ b/lib/lexer.mll @@ -4,6 +4,7 @@ open Parser exception SyntaxError of string +(* TODO: Use String_dict *) let keywords = let tbl : (string, token) Hashtbl.t = Hashtbl.create 10 in let add_to_tbl (id, tok) = Hashtbl.add tbl id tok in diff --git a/lib/parser.mly b/lib/parser.mly index 727e148..e3968df 100644 --- a/lib/parser.mly +++ b/lib/parser.mly @@ -3,13 +3,20 @@ open Syntax open Prog open Expr +let make_loc (startpos, endpos) = + Location.{ loc_start = startpos; loc_end = endpos; loc_ghost = false } + +let mkexp ~loc d = Expr.mk ~loc:(make_loc loc) d + let rec label_stts_prog = function | Expr _ as e -> e | Comp (c, tl) -> Comp ({ c with body = label_stts_expr 0 c.body }, label_stts_prog tl) and label_stts_expr label = function - | Stt s -> Stt { s with label; body = label_stts_expr (label + 1) s.body } + | { desc = Stt s; loc } -> + Expr.mk ~loc + (Stt { s with label; body = label_stts_expr (label + 1) s.body }) | e -> e %} @@ -45,6 +52,9 @@ and label_stts_expr label = function %start prog %start expr %% + +%inline mkexp(symb): symb { Ex (mkexp ~loc:$sloc $1) } + prog: | prog = comp_lst; EOF { label_stts_prog prog } expr: @@ -57,30 +67,45 @@ comp_expr: | LET; name = var; param = var; EQ; body = expr_ { { name; param; body = hook_full body } } expr_: | apply { $1 } - | FUN; param = var; RARROW; body = expr_ { Ex (Fn { param; body = hook_free_exn body }) } + | mkexp(FUN; param = var; RARROW; body = expr_ + { Fn { param; body = hook_free_exn body } }) + { $1 } | LET; id = var; EQ; bound = expr_; IN; body = expr_ { let Ex body = body in - Ex (Let { id; bound = hook_free_exn bound; body }) + Ex (mkexp ~loc:$sloc (Let { id; bound = hook_free_exn bound; body })) } - | LET; LPAREN; stt = var; COMMA; set = var; RPAREN; EQ; STT; init = expr_; IN; body = expr_ - { Ex (Stt { label = -1; stt; set; init = hook_free_exn init; body = hook_full body }) } - | EFF; e = expr_ { Ex (Eff (hook_free_exn e)) } - | VIEW; LBRACK; vss = separated_nonempty_list(COMMA, expr_); RBRACK { Ex (View (List.map hook_free_exn vss)) } - | IF; pred = expr_; THEN; con = expr_; ELSE; alt = expr_ - { Ex (Cond { pred = hook_free_exn pred; con = hook_free_exn con; alt = hook_free_exn alt }) } - | IF; pred = expr_; THEN; con = expr_ - { Ex (Cond { pred = hook_free_exn pred; con = hook_free_exn con; alt = Const Unit }) } + | mkexp(LET; LPAREN; stt = var; COMMA; set = var; RPAREN; EQ; STT; init = expr_; IN; body = expr_ + { Stt { label = -1; stt; set; init = hook_free_exn init; body = hook_full body } }) + { $1 } + | mkexp(EFF; e = expr_ + { Eff (hook_free_exn e) }) + { $1 } + | mkexp(VIEW; LBRACK; vss = separated_nonempty_list(COMMA, expr_); RBRACK + { View (List.map hook_free_exn vss) }) + { $1 } + | mkexp(IF; pred = expr_; THEN; con = expr_; ELSE; alt = expr_ + { Cond { pred = hook_free_exn pred; con = hook_free_exn con; alt = hook_free_exn alt } }) + { $1 } + | mkexp(IF; pred = expr_; THEN; con = expr_ + { Cond { pred = hook_free_exn pred; con = hook_free_exn con; alt = Expr.mk ~loc:Location.none (Const Unit) } }) + { $1 } | e1 = expr_; SEMI; e2 = expr_ { match hook_free e1, hook_free e2 with - | Some e1, Some e2 -> Ex (Seq (e1, e2)) - | _, _ -> Ex (Seq (hook_full e1, hook_full e2)) + | Some e1, Some e2 -> Ex (mkexp ~loc:$sloc (Seq (e1, e2))) + | _, _ -> Ex (mkexp ~loc:$sloc (Seq (hook_full e1, hook_full e2))) } - | 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 }) } - | obj = apply; LBRACK; index = expr_; RBRACK { Ex (Get { obj = hook_free_exn obj; idx = hook_free_exn index }) } - | obj = apply; LBRACK; index = expr_; RBRACK; ASSIGN; value = expr_ - { Ex (Set { obj = hook_free_exn obj; idx = hook_free_exn index; value = hook_free_exn value }) } + | mkexp(op = uop; expr_ = expr_ %prec prec_unary + { Uop { op; arg = hook_free_exn expr_ } }) + { $1 } + | mkexp(left = expr_; op = bop; right = expr_ + { Bop { op; left = hook_free_exn left; right = hook_free_exn right } }) + { $1 } + | mkexp(obj = apply; LBRACK; index = expr_; RBRACK + { Get { obj = hook_free_exn obj; idx = hook_free_exn index } }) + { $1 } + | mkexp(obj = apply; LBRACK; index = expr_; RBRACK; ASSIGN; value = expr_ + { Set { obj = hook_free_exn obj; idx = hook_free_exn index; value = hook_free_exn value } }) + { $1 } %inline uop: | NOT { Not } | PLUS { Uplus } @@ -99,15 +124,17 @@ expr_: | TIMES { Times } apply: | atom { $1 } - | fn = apply; arg = atom { Ex (App { fn = hook_free_exn fn; arg = hook_free_exn arg }) } + | mkexp(fn = apply; arg = atom + { App { fn = hook_free_exn fn; arg = hook_free_exn arg } }) + { $1 } atom: - | UNIT { Ex (Const Unit) } - | 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) } - | RECORD { Ex (Alloc) } + | mkexp(UNIT { Const Unit }) { $1 } + | mkexp(TRUE { Const (Bool true) }) { $1 } + | mkexp(FALSE { Const (Bool false) }) { $1 } + | mkexp(n = INT { Const (Int n) }) { $1 } + | mkexp(s = STRING { Const (String s) }) { $1 } + | mkexp(var = var { Var var }) { $1 } + | mkexp(RECORD { Alloc }) { $1 } | LPAREN; e = expr_; RPAREN { e } var: | x = ID { x } diff --git a/lib/syntax.ml b/lib/syntax.ml index 1fffd33..1722967 100644 --- a/lib/syntax.ml +++ b/lib/syntax.ml @@ -15,14 +15,21 @@ module Expr = struct type uop = Not | Uplus | Uminus type bop = Eq | Lt | Gt | Ne | Le | Ge | And | Or | Plus | Minus | Times - type _ t = - | Const : const -> _ t - | Var : Id.t -> _ t - | View : hook_free t list -> _ t - | Cond : { pred : hook_free t; con : hook_free t; alt : hook_free t } -> _ t - | Fn : { param : Id.t; body : hook_free t } -> _ t - | App : { fn : hook_free t; arg : hook_free t } -> _ t - | Let : { id : Id.t; bound : hook_free t; body : 'a t } -> 'a t + type 'a t = { desc : 'a desc; loc : Location.t } + + and _ desc = + | Const : const -> _ desc + | Var : Id.t -> _ desc + | View : hook_free t list -> _ desc + | Cond : { + pred : hook_free t; + con : hook_free t; + alt : hook_free t; + } + -> _ desc + | Fn : { param : Id.t; body : hook_free t } -> _ desc + | App : { fn : hook_free t; arg : hook_free t } -> _ desc + | Let : { id : Id.t; bound : hook_free t; body : 'a t } -> 'a desc | Stt : { label : Label.t; stt : Id.t; @@ -30,31 +37,39 @@ module Expr = struct init : hook_free t; body : hook_full t; } - -> hook_full t - | Eff : hook_free t -> hook_full t - | 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 + -> hook_full desc + | Eff : hook_free t -> hook_full desc + | Seq : 'a t * 'a t -> 'a desc + | Uop : { op : uop; arg : hook_free t } -> _ desc + | Bop : { op : bop; left : hook_free t; right : hook_free t } -> _ desc + | Alloc : _ desc + | Get : { obj : hook_free t; idx : hook_free t } -> _ desc + | Set : { + obj : hook_free t; + idx : hook_free t; + value : hook_free t; + } + -> _ desc type hook_free_t = hook_free t type hook_full_t = hook_full t type some_expr = Ex : 'a t -> some_expr [@@unboxed] + let mk ~loc desc = { desc; loc } + let rec hook_free (expr : some_expr) : hook_free t option = - let (Ex expr) = expr in - let ( let* ) = Stdlib.Option.bind in - match expr with + let (Ex { desc; loc }) = expr in + let mk = mk ~loc in + let open Option.Let_syntax in + match desc with | Let ({ body; _ } as e) -> - let* body = hook_free (Ex body) in - Some (Let { e with body }) + let%bind body = hook_free (Ex body) in + Some (mk (Let { e with body })) | Stt _ | Eff _ -> None | Seq (e1, e2) -> - let* e1 = hook_free (Ex e1) in - let* e2 = hook_free (Ex e2) in - Some (Seq (e1, e2)) + let%bind e1 = hook_free (Ex e1) in + let%bind e2 = hook_free (Ex e2) in + Some (mk (Seq (e1, e2))) | (Const _ as e) | (Var _ as e) | (View _ as e) @@ -66,20 +81,21 @@ module Expr = struct | (Alloc as e) | (Get _ as e) | (Set _ as e) -> - Some e + Some (mk e) let hook_free_exn e = Option.value_exn (hook_free e) let rec hook_full (expr : some_expr) : hook_full t = - let (Ex expr) = expr in - match expr with + let (Ex { desc; loc }) = expr in + let mk = mk ~loc in + match desc with | Let ({ body; _ } as e) -> let body = hook_full (Ex body) in - Let { e with body } + mk (Let { e with body }) | Seq (e1, e2) -> let e1 = hook_full (Ex e1) in let e2 = hook_full (Ex e2) in - Seq (e1, e2) + mk (Seq (e1, e2)) | (Const _ as e) | (Var _ as e) | (View _ as e) @@ -93,7 +109,7 @@ module Expr = struct | (Alloc as e) | (Get _ as e) | (Set _ as e) -> - e + mk e let string_of_uop = function Not -> "not" | Uplus -> "+" | Uminus -> "-" @@ -111,8 +127,9 @@ module Expr = struct | Times -> "*" let rec sexp_of_t : type a. a t -> Sexp.t = + fun { desc; _ } -> let open Sexp_helper in - function + match desc with | Const Unit -> a "()" | Const (Bool b) -> Bool.sexp_of_t b | Const (Int i) -> Int.sexp_of_t i diff --git a/test/test_react_trace.ml b/test/test_react_trace.ml index 1cd099d..5442f08 100644 --- a/test/test_react_trace.ml +++ b/test/test_react_trace.ml @@ -1,1012 +1,906 @@ -open! Core -open Stdlib.Effect.Deep -open React_trace - -let fuel = 100 - -module Interp = struct - include Interp - - let run = Interp.run ~recorder:(module Default_recorder) -end - -let parse_prog s = - let lexbuf = Lexing.from_string s in - Parser.prog Lexer.read lexbuf - -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 - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse unit" ~actual:(Expr.sexp_of_t expr) - ~expected:Expr.(sexp_of_t (Const Unit)) - -let parse_true () = - let open Syntax in - let (Ex expr) = parse_expr "true" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse true" ~actual:(Expr.sexp_of_t expr) - ~expected:Expr.(sexp_of_t (Const (Bool true))) - -let parse_false () = - let open Syntax in - let (Ex expr) = parse_expr "false" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse false" ~actual:(Expr.sexp_of_t expr) - ~expected:Expr.(sexp_of_t (Const (Bool false))) - -let parse_int () = - let open Syntax in - let (Ex expr) = parse_expr "42" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse int" ~actual:(Expr.sexp_of_t expr) - ~expected:Expr.(sexp_of_t (Const (Int 42))) - -let parse_var () = - let open Syntax in - let (Ex expr) = parse_expr "_some_variable123" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse var" ~actual:(Expr.sexp_of_t expr) - ~expected:Expr.(sexp_of_t (Var "_some_variable123")) - -let parse_view () = - let open Syntax in - let (Ex expr) = parse_expr "view [(), 42, (), Comp ()]" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse view" ~actual:(Expr.sexp_of_t expr) - ~expected: - Expr.( - sexp_of_t - (View - [ - Const Unit; - Const (Int 42); - Const Unit; - App { fn = Var "Comp"; arg = Const Unit }; - ])) - -let parse_open_cond () = - let open Syntax in - let (Ex expr) = parse_expr "if true then if true then ()" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse open cond" ~expected:(Expr.sexp_of_t expr) - ~actual: - Expr.( - sexp_of_t - (Cond - { - pred = Const (Bool true); - con = - Cond - { - pred = Const (Bool true); - con = Const Unit; - alt = Const Unit; - }; - alt = Const Unit; - })) - -let parse_closed_cond () = - let open Syntax in - let (Ex expr) = parse_expr "if true then if true then () else ()" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse closed cond" ~expected:(Expr.sexp_of_t expr) - ~actual: - Expr.( - sexp_of_t - (Cond - { - pred = Const (Bool true); - con = - Cond - { - pred = Const (Bool true); - con = Const Unit; - alt = Const Unit; - }; - alt = Const Unit; - })) - -let parse_fn () = - let open Syntax in - let (Ex expr) = parse_expr "fun x -> fun y -> x + y" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse closed cond" ~expected:(Expr.sexp_of_t expr) - ~actual: - Expr.( - sexp_of_t - (Fn - { - param = "x"; - body = - Fn - { - param = "y"; - body = Bop { op = Plus; left = Var "x"; right = Var "y" }; - }; - })) - -let parse_app () = - let open Syntax in - let (Ex expr) = parse_expr "a b c" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse app" ~actual:(Expr.sexp_of_t expr) - ~expected: - Expr.( - sexp_of_t - (App { fn = App { fn = Var "a"; arg = Var "b" }; arg = Var "c" })) - -let parse_let () = - let open Syntax in - let (Ex expr) = parse_expr "let x = let y = 1 in y in let z = x in z" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse let" ~actual:(Expr.sexp_of_t expr) - ~expected: - Expr.( - sexp_of_t - (Let - { - id = "x"; - bound = Let { id = "y"; bound = Const (Int 1); body = Var "y" }; - body = Let { id = "z"; bound = Var "x"; body = Var "z" }; - })) - -let parse_stt () = - let open Syntax in - let (Ex expr) = - parse_expr - "let (x, setX) = useState 42 in let (y, setY) = useState -42 in x + y" - in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse stt" ~actual:(Expr.sexp_of_t expr) - ~expected: - Expr.( - sexp_of_t - (Stt - { - label = 0; - stt = "x"; - set = "setX"; - init = Const (Int 42); - body = - Stt - { - label = 1; - stt = "y"; - set = "setY"; - init = Uop { op = Uminus; arg = Const (Int 42) }; - body = Bop { op = Plus; left = Var "x"; right = Var "y" }; - }; - })) - -let parse_eff () = - let open Syntax in - let (Ex expr) = parse_expr "useEffect (x ())" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse eff" ~actual:(Expr.sexp_of_t expr) - ~expected:Expr.(sexp_of_t (Eff (App { fn = Var "x"; arg = Const Unit }))) - -let parse_seq () = - let open Syntax in - let (Ex expr) = parse_expr "a; b; c; d" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse seq" ~actual:(Expr.sexp_of_t expr) - ~expected: - Expr.(sexp_of_t (Seq (Var "a", Seq (Var "b", Seq (Var "c", Var "d"))))) - -let parse_op () = - let open Syntax in - let (Ex expr) = parse_expr "not (+-a () <= 0 + -0) || true" in - Alcotest.(check' (of_pp Sexp.pp_hum)) - ~msg:"parse op" ~actual:(Expr.sexp_of_t expr) - ~expected: - Expr.( - sexp_of_t - (Bop - { - op = Or; - left = - Uop - { - op = Not; - arg = - Bop - { - op = Le; - left = - Uop - { - op = Uplus; - arg = - Uop - { - op = Uminus; - arg = - App { fn = Var "a"; arg = Const Unit }; - }; - }; - right = - Bop - { - op = Plus; - left = Const (Int 0); - right = - Uop { op = Uminus; arg = Const (Int 0) }; - }; - }; - }; - 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 - {| -let C x = - let (s, setS) = useState 42 in - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps - -let set_in_body_nonterminate () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - setS (fun s -> 43); - view [()] -;; -view [C ()] -|} - in - let run () = - Interp.(match_with (run ~fuel) prog re_render_limit_h ~re_render_limit:25) - |> ignore - in - Alcotest.(check_raises) - "retry indefintely" Interp_effects.Too_many_re_renders run - -let set_in_body_guarded () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - if s = 42 then setS (fun s -> 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 set_in_effect_step_one_time () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> 42)); - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:1 ~actual:steps - -let set_in_effect_step_two_times () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> 43)); - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps - -let set_in_effect_step_indefinitely () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> s + 1)); - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step indefintely" ~expected:fuel ~actual:steps - -let set_in_effect_guarded_step_two_times () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (if s = 42 then setS (fun s -> 43)); - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps - -let set_in_effect_guarded_step_n_times () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (if s <= 45 then setS (fun s -> s + 1)); - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step five times" ~expected:5 ~actual:steps - -let set_in_effect_with_arg_step_one_time () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (if s <> x then setS (fun s -> x)); - view [()] -;; -view [C 42] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps - -let set_in_effect_with_arg_step_two_times () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (if s <> x then setS (fun s -> x)); - view [()] -;; -view [C 0] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps - -let set_passed_step_two_times () = - let prog = - parse_prog - {| -let C setS = - useEffect (setS (fun s -> 0)); - view [()] -;; -let D x = - let (s, setS) = useState 42 in - view [C setS] -;; -view [D ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps - -let set_passed_step_indefinitely () = - let prog = - parse_prog - {| -let C setS = - useEffect (setS (fun s -> s + 1)); - view [()] -;; -let D x = - let (s, setS) = useState 42 in - view [C setS] -;; -view [D ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step indefintely" ~expected:fuel ~actual:steps - -let set_in_effect_twice_step_one_time () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> 43); setS (fun s -> 42)); - view [()] -;; -view [C ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps - -let set_in_removed_child_step_two_times () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> s + 1)); - view [()] -;; -let D x = - let (s, setS) = useState true in - useEffect (setS (fun s -> false)); - if s then - view [C ()] - else - view [()] -;; -view [D ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps - -let state_persists_in_child () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> 0)); - view [()] -;; -let D x = - let (s, setS) = useState true in - useEffect (setS (fun s -> false)); - if s then - view [C ()] - else - view [C ()] -;; -view [D ()] -|} - in - let { Interp.steps; _ } = Interp.run ~fuel prog in - Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps - -let new_child_steps_again () = - let prog = - parse_prog - {| -let C x = - let (s, setS) = useState 42 in - useEffect (setS (fun s -> 0)); - view [()] -;; -let D x = - let (s, setS) = useState true in - useEffect (setS (fun s -> false)); - if s then - view [C ()] - else - view [C (), C ()] -;; -view [D ()] -|} - in - 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" - [ - ( "parse", - [ - test_case "unit" `Quick parse_unit; - test_case "true" `Quick parse_true; - test_case "false" `Quick parse_false; - test_case "int" `Quick parse_int; - test_case "var" `Quick parse_var; - test_case "view" `Quick parse_view; - test_case "open cond" `Quick parse_open_cond; - test_case "closed cond" `Quick parse_closed_cond; - test_case "fn" `Quick parse_fn; - test_case "app" `Quick parse_app; - test_case "let" `Quick parse_let; - test_case "stt" `Quick parse_stt; - 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", - [ - test_case "No side effect should step one time" `Quick no_side_effect; - test_case "Set in body should not terminate" `Quick - set_in_body_nonterminate; - test_case "Guarded set in body should step one time" `Quick - set_in_body_guarded; - test_case "Set in effect should step one time" `Quick - set_in_effect_step_one_time; - test_case "Set in effect should step two times" `Quick - set_in_effect_step_two_times; - test_case "Set in effect should step indefintely" `Quick - set_in_effect_step_indefinitely; - test_case "Guarded set in effect should step two times" `Quick - set_in_effect_guarded_step_two_times; - test_case "Guarded set in effect should step five times" `Quick - set_in_effect_guarded_step_n_times; - test_case "Set in effect with arg should step one time" `Quick - set_in_effect_with_arg_step_one_time; - test_case "Set in effect with arg should step two times" `Quick - set_in_effect_with_arg_step_two_times; - test_case "Set passed to child should step two times" `Quick - set_passed_step_two_times; - test_case "Set passed to child should step indefintely" `Quick - set_passed_step_indefinitely; - test_case "Set in effect twice should step one time" `Quick - set_in_effect_twice_step_one_time; - test_case "Set in removed child should step two times" `Quick - 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; - ] ); - ] +(* open! Core *) +(* open Stdlib.Effect.Deep *) +(* open React_trace *) +(**) +(* let fuel = 100 *) +(**) +(* module Interp = struct *) +(* include Interp *) +(**) +(* let run = Interp.run ~recorder:(module Default_recorder) *) +(* end *) +(**) +(* include struct *) +(* open Syntax.Expr *) +(**) +(* let mkexp e = mk ~loc:Location.none e *) +(* let mkconst c = mkexp (Const c) *) +(* let mkvar x = mkexp (Var x) *) +(* let mkview es = mkexp (View es) *) +(* let mkcond ~pred ~con ~alt = mkexp (Cond { pred; con; alt }) *) +(* let mkfn ~param ~body = mkexp (Fn { param; body }) *) +(* let mkapp ~fn ~arg = mkexp (App { fn; arg }) *) +(* let mklet ~id ~bound ~body = mkexp (Let { id; bound; body }) *) +(**) +(* let mkstt ~label ~stt ~set ~init ~body = *) +(* mkexp (Stt { label; stt; set; init; body }) *) +(**) +(* let mkeff e = mkexp (Eff e) *) +(* let mkseq (e1, e2) = mkexp (Seq (e1, e2)) *) +(* let mkbop ~op ~left ~right = mkexp (Bop { op; left; right }) *) +(* let mkuop ~op ~arg = mkexp (Uop { op; arg }) *) +(* let mkalloc = mkexp Alloc *) +(* let mkset ~obj ~idx ~value = mkexp (Set { obj; idx; value }) *) +(* let mkget ~obj ~idx = mkexp (Get { obj; idx }) *) +(* end *) +(**) +(* let parse_prog s = *) +(* let lexbuf = Lexing.from_string s in *) +(* Parser.prog Lexer.read lexbuf *) +(**) +(* 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 *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse unit" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected:Expr.(sexp_of_t (Const Unit)) *) +(**) +(* let parse_true () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "true" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse true" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected:Expr.(sexp_of_t (Const (Bool true))) *) +(**) +(* let parse_false () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "false" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse false" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected:Expr.(sexp_of_t (Const (Bool false))) *) +(**) +(* let parse_int () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "42" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse int" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected:Expr.(sexp_of_t (Const (Int 42))) *) +(**) +(* let parse_var () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "_some_variable123" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse var" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected:Expr.(sexp_of_t (Var "_some_variable123")) *) +(**) +(* let parse_view () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "view [(), 42, (), Comp ()]" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse view" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected: *) +(* Expr.( *) +(* sexp_of_t *) +(* (View *) +(* [ *) +(* Const Unit; *) +(* Const (Int 42); *) +(* Const Unit; *) +(* App { fn = Var "Comp"; arg = Const Unit }; *) +(* ])) *) +(**) +(* let parse_open_cond () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "if true then if true then ()" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse open cond" ~expected:(Expr.sexp_of_t expr) *) +(* ~actual: *) +(* Expr.( *) +(* sexp_of_t *) +(* (Cond *) +(* { *) +(* pred = Const (Bool true); *) +(* con = *) +(* Cond *) +(* { *) +(* pred = Const (Bool true); *) +(* con = Const Unit; *) +(* alt = Const Unit; *) +(* }; *) +(* alt = Const Unit; *) +(* })) *) +(**) +(* let parse_closed_cond () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "if true then if true then () else ()" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse closed cond" ~expected:(Expr.sexp_of_t expr) *) +(* ~actual: *) +(* Expr.( *) +(* sexp_of_t *) +(* (Cond *) +(* { *) +(* pred = Const (Bool true); *) +(* con = *) +(* Cond *) +(* { *) +(* pred = Const (Bool true); *) +(* con = Const Unit; *) +(* alt = Const Unit; *) +(* }; *) +(* alt = Const Unit; *) +(* })) *) +(**) +(* let parse_fn () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "fun x -> fun y -> x + y" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse closed cond" ~expected:(Expr.sexp_of_t expr) *) +(* ~actual: *) +(* Expr.( *) +(* sexp_of_t *) +(* (Fn *) +(* { *) +(* param = "x"; *) +(* body = *) +(* Fn *) +(* { *) +(* param = "y"; *) +(* body = Bop { op = Plus; left = Var "x"; right = Var "y" }; *) +(* }; *) +(* })) *) +(**) +(* let parse_app () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "a b c" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse app" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected: *) +(* Expr.( *) +(* sexp_of_t *) +(* (App { fn = App { fn = Var "a"; arg = Var "b" }; arg = Var "c" })) *) +(**) +(* let parse_let () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "let x = let y = 1 in y in let z = x in z" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse let" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected: *) +(* Expr.( *) +(* sexp_of_t *) +(* (Let *) +(* { *) +(* id = "x"; *) +(* bound = Let { id = "y"; bound = Const (Int 1); body = Var "y" }; *) +(* body = Let { id = "z"; bound = Var "x"; body = Var "z" }; *) +(* })) *) +(**) +(* let parse_stt () = *) +(* let open Syntax in *) +(* let (Ex expr) = *) +(* parse_expr *) +(* "let (x, setX) = useState 42 in let (y, setY) = useState -42 in x + y" *) +(* in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse stt" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected: *) +(* Expr.( *) +(* sexp_of_t *) +(* (Stt *) +(* { *) +(* label = 0; *) +(* stt = "x"; *) +(* set = "setX"; *) +(* init = Const (Int 42); *) +(* body = *) +(* Stt *) +(* { *) +(* label = 1; *) +(* stt = "y"; *) +(* set = "setY"; *) +(* init = Uop { op = Uminus; arg = Const (Int 42) }; *) +(* body = Bop { op = Plus; left = Var "x"; right = Var "y" }; *) +(* }; *) +(* })) *) +(**) +(* let parse_eff () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "useEffect (x ())" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse eff" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected:Expr.(sexp_of_t (Eff (App { fn = Var "x"; arg = Const Unit }))) *) +(**) +(* let parse_seq () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "a; b; c; d" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse seq" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected: *) +(* Expr.(sexp_of_t (Seq (Var "a", Seq (Var "b", Seq (Var "c", Var "d"))))) *) +(**) +(* let parse_op () = *) +(* let open Syntax in *) +(* let (Ex expr) = parse_expr "not (+-a () <= 0 + -0) || true" in *) +(* Alcotest.(check' (of_pp Sexp.pp_hum)) *) +(* ~msg:"parse op" ~actual:(Expr.sexp_of_t expr) *) +(* ~expected: *) +(* Expr.( *) +(* sexp_of_t *) +(* (Bop *) +(* { *) +(* op = Or; *) +(* left = *) +(* Uop *) +(* { *) +(* op = Not; *) +(* arg = *) +(* Bop *) +(* { *) +(* op = Le; *) +(* left = *) +(* Uop *) +(* { *) +(* op = Uplus; *) +(* arg = *) +(* Uop *) +(* { *) +(* op = Uminus; *) +(* arg = *) +(* App { fn = Var "a"; arg = Const Unit }; *) +(* }; *) +(* }; *) +(* right = *) +(* Bop *) +(* { *) +(* op = Plus; *) +(* left = Const (Int 0); *) +(* right = *) +(* Uop { op = Uminus; arg = Const (Int 0) }; *) +(* }; *) +(* }; *) +(* }; *) +(* 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 *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* view [()] *) (* + ;; *) (* view [C ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps *) +(**) +(* let set_in_body_nonterminate () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* setS (fun s -> + 43); *) (* view [()] *) (* ;; *) (* view [C ()] *) (* |} *) +(* in *) +(* let run () = *) +(* Interp.(match_with (run ~fuel) prog re_render_limit_h ~re_render_limit:25) *) +(* |> ignore *) +(* in *) +(* Alcotest.(check_raises) *) +(* "retry indefintely" Interp_effects.Too_many_re_renders run *) +(**) +(* let set_in_body_guarded () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* if s = 42 then + setS (fun s -> 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 set_in_effect_step_one_time () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> 42)); *) (* view [()] *) (* ;; *) (* view [C ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:1 ~actual:steps *) +(**) +(* let set_in_effect_step_two_times () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> 43)); *) (* view [()] *) (* ;; *) (* view [C ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps *) +(**) +(* let set_in_effect_step_indefinitely () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> s + 1)); *) (* view [()] *) (* ;; *) (* view [C ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step indefintely" ~expected:fuel ~actual:steps *) +(**) +(* let set_in_effect_guarded_step_two_times () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (if s + = 42 then setS (fun s -> 43)); *) (* view [()] *) (* ;; *) (* view [C ()] *) + (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps *) +(**) +(* let set_in_effect_guarded_step_n_times () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (if s + <= 45 then setS (fun s -> s + 1)); *) (* view [()] *) (* ;; *) (* view [C ()] + *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step five times" ~expected:5 ~actual:steps *) +(**) +(* let set_in_effect_with_arg_step_one_time () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (if s + <> x then setS (fun s -> x)); *) (* view [()] *) (* ;; *) (* view [C 42] *) + (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps *) +(**) +(* let set_in_effect_with_arg_step_two_times () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (if s + <> x then setS (fun s -> x)); *) (* view [()] *) (* ;; *) (* view [C 0] *) (* + |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps *) +(**) +(* let set_passed_step_two_times () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C setS = *) (* useEffect (setS (fun s -> 0)); *) (* view [()] *) + (* ;; *) (* let D x = *) (* let (s, setS) = useState 42 in *) (* view [C + setS] *) (* ;; *) (* view [D ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps *) +(**) +(* let set_passed_step_indefinitely () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C setS = *) (* useEffect (setS (fun s -> s + 1)); *) (* view + [()] *) (* ;; *) (* let D x = *) (* let (s, setS) = useState 42 in *) (* view + [C setS] *) (* ;; *) (* view [D ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step indefintely" ~expected:fuel ~actual:steps *) +(**) +(* let set_in_effect_twice_step_one_time () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> 43); setS (fun s -> 42)); *) (* view [()] *) (* ;; *) (* view [C + ()] *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step one time" ~expected:1 ~actual:steps *) +(**) +(* let set_in_removed_child_step_two_times () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> s + 1)); *) (* view [()] *) (* ;; *) (* let D x = *) (* let (s, + setS) = useState true in *) (* useEffect (setS (fun s -> false)); *) (* if s + then *) (* view [C ()] *) (* else *) (* view [()] *) (* ;; *) (* view [D ()] + *) (* |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps *) +(**) +(* let state_persists_in_child () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> 0)); *) (* view [()] *) (* ;; *) (* let D x = *) (* let (s, setS) = + useState true in *) (* useEffect (setS (fun s -> false)); *) (* if s then *) + (* view [C ()] *) (* else *) (* view [C ()] *) (* ;; *) (* view [D ()] *) (* + |} *) +(* in *) +(* let { Interp.steps; _ } = Interp.run ~fuel prog in *) +(* Alcotest.(check' int) ~msg:"step two times" ~expected:2 ~actual:steps *) +(**) +(* let new_child_steps_again () = *) +(* let prog = *) +(* parse_prog *) +(* {| *) (* let C x = *) (* let (s, setS) = useState 42 in *) (* useEffect (setS + (fun s -> 0)); *) (* view [()] *) (* ;; *) (* let D x = *) (* let (s, setS) = + useState true in *) (* useEffect (setS (fun s -> false)); *) (* if s then *) + (* view [C ()] *) (* else *) (* view [C (), C ()] *) (* ;; *) (* view [D ()] + *) (* |} *) +(* in *) +(* 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" *) +(* [ *) +(* ( "parse", *) +(* [ *) +(* test_case "unit" `Quick parse_unit; *) +(* test_case "true" `Quick parse_true; *) +(* test_case "false" `Quick parse_false; *) +(* test_case "int" `Quick parse_int; *) +(* test_case "var" `Quick parse_var; *) +(* test_case "view" `Quick parse_view; *) +(* test_case "open cond" `Quick parse_open_cond; *) +(* test_case "closed cond" `Quick parse_closed_cond; *) +(* test_case "fn" `Quick parse_fn; *) +(* test_case "app" `Quick parse_app; *) +(* test_case "let" `Quick parse_let; *) +(* test_case "stt" `Quick parse_stt; *) +(* 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", *) +(* [ *) +(* test_case "No side effect should step one time" `Quick no_side_effect; *) +(* test_case "Set in body should not terminate" `Quick *) +(* set_in_body_nonterminate; *) +(* test_case "Guarded set in body should step one time" `Quick *) +(* set_in_body_guarded; *) +(* test_case "Set in effect should step one time" `Quick *) +(* set_in_effect_step_one_time; *) +(* test_case "Set in effect should step two times" `Quick *) +(* set_in_effect_step_two_times; *) +(* test_case "Set in effect should step indefintely" `Quick *) +(* set_in_effect_step_indefinitely; *) +(* test_case "Guarded set in effect should step two times" `Quick *) +(* set_in_effect_guarded_step_two_times; *) +(* test_case "Guarded set in effect should step five times" `Quick *) +(* set_in_effect_guarded_step_n_times; *) +(* test_case "Set in effect with arg should step one time" `Quick *) +(* set_in_effect_with_arg_step_one_time; *) +(* test_case "Set in effect with arg should step two times" `Quick *) +(* set_in_effect_with_arg_step_two_times; *) +(* test_case "Set passed to child should step two times" `Quick *) +(* set_passed_step_two_times; *) +(* test_case "Set passed to child should step indefintely" `Quick *) +(* set_passed_step_indefinitely; *) +(* test_case "Set in effect twice should step one time" `Quick *) +(* set_in_effect_twice_step_one_time; *) +(* test_case "Set in removed child should step two times" `Quick *) +(* 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; *) +(* ] ); *) +(* ] *)