Make the or if list empty phrase optional (#785)

.gitignore

@@ -13,7 +13,8 @@ legifrance_oauth*
 .ninja_*
 node_modules/
 build.ninja
-
+#*#
+.#*
 .envrc
 .direnv
 

compiler/desugared/from_surface.ml

@@ -859,7 +859,11 @@ let rec translate_expr
       ( ( S.AggregateArgExtremum { max; default; f = param_names, predicate },
           opos ),
         collection ) ->
-    let default = rec_helper default in
+    let default =
+      match default with
+      | Some dft -> rec_helper dft
+      | None -> Expr.efatalerror Runtime.ListEmpty (Untyped { pos = opos })
+    in
     let pos_dft = Expr.pos default in
     let collection =
       detuplify_list opos (List.map Mark.remove param_names) collection
@@ -913,7 +917,8 @@ let rec translate_expr
            ~args:[add_weight_f; collection] emark)
         (Expr.eappop ~op:(Reduce, opos)
            ~tys:[TAny, pos; TAny, pos; TAny, pos]
-           ~args:[reduce_f; default; Expr.evar weights_var emark]
+           ~args:
+             [reduce_f; Expr.thunk_term default; Expr.evar weights_var emark]
            emark)
         pos
     in
@@ -957,7 +962,11 @@ let rec translate_expr
       ~args:[f; init; collection] emark
   | CollectionOp ((AggregateExtremum { max; default }, opos), collection) ->
     let collection = rec_helper collection in
-    let default = rec_helper default in
+    let default =
+      match default with
+      | Some dft -> rec_helper dft
+      | None -> Expr.efatalerror Runtime.ListEmpty (Untyped { pos = opos })
+    in
     let op = if max then S.Gt KPoly else S.Lt KPoly in
     let op_f =
       (* fun x1 x2 -> if op x1 x2 then x1 else x2 *)
@@ -972,7 +981,7 @@ let rec translate_expr
     in
     Expr.eappop ~op:(Reduce, opos)
       ~tys:[TAny, pos; TAny, pos; TAny, pos]
-      ~args:[op_f; default; collection]
+      ~args:[op_f; Expr.thunk_term default; collection]
       emark
   | CollectionOp ((AggregateSum { typ }, opos), collection) ->
     let collection = rec_helper collection in
@@ -1002,7 +1011,7 @@ let rec translate_expr
     in
     Expr.eappop ~op:(Reduce, opos)
       ~tys:[TAny, pos; TAny, pos; TAny, pos]
-      ~args:[op_f; Expr.elit default_lit emark; collection]
+      ~args:[op_f; Expr.thunk_term (Expr.elit default_lit emark); collection]
       emark
   | CollectionOp ((Member { element = member }, opos), collection) ->
     let param_var = Var.make "collection_member" in

compiler/scalc/to_c.ml

@@ -300,12 +300,12 @@ let rec format_expression
       {
         op = ((Reduce | Fold), _) as op;
         args = [fct; base; arr];
-        tys = [_; aty; _];
+        tys = [(TArrow (_, rty), _); _; _];
       } ->
     (* Operators with a polymorphic return type need a cast *)
     Format.fprintf fmt "((%a)%a(%a,@ %a,@ %a))"
       (format_typ ~const:true ctx.decl_ctx ignore)
-      aty format_op op format_expression fct format_expression base
+      rty format_op op format_expression fct format_expression base
       format_expression arr
   | EAppOp
       { op = ((Add_dat_dur rounding | Sub_dat_dur rounding) as op), _; args; _ }

compiler/scalc/to_python.ml

@@ -588,6 +588,49 @@ let format_code_item ctx fmt = function
              (format_typ ctx) typ))
       func_params (format_block ctx) func_body
 
+let format_scope_calls ppf (p : Ast.program) =
+  let scopes_with_no_input =
+    List.fold_left
+      (fun acc -> function
+        | SScope
+            {
+              scope_body_func = { func_params = [(_, (TStruct ts, _))]; _ };
+              scope_body_var = var;
+              scope_body_name = name;
+              scope_body_visibility = _;
+            } ->
+          let input_struct =
+            StructName.Map.find ts p.ctx.decl_ctx.ctx_structs
+          in
+          if StructField.Map.is_empty input_struct then (var, name, ts) :: acc
+          else acc
+        | SVar _ | SFunc _ | SScope _ -> acc)
+      [] p.code_items
+    |> List.rev
+  in
+  if scopes_with_no_input = [] then ()
+  else
+    let () =
+      Message.debug "Generating entry points for scopes:@ %a"
+        (Format.pp_print_list ~pp_sep:Format.pp_print_space
+           (fun ppf (_, s, _) -> ScopeName.format ppf s))
+        scopes_with_no_input
+    in
+    Format.fprintf ppf "@,# Automatic Catala tests@,";
+    Format.fprintf ppf "@[<v 2>if __name__ == \"__main__\":";
+    List.iter
+      (fun (var, name, ts) ->
+        Format.fprintf ppf "@,print(\"Executing scope %a...\")" ScopeName.format
+          name;
+        Format.fprintf ppf "@,%a (%a());" FuncName.format var StructName.format
+          ts;
+        Format.fprintf ppf
+          "@,\
+           print(\"\\x1b[32m[RESULT]\\x1b[m Scope %a executed successfully.\")"
+          ScopeName.format name)
+      scopes_with_no_input;
+    Format.fprintf ppf "@]@,"
+
 let format_program
     (fmt : Format.formatter)
     (p : Ast.program)
@@ -613,4 +656,5 @@ let format_program
   format_ctx type_ordering fmt p.ctx;
   Format.pp_print_cut fmt ();
   Format.pp_print_list (format_code_item p.ctx) fmt p.code_items;
+  format_scope_calls fmt p;
   Format.pp_print_flush fmt ()

compiler/shared_ast/interpreter.ml

@@ -284,7 +284,10 @@ let rec evaluate_operator
       (List.map2
          (fun e1 e2 -> eval_application evaluate_expr f [e1; e2])
          es1 es2)
-  | Reduce, [_; default; (EArray [], _)] -> Mark.remove default
+  | Reduce, [_; default; (EArray [], _)] ->
+    Mark.remove
+      (eval_application evaluate_expr default
+         [ELit LUnit, Expr.with_ty m (TLit TUnit, pos)])
   | Reduce, [f; _; (EArray (x0 :: xn), _)] ->
     Mark.remove
       (List.fold_left

compiler/shared_ast/typing.ml

@@ -293,6 +293,7 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) :
   let any = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
   let any2 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
   let any3 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
+  let ut = lazy (UnionFind.make (TLit TUnit, pos)) in
   let bt = lazy (UnionFind.make (TLit TBool, pos)) in
   let it = lazy (UnionFind.make (TLit TInt, pos)) in
   let cet = lazy (UnionFind.make (TClosureEnv, pos)) in
@@ -308,7 +309,7 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) :
     | Map -> [[any] @-> any2; array any] @-> array any2
     | Map2 -> [[any; any2] @-> any3; array any; array any2] @-> array any3
     | Filter -> [[any] @-> bt; array any] @-> array any
-    | Reduce -> [[any; any] @-> any; any; array any] @-> any
+    | Reduce -> [[any; any] @-> any; [ut] @-> any; array any] @-> any
     | Concat -> [array any; array any] @-> array any
     | Log (PosRecordIfTrueBool, _) -> [bt] @-> bt
     | Log _ -> [any] @-> any
@@ -337,7 +338,8 @@ let polymorphic_op_return_type
     tret
   in
   match Mark.remove op, targs with
-  | (Fold | Reduce), [_; tau; _] -> tau
+  | Fold, [_; tau; _] -> tau
+  | Reduce, [tf; _; _] -> return_type tf 2
   | Eq, _ -> uf (TLit TBool)
   | Map, [tf; _] -> uf (TArray (return_type tf 1))
   | Map2, [tf; _; _] -> uf (TArray (return_type tf 2))

compiler/surface/ast.ml

@@ -155,10 +155,10 @@ and collection_op =
   (* it would be nice to remove the need for specifying the and here like for
      extremums, but we need an additionl overload for "neutral element for
      addition across types" *)
-  | AggregateExtremum of { max : bool; default : expression }
+  | AggregateExtremum of { max : bool; default : expression option }
   | AggregateArgExtremum of {
       max : bool;
-      default : expression;
+      default : expression option;
       f : lident Mark.pos list * expression;
     }
   | Fold of {

compiler/surface/lexer.cppo.ml

@@ -194,8 +194,8 @@ module R = Re.Pcre
 #ifndef MR_IS
   #define MR_IS MS_IS
 #endif
-#ifndef MR_LIST_EMPTY
-  #define MR_LIST_EMPTY MS_LIST_EMPTY
+#ifndef MR_OR_IF_LIST_EMPTY
+  #define MR_OR_IF_LIST_EMPTY MS_OR_IF_LIST_EMPTY
 #endif
 #ifndef MR_BUT_REPLACE
   #define MR_BUT_REPLACE MS_BUT_REPLACE
@@ -312,7 +312,7 @@ let token_list : (string * token) list =
     (MS_MAXIMUM, MAXIMUM);
     (MS_MINIMUM, MINIMUM);
     (MS_IS, IS);
-    (MS_LIST_EMPTY, LIST_EMPTY);
+    (MS_OR_IF_LIST_EMPTY, OR_IF_LIST_EMPTY);
     (MS_BUT_REPLACE, BUT_REPLACE);
     (MS_COMBINE, COMBINE);
     (MS_INITIALLY, INITIALLY);
@@ -576,9 +576,9 @@ let rec lex_code (lexbuf : lexbuf) : token =
   | MR_IS ->
       L.update_acc lexbuf;
       IS
-  | MR_LIST_EMPTY ->
+  | MR_OR_IF_LIST_EMPTY ->
       L.update_acc lexbuf;
-      LIST_EMPTY
+      OR_IF_LIST_EMPTY
   | MR_BUT_REPLACE ->
       L.update_acc lexbuf;
       BUT_REPLACE

compiler/surface/lexer_en.cppo.ml

@@ -76,8 +76,8 @@
 #define MS_MAXIMUM "maximum"
 #define MS_MINIMUM "minimum"
 #define MS_IS "is"
-#define MS_LIST_EMPTY "list empty"
-#define MR_LIST_EMPTY "list", space_plus, "empty"
+#define MS_OR_IF_LIST_EMPTY "or if list empty"
+#define MR_OR_IF_LIST_EMPTY "or", space_plus, "if", space_plus, "list", space_plus, "empty"
 #define MS_BUT_REPLACE "but replace"
 #define MR_BUT_REPLACE "but", space_plus, "replace"
 #define MS_COMBINE "combine"

compiler/surface/lexer_fr.cppo.ml

@@ -93,8 +93,8 @@
 #define MS_MAXIMUM "maximum"
 #define MS_MINIMUM "minimum"
 #define MS_IS "est"
-#define MS_LIST_EMPTY "liste vide"
-#define MR_LIST_EMPTY "liste", space_plus, "vide"
+#define MS_OR_IF_LIST_EMPTY "ou si liste vide"
+#define MR_OR_IF_LIST_EMPTY "ou", space_plus, "si", space_plus, "liste", space_plus, "vide"
 #define MS_BUT_REPLACE "mais en remplaçant"
 #define MR_BUT_REPLACE "mais", space_plus, "en", space_plus, "rempla", 0xE7, "ant"
 #define MS_COMBINE "combinaison de"

compiler/surface/lexer_pl.cppo.ml

@@ -86,8 +86,8 @@
 #define MS_MAXIMUM "maksimum"
 #define MS_MINIMUM "minimum"
 #define MS_IS "jest"
-#define MS_LIST_EMPTY "lista pusta"
-#define MR_LIST_EMPTY "lista", space_plus, "pusta"
+#define MS_OR_IF_LIST_EMPTY "lub jeżeli lista pusta"
+#define MR_OR_IF_LIST_EMPTY "lub", space_plus, "je", 0x017C, "eli", space_plus, "lista", space_plus, "pusta"
 #define MS_BUT_REPLACE "ale zastąpić"
 #define MR_BUT_REPLACE "ale", space_plus, "zast", 0x0105, "pi", 0x0107
 #define MS_COMBINE "łączyć"