removes loops

src/passes/3-self_ast_simplified/helpers.ml

@@ -19,10 +19,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
   | E_look_up ab ->
       let%bind res = bind_fold_pair self init' ab in
       ok res
-  | E_loop {condition;body} ->
-      let ab = (condition,body) in 
-      let%bind res = bind_fold_pair self init' ab in
-      ok res
   | E_application {expr1;expr2} -> (
       let ab = (expr1,expr2) in
       let%bind res = bind_fold_pair self init' ab in
@@ -116,11 +112,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
       let%bind ab' = bind_map_pair self ab in
       return @@ E_look_up ab'
     )
-  | E_loop {condition;body} -> (
-      let ab = (condition,body) in
-      let%bind (a,b) = bind_map_pair self ab in
-      return @@ E_loop {condition = a; body = b}
-    )
   | E_ascription ascr -> (
       let%bind e' = self ascr.anno_expr in
       return @@ E_ascription {ascr with anno_expr=e'}
@@ -237,11 +228,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
       let%bind (res, ab') = bind_fold_map_pair self init' ab in
       ok (res, return @@ E_look_up ab')
     )
-  | E_loop {condition;body} -> (
-      let ab = (condition,body) in
-      let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
-      ok (res, return @@ E_loop {condition = a; body = b})
-    )
   | E_ascription ascr -> (
       let%bind (res,e') = self init' ascr.anno_expr in
       ok (res, return @@ E_ascription {ascr with anno_expr=e'})

src/passes/4-typer-new/typer.ml

@@ -159,14 +159,6 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
-    let title = (thunk "not supported yet") in
-    let message () = message in
-    let data = [
-      ("expression" , fun () -> Format.asprintf "%a"  O.PP.expression ae)
-    ] in
-    error ~data title message ()
-
 end
 
 open Errors
@@ -734,11 +726,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
    *       tv_opt in
    *     return (O.E_matching (ex', m')) tv
    *   ) *)
-  | E_loop {condition; body} ->
-    let%bind (expr' , state') = type_expression e state condition in
-    let%bind (body' , state'') = type_expression e state' body in
-    let wrapped = Wrap.loop expr'.type_expression body'.type_expression in
-    return_wrapped (O.E_loop {condition=expr';body=body'}) state'' wrapped
   | E_let_in {let_binder ; rhs ; let_result; inline} ->
     let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
     (* TODO: the binder annotation should just be an annotation node *)
@@ -1100,7 +1087,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
   (* | E_failwith ae ->
    *   let%bind ae' = untype_expression ae in
    *   return (e_failwith ae') *)
-  | E_loop _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
   | E_let_in {let_binder; rhs;let_result; inline} ->
     let%bind tv = untype_type_value rhs.type_expression in
     let%bind rhs = untype_expression rhs in

src/passes/4-typer-new/typer.ml.old

@@ -675,28 +675,6 @@ and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression -
                       a'.location) @@
       Ast_typed.assert_type_expression_eq (t_unit () , a'_type_annot) in
     return (O.E_sequence (a' , b')) (get_type_annotation b')
-  | E_loop (expr , body) ->
-    let%bind expr' = type_expression e expr in
-    let%bind body' = type_expression e body in
-    let t_expr' = get_type_annotation expr' in
-    let%bind () =
-      trace_strong (type_error
-                      ~msg:"while condition isn't of type bool"
-                      ~expected:(O.t_bool ())
-                      ~actual:t_expr'
-                      ~expression:expr
-                      expr'.location) @@
-      Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in
-    let t_body' = get_type_annotation body' in
-    let%bind () =
-      trace_strong (type_error
-                     ~msg:"while body isn't of unit type"
-                     ~expected:(O.t_unit ())
-                     ~actual:t_body'
-                     ~expression:body
-                     body'.location) @@
-      Ast_typed.assert_type_expression_eq (t_unit () , t_body') in
-    return (O.E_loop (expr' , body')) (t_unit ())
   | E_assign (name , path , expr) ->
     let%bind typed_name =
       let%bind ele = Environment.get_trace name e in
@@ -834,7 +812,6 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
       let%bind ae' = untype_expression ae in
       return (e_failwith ae')
   | E_sequence _
-  | E_loop _
   | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
   | E_let_in {binder;rhs;result} ->
       let%bind tv = untype_type_expression rhs.type_annotation in

src/passes/4-typer-old/typer.ml

@@ -205,14 +205,6 @@ module Errors = struct
     ] in
     error ~data title message ()
 
-  let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
-    let title = (thunk "not suported yet") in
-    let message () = message in
-    let data = [
-      ("expression" , fun () -> Format.asprintf "%a"  O.PP.expression ae)
-    ] in
-    error ~data title message ()
-
 end
 open Errors
 
@@ -774,28 +766,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
         tv_opt in
       return (O.E_matching {matchee=ex'; cases=m'}) tv
     )
-  | E_loop {condition; body} ->
-    let%bind expr' = type_expression' e condition in
-    let%bind body' = type_expression' e body in
-    let t_expr' = get_type_expression expr' in
-    let%bind () =
-      trace_strong (type_error
-                      ~msg:"while condition isn't of type bool"
-                      ~expected:(O.t_bool ())
-                      ~actual:t_expr'
-                      ~expression:condition
-                      expr'.location) @@
-      Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in
-    let t_body' = get_type_expression body' in
-    let%bind () =
-      trace_strong (type_error
-                     ~msg:"while body isn't of unit type"
-                     ~expected:(O.t_unit ())
-                     ~actual:t_body'
-                     ~expression:body
-                     body'.location) @@
-      Ast_typed.assert_type_expression_eq (t_unit () , t_body') in
-    return (O.E_loop {condition=expr'; body=body'}) (t_unit ())
   | E_let_in {let_binder ; rhs ; let_result; inline} ->
     let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
     let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in
@@ -909,7 +879,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
       let%bind ae' = untype_expression matchee in
       let%bind m' = untype_matching untype_expression cases in
       return (e_matching ae' m')
-  | E_loop _-> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
   | E_let_in {let_binder;rhs;let_result; inline} ->
       let%bind tv = untype_type_expression rhs.type_expression in
       let%bind rhs = untype_expression rhs in

src/passes/5-self_ast_typed/helpers.ml

@@ -19,10 +19,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
   | E_look_up ab ->
       let%bind res = bind_fold_pair self init' ab in
       ok res
-  | E_loop {condition;body} ->
-      let ab = (condition,body) in 
-      let%bind res = bind_fold_pair self init' ab in
-      ok res
   | E_application {expr1;expr2} -> (
       let ab = (expr1,expr2) in
       let%bind res = bind_fold_pair self init' ab in
@@ -116,11 +112,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
       let%bind ab' = bind_map_pair self ab in
       return @@ E_look_up ab'
     )
-  | E_loop {condition;body} -> (
-      let ab = (condition,body) in
-      let%bind (a,b) = bind_map_pair self ab in
-      return @@ E_loop {condition = a; body = b}
-    )
   | E_matching {matchee=e;cases} -> (
       let%bind e' = self e in
       let%bind cases' = map_cases f cases in
@@ -232,11 +223,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
       let%bind (res, ab') = bind_fold_map_pair self init' ab in
       ok (res, return @@ E_look_up ab')
     )
-  | E_loop {condition;body} -> (
-      let ab = (condition,body) in
-      let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
-      ok (res, return @@ E_loop {condition = a; body = b})
-    )
   | E_matching {matchee=e;cases} -> (
       let%bind (res, e') = self init' e in
       let%bind (res,cases') = fold_map_cases f res cases in

src/passes/6-interpreter/interpreter.ml

@@ -371,7 +371,7 @@ and eval : Ast_typed.expression -> env -> value result
       | _ -> simple_fail "not yet supported case"
         (* ((ctor,name),body) *)
     )
-    | E_look_up _ | E_loop _ ->
+    | E_look_up _ ->
       let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
       simple_fail serr
 

src/passes/6-transpiler/transpiler.ml

@@ -431,11 +431,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
       let%bind (ds', i') = bind_map_pair f dsi in
       return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
     )
-  | E_loop {condition; body} -> (
-      let%bind expr' = transpile_annotated_expression condition in
-      let%bind body' = transpile_annotated_expression body in
-      return @@ E_while (expr' , body')
-    )
   | E_matching {matchee=expr; cases=m} -> (
       let%bind expr' = transpile_annotated_expression expr in
       match m with

src/stages/ast_simplified/PP.ml

@@ -48,8 +48,6 @@ let rec expression ppf (e : expression) =
   | E_matching {matchee; cases; _} ->
       fprintf ppf "match %a with %a" expression matchee (matching expression)
         cases
-  | E_loop l ->
-      fprintf ppf "while %a do %a" expression l.condition expression l.body
   | E_let_in { let_binder ; mut; rhs ; let_result; inline } ->    
     fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
   | E_skip ->

src/stages/ast_simplified/combinators.ml

@@ -122,7 +122,6 @@ let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; lab
 let e_accessor_list ?loc a b  = List.fold_left (fun a b -> e_accessor ?loc a b) a b
 let e_variable ?loc v = location_wrap ?loc @@ E_variable v
 let e_skip ?loc () = location_wrap ?loc @@ E_skip
-let e_loop ?loc condition body = location_wrap ?loc @@ E_loop {condition; body}
 let e_let_in ?loc (binder, ascr) mut inline rhs let_result = 
   location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
 let e_annotation ?loc anno_expr ty = location_wrap ?loc @@ E_ascription {anno_expr; type_annotation = ty}

src/stages/ast_simplified/combinators.mli

@@ -83,7 +83,6 @@ val e_accessor : ?loc:Location.t -> expression -> string -> expression
 val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
 val e_variable : ?loc:Location.t -> expression_variable -> expression
 val e_skip : ?loc:Location.t -> unit -> expression
-val e_loop : ?loc:Location.t -> expression -> expression -> expression
 val e_sequence : ?loc:Location.t -> expression -> expression -> expression
 val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
 val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression

src/stages/ast_simplified/misc.ml

@@ -184,7 +184,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
   | (E_application _, _) | (E_let_in _, _)
   | (E_record_accessor _, _)
   | (E_look_up _, _) | (E_matching _, _)
-  | (E_loop _, _) | (E_skip, _) -> simple_fail "comparing not a value"
+  | (E_skip, _) -> simple_fail "comparing not a value"
 
 let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)
 

src/stages/ast_simplified/types.ml

@@ -51,7 +51,6 @@ and expression_content =
   | E_set of expression list
   | E_look_up of (expression * expression)
   (* Advanced *)
-  | E_loop of loop
   | E_ascription of ascription
 
 and constant =
@@ -79,8 +78,6 @@ and accessor = {expr: expression; label: label}
 
 and update = {record: expression; path: label ; update: expression}
 
-and loop = {condition: expression; body: expression}
-
 and matching_expr = (expr,unit) matching_content
 and matching =
   { matchee: expression

src/stages/ast_typed/PP.ml

@@ -44,8 +44,6 @@ let rec expression ppf (e : expression) =
         expression result
   | E_matching {matchee; cases;} ->
       fprintf ppf "match %a with %a" expression matchee (matching expression) cases
-  | E_loop l ->
-      fprintf ppf "while %a do %a" expression l.condition expression l.body
   | E_let_in {let_binder; rhs; let_result; inline} ->
       fprintf ppf "let %a = %a%a in %a" expression_variable let_binder expression
         rhs option_inline inline expression let_result

src/stages/ast_typed/misc.ml

@@ -216,7 +216,6 @@ module Free_variables = struct
     | (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
     | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
     | E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
-    | E_loop {condition ; body} -> unions @@ List.map self [ condition ; body ]
     | E_let_in { let_binder; rhs; let_result; _} ->
       let b' = union (singleton let_binder) b in
       union
@@ -533,7 +532,7 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result =
   | (E_lambda _, _) | (E_let_in _, _)
   | (E_record_accessor _, _) | (E_record_update _,_)
   | (E_look_up _, _) | (E_matching _, _)
-  | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
+  -> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
 
 let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =
   match a, b with

src/stages/ast_typed/misc_smart.ml

@@ -89,9 +89,6 @@ module Captured_variables = struct
       let%bind a' = self matchee in
       let%bind cs' = matching_expression b cases in
       ok @@ union a' cs'
-    | E_loop {condition; body} ->
-      let%bind lst' = bind_map_list self [ condition ; body ] in
-      ok @@ unions lst'
     | E_let_in li ->
       let b' = union (singleton li.let_binder) b in
       expression b' li.let_result

src/stages/ast_typed/types.ml

@@ -55,14 +55,10 @@ and expression_content =
   | E_list of expression list
   | E_set of expression list
   | E_look_up of (expression * expression)
-  (* Advanced *)
-  | E_loop of loop
-  (* | E_ascription of ascription *)
 
-and constant = {
+and constant =
-    cons_name: constant' ;
+  { cons_name: constant'
-    arguments: expression list ;
+  ; arguments: expression list }
-  }
 
 and application = {expr1: expression; expr2: expression}
 
@@ -96,15 +92,10 @@ and update = {
     update: expression ;
   }
 
-and loop = {
+and matching_expr = (expression,type_expression) matching_content
-    condition: expression ;
+and matching =
-    body: expression ;
+  { matchee: expression
-  }
+  ; cases: matching_expr
-
-and matching_expr = (expression, type_expression) matching_content
-and matching = {
-    matchee: expression ;
-    cases: matching_expr ;
   }
 
 and ascription = {

src/stages/typesystem/misc.ml

@@ -212,10 +212,6 @@ module Substitution = struct
         let%bind matchee = s_expression ~substs matchee in
         let%bind cases = s_matching_expr ~substs cases in
         ok @@ T.E_matching {matchee;cases}
-      | T.E_loop  {condition;body} ->
-        let%bind condition = s_expression ~substs condition in
-        let%bind body = s_expression ~substs body in
-        ok @@ T.E_loop {condition;body}
 
     and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } ->
       let%bind expression_content = s_expression_content ~substs expression_content in