preparations for statements removal

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

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

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
 

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

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

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

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) *)
 

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

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