diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index cd7f81d61..725c2b908 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -50,6 +50,19 @@ let rec expression ppf (e:expression) = match e with fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m | E_failwith ae -> fprintf ppf "failwith %a" annotated_expression ae + | E_sequence (a , b) -> + fprintf ppf "%a ; %a" + annotated_expression a + annotated_expression b + | E_loop (expr , body) -> + fprintf ppf "%a ; %a" + annotated_expression expr + annotated_expression body + | E_assign (name , path , expr) -> + fprintf ppf "%s.%a := %a" + name + PP_helpers.(list_sep access (const ".")) path + annotated_expression expr and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" annotated_expression a annotated_expression b diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index e09d12e59..af1e1943a 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -74,6 +74,10 @@ and expression = (* Matching *) | E_matching of (ae * matching_expr) | E_failwith of ae + (* Replace Statements *) + | E_sequence of (ae * ae) + | E_loop of (ae * ae) + | E_assign of (name * access_path * ae) and access = | Access_tuple of int diff --git a/src/ast_typed/PP.ml b/src/ast_typed/PP.ml index 35bc1101e..22d241ca0 100644 --- a/src/ast_typed/PP.ml +++ b/src/ast_typed/PP.ml @@ -47,6 +47,13 @@ and expression ppf (e:expression) : unit = | E_matching (ae, m) -> fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m | E_failwith ae -> fprintf ppf "failwith %a" annotated_expression ae + | E_sequence (a , b) -> fprintf ppf "%a ; %a" annotated_expression a annotated_expression b + | E_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body + | E_assign (name , path , expr) -> + fprintf ppf "%s.%a := %a" + name.type_name + PP_helpers.(list_sep pre_access (const ".")) path + annotated_expression expr and value ppf v = annotated_expression ppf v diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index 0aa3cfcd8..430c2ed72 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -4,6 +4,8 @@ open Types let make_t type_value' simplified = { type_value' ; simplified } let make_a_e expression type_annotation environment = { expression ; type_annotation ; dummy_field = () ; environment } let make_n_e name a_e = { name ; annotated_expression = a_e } +let make_n_t type_name type_value = { type_name ; type_value } + let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s let t_string ?s () : type_value = make_t (T_constant ("string", [])) s diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index cb03a38b0..f2a5005a8 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -59,6 +59,9 @@ module Free_variables = struct | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] | E_matching (a , cs) -> union (self a) (matching_expression b cs) | E_failwith a -> self a + | E_sequence (a , b) -> unions @@ List.map self [ a ; b ] + | E_loop (expr , body) -> unions @@ List.map self [ expr ; body ] + | E_assign (_ , _ , expr) -> self expr and lambda : bindings -> lambda -> bindings = fun b l -> let b' = union (singleton l.binder) b in diff --git a/src/ast_typed/misc_smart.ml b/src/ast_typed/misc_smart.ml index d333705fe..cbd5b1c4a 100644 --- a/src/ast_typed/misc_smart.ml +++ b/src/ast_typed/misc_smart.ml @@ -94,6 +94,14 @@ module Captured_variables = struct let%bind cs' = matching_expression b cs in ok @@ union a' cs' | E_failwith a -> self a + | E_sequence (a , b) -> + let%bind lst' = bind_map_list self [ a ; b ] in + ok @@ unions lst' + | E_loop (expr , body) -> + let%bind lst' = bind_map_list self [ expr ; body ] in + ok @@ unions lst' + | E_assign (_ , _ , expr) -> self expr + and instruction' : bindings -> instruction -> (bindings * bindings) result = fun b i -> match i with diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index c82abd1c6..c6178730d 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -97,6 +97,10 @@ and expression = (* Advanced *) | E_matching of (ae * matching_expr) | E_failwith of ae + (* Replace Statements *) + | E_sequence of (ae * ae) + | E_loop of (ae * ae) + | E_assign of (named_type_value * access_path * ae) and value = annotated_expression (* todo (for refactoring) *) diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 83f3c2772..33d3953cf 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -377,6 +377,48 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | E_look_up dsi -> let%bind (ds', i') = bind_map_pair f dsi in return @@ E_constant ("GET", [i' ; ds']) + | E_sequence (a , b) -> ( + let%bind a' = translate_annotated_expression a in + let%bind b' = translate_annotated_expression b in + return @@ E_sequence (a' , b') + ) + | E_loop (expr , body) -> ( + let%bind expr' = translate_annotated_expression expr in + let%bind body' = translate_annotated_expression body in + return @@ E_while (expr' , body') + ) + | E_assign (typed_name , path , expr) -> ( + let ty = typed_name.type_value in + let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result = + fun (prev, acc) cur -> + let%bind ty' = translate_type prev in + match cur with + | Access_tuple ind -> + let%bind ty_lst = AST.Combinators.get_t_tuple prev in + let%bind ty'_lst = bind_map_list translate_type ty_lst in + let%bind path = tuple_access_to_lr ty' ty'_lst ind in + let path' = List.map snd path in + ok (List.nth ty_lst ind, acc @ path') + | Access_record prop -> + let%bind ty_map = + let error = + let title () = "accessing property on not a record" in + let content () = Format.asprintf "%s on %a in %a" + prop Ast_typed.PP.type_value prev Ast_typed.PP.annotated_expression expr in + error title content + in + trace error @@ + AST.Combinators.get_t_record prev in + let%bind ty'_map = bind_map_smap translate_type ty_map in + let%bind path = record_access_to_lr ty' ty'_map prop in + let path' = List.map snd path in + ok (Map.String.find prop ty_map, acc @ path') + | Access_map _k -> simple_fail "no patch for map yet" + in + let%bind (_, path) = bind_fold_right_list aux (ty, []) path in + let%bind expr' = translate_annotated_expression expr in + return (E_assignment (typed_name.type_name, path, expr')) + ) | E_matching (expr, m) -> ( let%bind expr' = translate_annotated_expression expr in match m with diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 10a146afd..88a1da145 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -571,6 +571,55 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot return (O.E_matching (ex', m')) tv ) ) + | E_sequence (a , b) -> + let%bind a' = type_annotated_expression e a in + let%bind b' = type_annotated_expression e b in + let%bind () = + trace_strong (simple_error "first part of the sequence isn't of unit type") @@ + Ast_typed.assert_type_value_eq (t_unit () , get_type_annotation a') in + return (O.E_sequence (a' , b')) (get_type_annotation b') + | E_loop (expr , body) -> + let%bind expr' = type_annotated_expression e expr in + let%bind body' = type_annotated_expression e body in + let%bind () = + trace_strong (simple_error "while condition isn't of type bool") @@ + Ast_typed.assert_type_value_eq (t_bool () , get_type_annotation expr') in + let%bind () = + trace_strong (simple_error "while body isn't of unit type") @@ + Ast_typed.assert_type_value_eq (t_unit () , get_type_annotation body') in + return (O.E_loop (expr' , body')) (t_unit ()) + | E_assign (name , path , expr) -> + let%bind typed_name = + let%bind ele = + trace_option (simple_error "missing var in env") @@ + Environment.get_opt name e in + ok @@ make_n_t name ele.type_value in + let%bind (assign_tv , path') = + let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path -> + match cur_path with + | Access_tuple index -> ( + let%bind tpl = get_t_tuple prec_tv in + let%bind tv' = + trace_option (simple_error "tuple too small") @@ + List.nth_opt tpl index in + ok (tv' , prec_path @ [O.Access_tuple index]) + ) + | Access_record property -> ( + let%bind m = get_t_record prec_tv in + let%bind tv' = + trace_option (simple_error "tuple too small") @@ + Map.String.find_opt property m in + ok (tv' , prec_path @ [O.Access_record property]) + ) + | Access_map _ -> simple_fail "no assign expressions with maps yet" + in + bind_fold_list aux (typed_name.type_value , []) path in + let%bind expr' = type_annotated_expression e expr in + let%bind () = + trace_strong (simple_error "assign type doesn't match left-hand-side") @@ + Ast_typed.assert_type_value_eq (assign_tv , get_type_annotation expr') in + return (O.E_assign (typed_name , path' , expr')) (t_unit ()) + and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result = (* Constant poorman's polymorphism *) @@ -679,6 +728,9 @@ let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_ex | E_failwith ae -> let%bind ae' = untype_annotated_expression ae in return (E_failwith ae') + | E_sequence _ + | E_loop _ + | E_assign _ -> simple_fail "not possible to untranspile statements yet" and untype_block (b:O.block) : (I.block) result = bind_list @@ List.map untype_instruction b