Some small cleanup & QoL changes (#572)

Makefile

@@ -200,10 +200,10 @@ CLERK=$(CLERK_BIN) --exe $(CATALA_BIN) \
 .FORCE:
 
 unit-tests: .FORCE
-	dune runtest
+	dune build @for-tests @runtest
 
 #> tests					: Run interpreter tests
-tests: .FORCE prepare-install unit-tests
+tests: .FORCE unit-tests
 	@$(MAKE) -C tests pass_all_tests
 
 tests/%: .FORCE

build_system/clerk_driver.ml

@@ -616,7 +616,7 @@ let gen_build_statements
     | Some m ->
       let target ext = (!Var.builddir / src /../ m) ^ "." ^ ext in
       Nj.build "ocaml-module" ~inputs:[ml_file]
-        ~implicit_in:(List.map modd modules)
+        ~implicit_in:(!Var.catala_exe :: List.map modd modules)
         ~outputs:[target "cmxs"]
         ~implicit_out:(List.map target implicit_out_exts)
         ~vars:

compiler/dcalc/from_scopelang.ml

@@ -597,13 +597,10 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
   | EAppOp { op = Add_dat_dur _; args; tys } ->
     let args = List.map (translate_expr ctx) args in
     Expr.eappop ~op:(Add_dat_dur ctx.date_rounding) ~args ~tys m
-  | EAppOp { op; args; tys } ->
-    let args = List.map (translate_expr ctx) args in
-    Expr.eappop ~op:(Operator.translate op) ~args ~tys m
   | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
     | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _
-    | EIfThenElse _ ) as e ->
-    Expr.map ~f:(translate_expr ctx) (e, m)
+    | EIfThenElse _ | EAppOp _ ) as e ->
+    Expr.map ~f:(translate_expr ctx) ~op:Operator.translate (e, m)
 
 (** The result of a rule translation is a list of assignment, with variables and
     expressions. We also return the new translation context available after the

compiler/lcalc/compile_with_exceptions.ml

@@ -20,9 +20,8 @@ module D = Dcalc.Ast
 module A = Ast
 
 let rec translate_typ (tau : typ) : typ =
-  Mark.copy tau
-    begin
-      match Mark.remove tau with
+  Mark.map
+    (function
       | TDefault t -> Mark.remove (translate_typ t)
       | TLit l -> TLit l
       | TTuple ts -> TTuple (List.map translate_typ ts)
@@ -38,10 +37,10 @@ let rec translate_typ (tau : typ) : typ =
            translation step."
       | TAny -> TAny
       | TArray ts -> TArray (translate_typ ts)
-      | TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2)
-    end
+      | TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2))
+    tau
 
-let translate_mark e = Expr.map_ty translate_typ (Mark.get e)
+let translate_mark m = Expr.map_ty translate_typ m
 
 let rec translate_default
     (exceptions : 'm D.expr list)
@@ -71,32 +70,26 @@ let rec translate_default
     mark_default
 
 and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
-  let m = translate_mark e in
-  match Mark.remove e with
-  | EEmptyError -> Expr.eraise EmptyError m
-  | EErrorOnEmpty arg ->
+  match e with
+  | EEmptyError, m -> Expr.eraise EmptyError (translate_mark m)
+  | EErrorOnEmpty arg, m ->
+    let m = translate_mark m in
     Expr.ecatch (translate_expr arg) EmptyError
       (Expr.eraise NoValueProvided m)
       m
-  | EDefault { excepts; just; cons } -> translate_default excepts just cons m
-  | EPureDefault e -> translate_expr e
-  (* As we need to translate types as well as terms, we cannot simply use
-     [Expr.map] for terms that contains types. *)
-  | EAbs { binder; tys } ->
-    let tys = List.map translate_typ tys in
-    Expr.map ~f:translate_expr (EAbs { binder; tys }, m)
-  | EApp { f; args; tys } ->
-    let tys = List.map translate_typ tys in
-    Expr.map ~f:translate_expr (EApp { f; args; tys }, m)
-  | EAppOp { op; args; tys } ->
+  | EDefault { excepts; just; cons }, m ->
+    translate_default excepts just cons (translate_mark m)
+  | EPureDefault e, _ -> translate_expr e
+  | EAppOp { op; args; tys }, m ->
     Expr.eappop ~op:(Operator.translate op)
       ~args:(List.map translate_expr args)
       ~tys:(List.map translate_typ tys)
-      m
-  | ( ELit _ | EArray _ | EVar _ | EExternal _ | EIfThenElse _ | ETuple _
-    | ETupleAccess _ | EInj _ | EAssert _ | EStruct _ | EStructAccess _
-    | EMatch _ ) as e ->
-    Expr.map ~f:translate_expr (Mark.add m e)
+      (translate_mark m)
+  | ( ( ELit _ | EArray _ | EVar _ | EAbs _ | EApp _ | EExternal _
+      | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _
+      | EStruct _ | EStructAccess _ | EMatch _ ),
+      _ ) as e ->
+    Expr.map ~f:translate_expr ~typ:translate_typ e
   | _ -> .
 
 let translate_scope_body_expr (scope_body_expr : 'expr1 scope_body_expr) :

compiler/lcalc/compile_without_exceptions.ml

@@ -50,7 +50,7 @@ let rec translate_typ (tau : typ) : typ =
       | TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2)
     end
 
-let translate_mark e = Expr.map_ty translate_typ (Mark.get e)
+let translate_mark m = Expr.map_ty translate_typ m
 
 let rec translate_default
     (exceptions : 'm D.expr list)
@@ -82,52 +82,45 @@ let rec translate_default
     mark_default
 
 and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
-  let mark = translate_mark e in
-  match Mark.remove e with
-  | EEmptyError ->
+  match e with
+  | EEmptyError, m ->
+    let m = translate_mark m in
+    let pos = Expr.mark_pos m in
     Expr.einj
-      ~e:(Expr.elit LUnit (Expr.with_ty mark (TLit TUnit, Expr.mark_pos mark)))
-      ~cons:Expr.none_constr ~name:Expr.option_enum mark
-  | EErrorOnEmpty arg ->
-    let pos = Expr.mark_pos mark in
+      ~e:(Expr.elit LUnit (Expr.with_ty m (TLit TUnit, pos)))
+      ~cons:Expr.none_constr ~name:Expr.option_enum m
+  | EErrorOnEmpty arg, m ->
+    let m = translate_mark m in
+    let pos = Expr.mark_pos m in
     let cases =
       EnumConstructor.Map.of_list
         [
           ( Expr.none_constr,
             let x = Var.make "_" in
             Expr.make_abs [| x |]
-              (Expr.eraise NoValueProvided mark)
+              (Expr.eraise NoValueProvided m)
               [TAny, pos]
-              (Expr.mark_pos mark) );
+              pos );
           (* | None x -> raise NoValueProvided *)
-          Expr.some_constr, Expr.fun_id ~var_name:"arg" mark (* | Some x -> x *);
+          Expr.some_constr, Expr.fun_id ~var_name:"arg" m (* | Some x -> x *);
         ]
     in
-    Expr.ematch ~e:(translate_expr arg) ~name:Expr.option_enum ~cases mark
-  | EDefault { excepts; just; cons } -> translate_default excepts just cons mark
-  | EPureDefault e ->
+    Expr.ematch ~e:(translate_expr arg) ~name:Expr.option_enum ~cases m
+  | EDefault { excepts; just; cons }, m ->
+    translate_default excepts just cons (translate_mark m)
+  | EPureDefault e, m ->
     Expr.einj ~e:(translate_expr e) ~cons:Expr.some_constr
-      ~name:Expr.option_enum mark
-  (* As we need to translate types as well as terms, we cannot simply use
-     [Expr.map] for terms that contains types. *)
-  | EApp { f; args; tys } ->
-    let tys = List.map translate_typ tys in
-    Expr.map ~f:translate_expr (EApp { f; args; tys }, mark)
-  | EAppOp { op; tys; args } ->
+      ~name:Expr.option_enum (translate_mark m)
+  | EAppOp { op; tys; args }, m ->
     Expr.eappop ~op:(Operator.translate op)
       ~tys:(List.map translate_typ tys)
       ~args:(List.map translate_expr args)
-      mark
-  | EAbs { binder; tys } ->
-    let vars, body = Bindlib.unmbind binder in
-    let body = translate_expr body in
-    let binder = Expr.bind (Array.map Var.translate vars) body in
-    let tys = List.map translate_typ tys in
-    Expr.eabs binder tys mark
-  | ( ELit _ | EArray _ | EVar _ | EExternal _ | EIfThenElse _ | ETuple _
-    | ETupleAccess _ | EInj _ | EAssert _ | EStruct _ | EStructAccess _
-    | EMatch _ ) as e ->
-    Expr.map ~f:translate_expr (Mark.add mark e)
+      (translate_mark m)
+  | ( ( ELit _ | EArray _ | EVar _ | EApp _ | EAbs _ | EExternal _
+      | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _
+      | EStruct _ | EStructAccess _ | EMatch _ ),
+      _ ) as e ->
+    Expr.map ~f:translate_expr ~typ:translate_typ e
   | _ -> .
 
 let translate_scope_body_expr

compiler/shared_ast/definitions.ml

@@ -485,11 +485,11 @@ and ('a, 'b, 'm) base_gexpr =
     }
       -> ('a, < .. >, 'm) base_gexpr
   | EAppOp : {
-      op : 'b operator;
+      op : 'a operator;
       args : ('a, 'm) gexpr list;
       tys : typ list;
     }
-      -> ('a, (< .. > as 'b), 'm) base_gexpr
+      -> ('a, < .. >, 'm) base_gexpr
   | EArray : ('a, 'm) gexpr list -> ('a, < .. >, 'm) base_gexpr
   | EVar : ('a, 'm) naked_gexpr Bindlib.var -> ('a, _, 'm) base_gexpr
   | EAbs : {

compiler/shared_ast/expr.ml

@@ -265,13 +265,17 @@ let option_enum_config =
 (* shallow map *)
 let map
     (type a b)
+    ?(typ : typ -> typ = Fun.id)
+    ?op:(fop = (fun _ -> invalid_arg "Expr.map" : a Operator.t -> b Operator.t))
     ~(f : (a, 'm1) gexpr -> (b, 'm2) boxed_gexpr)
     (e : ((a, b, 'm1) base_gexpr, 'm2) marked) : (b, 'm2) boxed_gexpr =
-  let m = Mark.get e in
+  let m = map_ty typ (Mark.get e) in
   match Mark.remove e with
   | ELit l -> elit l m
-  | EApp { f = e1; args; tys } -> eapp ~f:(f e1) ~args:(List.map f args) ~tys m
-  | EAppOp { op; tys; args } -> eappop ~op ~tys ~args:(List.map f args) m
+  | EApp { f = e1; args; tys } ->
+    eapp ~f:(f e1) ~args:(List.map f args) ~tys:(List.map typ tys) m
+  | EAppOp { op; tys; args } ->
+    eappop ~op:(fop op) ~tys:(List.map typ tys) ~args:(List.map f args) m
   | EArray args -> earray (List.map f args) m
   | EVar v -> evar (Var.translate v) m
   | EExternal { name } -> eexternal ~name m
@@ -279,6 +283,7 @@ let map
     let vars, body = Bindlib.unmbind binder in
     let body = f body in
     let binder = bind (Array.map Var.translate vars) body in
+    let tys = List.map typ tys in
     eabs binder tys m
   | EIfThenElse { cond; etrue; efalse } ->
     eifthenelse (f cond) (f etrue) (f efalse) m
@@ -306,9 +311,10 @@ let map
   | EScopeCall { scope; args } ->
     let args = ScopeVar.Map.map f args in
     escopecall ~scope ~args m
-  | ECustom { obj; targs; tret } -> ecustom obj targs tret m
+  | ECustom { obj; targs; tret } ->
+    ecustom obj (List.map typ targs) (typ tret) m
 
-let rec map_top_down ~f e = map ~f:(map_top_down ~f) (f e)
+let rec map_top_down ~f e = map ~f:(map_top_down ~f) ~op:Fun.id (f e)
 let map_marks ~f e = map_top_down ~f:(Mark.map_mark f) e
 
 (* Folds the given function on the direct children of the given expression. *)
@@ -456,7 +462,7 @@ let map_gather
 (* - *)
 
 (** See [Bindlib.box_term] documentation for why we are doing that. *)
-let rec rebox (e : ('a any, 't) gexpr) = map ~f:rebox e
+let rec rebox (e : ('a any, 't) gexpr) = map ~f:rebox ~op:Fun.id e
 
 let box e = Mark.map Bindlib.box e
 let unbox (e, m) = Bindlib.unbox e, m
@@ -778,7 +784,7 @@ let skip_wrappers : type a. (a, 'm) gexpr -> (a, 'm) gexpr = Print.skip_wrappers
 
 let remove_logging_calls e =
   let rec f e =
-    let e, m = map ~f e in
+    let e, m = map ~f ~op:Fun.id e in
     ( Bindlib.box_apply
         (function EAppOp { op = Log _; args = [(arg, _)]; _ } -> arg | e -> e)
         e,
@@ -856,7 +862,7 @@ let rename_vars
       let body = aux ctx body in
       let binder = bind vars body in
       eabs binder tys m
-    | e -> map ~f:(aux ctx) e
+    | e -> map ~f:(aux ctx) ~op:Fun.id e
   in
   let ctx =
     List.fold_left

compiler/shared_ast/expr.mli

@@ -233,6 +233,8 @@ val untype : ('a, 'm) gexpr -> ('a, untyped) boxed_gexpr
 (** {2 Traversal functions} *)
 
 val map :
+  ?typ:(typ -> typ) ->
+  ?op:('a operator -> 'b operator) ->
   f:(('a, 'm1) gexpr -> ('b, 'm2) boxed_gexpr) ->
   (('a, 'b, 'm1) base_gexpr, 'm2) marked ->
   ('b, 'm2) boxed_gexpr
@@ -265,7 +267,12 @@ val map :
     The [e] parameter passed to [map] here needs to have only the common cases
     in its shallow type, but can still contain any node from the starting AST
     deeper inside: this is where the second type parameter to [base_gexpr]
-    becomes useful. *)
+    becomes useful.
+
+    The [typ] argument, if specified, will apply a transformation both on type
+    annotations, if present, and on types appearing within the AST nodes.
+
+    The [op] argument must be specified for the [EAppOp] case to be handled. *)
 
 val map_top_down :
   f:(('a, 'm1) gexpr -> (('a, 'm1) naked_gexpr, 'm2) marked) ->

compiler/shared_ast/interpreter.ml

@@ -28,21 +28,6 @@ module Runtime = Runtime_ocaml.Runtime
 let is_empty_error : type a. (a, 'm) gexpr -> bool =
  fun e -> match Mark.remove e with EEmptyError -> true | _ -> false
 
-(** [e' = propagate_empty_error e f] return [EEmptyError] if [e] is
-    [EEmptyError], else it apply [f] on not-empty term [e]. *)
-let propagate_empty_error :
-    type a. (a, 'm) gexpr -> ((a, 'm) gexpr -> (a, 'm) gexpr) -> (a, 'm) gexpr =
- fun e f -> match e with (EEmptyError, _) as e -> e | e -> f e
-
-(** [e' = propagate_empty_error_list elist f] return [EEmptyError] if one lement
-    of [es] is [EEmptyError], else it apply [f] on not-empty term list [elist]. *)
-let propagate_empty_error_list elist f =
-  let rec aux acc = function
-    | [] -> f (List.rev acc)
-    | e :: r -> propagate_empty_error e (fun e -> aux (e :: acc) r)
-  in
-  aux [] elist
-
 (* TODO: we should provide a generic way to print logs, that work across the
    different backends: python, ocaml, javascript, and interpreter *)
 
@@ -171,8 +156,6 @@ let rec evaluate_operator
       op Expr.format
       (EAppOp { op; tys = []; args }, m)
   in
-  propagate_empty_error_list args
-  @@ fun args ->
   let open Runtime.Oper in
   Mark.add m
   @@
@@ -643,8 +626,6 @@ let rec evaluate_expr :
   | EApp { f = e1; args; _ } -> (
     let e1 = evaluate_expr ctx lang e1 in
     let args = List.map (evaluate_expr ctx lang) args in
-    propagate_empty_error e1
-    @@ fun e1 ->
     match Mark.remove e1 with
     | EAbs { binder; _ } ->
       if Bindlib.mbinder_arity binder = List.length args then
@@ -672,14 +653,10 @@ let rec evaluate_expr :
   | EAppOp { op; args; _ } ->
     let args = List.map (evaluate_expr ctx lang) args in
     evaluate_operator (evaluate_expr ctx lang) op m lang args
-  | EAbs { binder; tys } -> Expr.unbox (Expr.eabs (Bindlib.box binder) tys m)
-  | ELit _ as e -> Mark.add m e
-  (* | EAbs _ as e -> Marked.mark m e (* these are values *) *)
+  | EAbs _ | ELit _ | ECustom _ | EEmptyError -> e (* these are values *)
   | EStruct { fields = es; name } ->
     let fields, es = List.split (StructField.Map.bindings es) in
     let es = List.map (evaluate_expr ctx lang) es in
-    propagate_empty_error_list es
-    @@ fun es ->
     Mark.add m
       (EStruct
          {
@@ -689,8 +666,7 @@ let rec evaluate_expr :
            name;
          })
   | EStructAccess { e; name = s; field } -> (
-    propagate_empty_error (evaluate_expr ctx lang e)
-    @@ fun e ->
+    let e = evaluate_expr ctx lang e in
     match Mark.remove e with
     | EStruct { fields = es; name } -> (
       if not (StructName.equal s name) then
@@ -722,11 +698,10 @@ let rec evaluate_expr :
         (Print.UserFacing.expr lang)
         e size)
   | EInj { e; name; cons } ->
-    propagate_empty_error (evaluate_expr ctx lang e)
-    @@ fun e -> Mark.add m (EInj { e; name; cons })
+    let e = evaluate_expr ctx lang e in
+    Mark.add m (EInj { e; name; cons })
   | EMatch { e; cases; name } -> (
-    propagate_empty_error (evaluate_expr ctx lang e)
-    @@ fun e ->
+    let e = evaluate_expr ctx lang e in
     match Mark.remove e with
     | EInj { e = e1; cons; name = name' } ->
       if not (EnumName.equal name name') then
@@ -752,8 +727,7 @@ let rec evaluate_expr :
         "Expected a term having a sum type as an argument to a match (should \
          not happen if the term was well-typed")
   | EIfThenElse { cond; etrue; efalse } -> (
-    propagate_empty_error (evaluate_expr ctx lang cond)
-    @@ fun cond ->
+    let cond = evaluate_expr ctx lang cond in
     match Mark.remove cond with
     | ELit (LBool true) -> evaluate_expr ctx lang etrue
     | ELit (LBool false) -> evaluate_expr ctx lang efalse
@@ -762,23 +736,21 @@ let rec evaluate_expr :
         "Expected a boolean literal for the result of this condition (should \
          not happen if the term was well-typed)")
   | EArray es ->
-    propagate_empty_error_list (List.map (evaluate_expr ctx lang) es)
-    @@ fun es -> Mark.add m (EArray es)
-  | EAssert e' ->
-    propagate_empty_error (evaluate_expr ctx lang e') (fun e ->
-        match Mark.remove e with
-        | ELit (LBool true) -> Mark.add m (ELit LUnit)
-        | ELit (LBool false) ->
-          Message.raise_spanned_error (Expr.pos e') "Assertion failed:@\n%a"
-            (Print.UserFacing.expr lang)
-            (partially_evaluate_expr_for_assertion_failure_message ctx lang
-               (Expr.skip_wrappers e'))
-        | _ ->
-          Message.raise_spanned_error (Expr.pos e')
-            "Expected a boolean literal for the result of this assertion \
-             (should not happen if the term was well-typed)")
-  | ECustom _ -> e
-  | EEmptyError -> Mark.copy e EEmptyError
+    let es = List.map (evaluate_expr ctx lang) es in
+    Mark.add m (EArray es)
+  | EAssert e' -> (
+    let e = evaluate_expr ctx lang e' in
+    match Mark.remove e with
+    | ELit (LBool true) -> Mark.add m (ELit LUnit)
+    | ELit (LBool false) ->
+      Message.raise_spanned_error (Expr.pos e') "Assertion failed:@\n%a"
+        (Print.UserFacing.expr lang)
+        (partially_evaluate_expr_for_assertion_failure_message ctx lang
+           (Expr.skip_wrappers e'))
+    | _ ->
+      Message.raise_spanned_error (Expr.pos e')
+        "Expected a boolean literal for the result of this assertion (should \
+         not happen if the term was well-typed)")
   | EErrorOnEmpty e' -> (
     match evaluate_expr ctx lang e' with
     | EEmptyError, _ ->

compiler/shared_ast/optimizations.ml

@@ -86,7 +86,7 @@ let rec optimize_expr :
     ((a, b) dcalc_lcalc, 'm) boxed_gexpr =
  fun ctx e ->
   (* We proceed bottom-up, first apply on the subterms *)
-  let e = Expr.map ~f:(optimize_expr ctx) e in
+  let e = Expr.map ~f:(optimize_expr ctx) ~op:Fun.id e in
   let mark = Mark.get e in
   (* Then reduce the parent node *)
   let reduce (e : ((a, b) dcalc_lcalc, 'm) gexpr) =

dune

@@ -52,6 +52,16 @@
  (name exec)
  (deps compiler/catala.exe build_system/clerk.exe))
 
+;; This alias contains the minimum requirements to run the tests. It's lighter than building @install which includes the (long) compilation of `catala.js`
+
+(alias
+ (name for-tests)
+ (deps
+  _build/install/default/bin/catala
+  _build/install/default/bin/clerk
+  _build/install/default/lib/catala/runtime_ocaml/runtime_ocaml.cmi
+  _build/install/default/lib/catala/runtime_ocaml/runtime_ocaml__Runtime.cmi))
+
 ;; This garbles Clerk output, prefer to run from Makefile
 ;; (rule
 ;;  (alias runtest)