diff --git a/Makefile b/Makefile index b4d09465..8a33a6fa 100644 --- a/Makefile +++ b/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 diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 034745f6..d29c9661 100644 --- a/build_system/clerk_driver.ml +++ b/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: diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 6ca82092..b2ee26e0 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/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 diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index 24551600..8e1b0607 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/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) : diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 25c35b11..a8d5be69 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/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 diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index b2adf058..e007471b 100644 --- a/compiler/shared_ast/definitions.ml +++ b/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 : { diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 4ca3b23b..41d9f525 100644 --- a/compiler/shared_ast/expr.ml +++ b/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 diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index a4c80fd5..018c621c 100644 --- a/compiler/shared_ast/expr.mli +++ b/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) -> diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 2810ae04..4a3bbbda 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/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, _ -> diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index 2f2e75a7..a55f9715 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/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) = diff --git a/dune b/dune index 415b1bbe..9be60db6 100644 --- a/dune +++ b/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)