CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Formatting

Browse Source
This commit is contained in:
Denis Merigoux 2024-02-01 17:22:42 +01:00
parent 54ca62a78e
commit d7e71885c1
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
3 changed files with 60 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
build_system/clerk_driver.ml
View File

@ -740,31 +740,27 @@ let gen_build_statements
Nj.build "post-test" Nj.build "post-test"
~outputs:[inc (srcv ^ label)] ~outputs:[inc (srcv ^ label)]
~inputs:[srcv; inc (srcv ^ "@out")] ~inputs:[srcv; inc (srcv ^ "@out")]
~implicit_in:["always"]; ~implicit_in:["always"]
in in
match item.legacy_tests with match item.legacy_tests with
| [] -> | [] ->
if item.has_inline_tests then [ inline_test "@test"; results ] if item.has_inline_tests then [inline_test "@test"; results] else []
else []
| legacy -> | legacy ->
let inline = let inline =
if item.has_inline_tests then [ inline_test "@inline" ] if item.has_inline_tests then [inline_test "@inline"] else []
else []
in in
inline @ inline
[ @ [
Nj.build "dir-tests" Nj.build "dir-tests"
~outputs:[inc (srcv ^ "@test")] ~outputs:[inc (srcv ^ "@test")]
~inputs: ~inputs:
( ((if item.has_inline_tests then [inc (srcv ^ "@inline")] else [])
(if item.has_inline_tests then [ inc (srcv ^ "@inline") ] else []) @ @ List.map
List.map (fun test ->
(fun test -> (!Var.builddir / legacy_test_reference test) ^ "@post")
(!Var.builddir / legacy_test_reference test) ^ "@post") legacy);
legacy results;
); ]
results;
]
in in
legacy_tests @ inline_tests @ tests legacy_tests @ inline_tests @ tests
in in

82
compiler/lcalc/monomorphize.ml
View File

@ -159,7 +159,11 @@ let collect_monomorphized_instances (prg : typed program) :
let acc = let acc =
Scope.fold_left Scope.fold_left
~init: ~init:
{ options = Type.Map.empty; tuples = Type.Map.empty; arrays = Type.Map.empty } {
options = Type.Map.empty;
tuples = Type.Map.empty;
arrays = Type.Map.empty;
}
~f:(fun acc item _ -> ~f:(fun acc item _ ->
match item with match item with
| Topdef (_, typ, e) -> collect_typ (collect_expr e acc) typ | Topdef (_, typ, e) -> collect_typ (collect_expr e acc) typ
@ -188,8 +192,7 @@ let rec monomorphize_typ
match Mark.remove typ with match Mark.remove typ with
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ | TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ
| TArray t1 -> | TArray t1 ->
( TStruct (Type.Map.find t1 monomorphized_instances.arrays).name, TStruct (Type.Map.find t1 monomorphized_instances.arrays).name, Mark.get typ
Mark.get typ )
| TDefault t1 -> | TDefault t1 ->
TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ
| TArrow (t1s, t2) -> | TArrow (t1s, t2) ->
@ -201,12 +204,13 @@ let rec monomorphize_typ
( TStruct (Type.Map.find typ monomorphized_instances.tuples).name, ( TStruct (Type.Map.find typ monomorphized_instances.tuples).name,
Mark.get typ ) Mark.get typ )
| TOption t1 -> | TOption t1 ->
( TEnum (Type.Map.find t1 monomorphized_instances.options).name, TEnum (Type.Map.find t1 monomorphized_instances.options).name, Mark.get typ
Mark.get typ )
let is_some c = let is_some c =
EnumConstructor.equal Expr.some_constr c || EnumConstructor.equal Expr.some_constr c
(assert (EnumConstructor.equal Expr.none_constr c); false) ||
(assert (EnumConstructor.equal Expr.none_constr c);
false)
(* We output a typed expr but the types in the output are wrong, it should be (* We output a typed expr but the types in the output are wrong, it should be
untyped and re-typed later. *) untyped and re-typed later. *)
@ -217,9 +221,7 @@ let rec monomorphize_expr
match Mark.remove e with match Mark.remove e with
| ETuple args -> | ETuple args ->
let new_args = List.map (monomorphize_expr monomorphized_instances) args in let new_args = List.map (monomorphize_expr monomorphized_instances) args in
let tuple_instance = let tuple_instance = Type.Map.find typ monomorphized_instances.tuples in
Type.Map.find typ monomorphized_instances.tuples
in
let fields = let fields =
StructField.Map.of_list StructField.Map.of_list
@@ List.map2 @@ List.map2
@ -229,9 +231,7 @@ let rec monomorphize_expr
Expr.estruct ~name:tuple_instance.name ~fields (Mark.get e) Expr.estruct ~name:tuple_instance.name ~fields (Mark.get e)
| ETupleAccess { e = e1; index; _ } -> | ETupleAccess { e = e1; index; _ } ->
let tuple_instance = let tuple_instance =
Type.Map.find Type.Map.find (Expr.ty e1) monomorphized_instances.tuples
(Expr.ty e1)
monomorphized_instances.tuples
in in
let new_e1 = monomorphize_expr monomorphized_instances e1 in let new_e1 = monomorphize_expr monomorphized_instances e1 in
Expr.estructaccess ~name:tuple_instance.name Expr.estructaccess ~name:tuple_instance.name
@ -255,16 +255,18 @@ let rec monomorphize_expr
let new_cases = let new_cases =
match new_cases with match new_cases with
| [(n1, e1); (n2, e2)] -> ( | [(n1, e1); (n2, e2)] -> (
let is_some c = let is_some c =
EnumConstructor.equal Expr.some_constr c || EnumConstructor.equal Expr.some_constr c
(assert (EnumConstructor.equal Expr.none_constr c); false) ||
in (assert (EnumConstructor.equal Expr.none_constr c);
match is_some n1, is_some n2 with false)
| true, false -> in
[option_instance.some_cons, e1; option_instance.none_cons, e2] match is_some n1, is_some n2 with
| false, true -> | true, false ->
[option_instance.some_cons, e2; option_instance.none_cons, e1] [option_instance.some_cons, e1; option_instance.none_cons, e2]
| _ -> failwith "should not happen") | false, true ->
[option_instance.some_cons, e2; option_instance.none_cons, e1]
| _ -> failwith "should not happen")
| _ -> failwith "should not happen" | _ -> failwith "should not happen"
in in
let new_cases = EnumConstructor.Map.of_list new_cases in let new_cases = EnumConstructor.Map.of_list new_cases in
@ -280,8 +282,7 @@ let rec monomorphize_expr
in in
let new_e1 = monomorphize_expr monomorphized_instances e1 in let new_e1 = monomorphize_expr monomorphized_instances e1 in
let new_cons = let new_cons =
if is_some cons if is_some cons then option_instance.some_cons
then option_instance.some_cons
else option_instance.none_cons else option_instance.none_cons
in in
Expr.einj ~name:option_instance.name ~e:new_e1 ~cons:new_cons (Mark.get e) Expr.einj ~name:option_instance.name ~e:new_e1 ~cons:new_cons (Mark.get e)
@ -405,23 +406,22 @@ let program (prg : typed program) :
} }
in in
let code_items = let code_items =
Bindlib.unbox @@ Bindlib.unbox
Scope.map @@ Scope.map
~f:(fun code_item -> ~f:(fun code_item ->
match code_item with match code_item with
| Topdef (name, typ, e) -> Bindlib.box (Topdef (name, typ, e)) | Topdef (name, typ, e) -> Bindlib.box (Topdef (name, typ, e))
| ScopeDef (name, body) -> | ScopeDef (name, body) ->
let s_var, scope_body = Bindlib.unbind body.scope_body_expr in let s_var, scope_body = Bindlib.unbind body.scope_body_expr in
Bindlib.box_apply Bindlib.box_apply
(fun scope_body_expr -> (fun scope_body_expr ->
ScopeDef (name, { body with scope_body_expr })) ScopeDef (name, { body with scope_body_expr }))
(Bindlib.bind_var s_var (Bindlib.bind_var s_var
(Scope.map_exprs_in_lets ~varf:Fun.id (Scope.map_exprs_in_lets ~varf:Fun.id
~transform_types: ~transform_types:(monomorphize_typ monomorphized_instances)
(monomorphize_typ monomorphized_instances) ~f:(monomorphize_expr monomorphized_instances)
~f:(monomorphize_expr monomorphized_instances) scope_body)))
scope_body))) ~varf:Fun.id prg.code_items
~varf:Fun.id prg.code_items
in in
let prg = Program.untype { prg with code_items } in let prg = Program.untype { prg with code_items } in
( prg, ( prg,

8
compiler/shared_ast/type.ml
View File

@ -94,11 +94,11 @@ let rec compare ty1 ty2 =
| _, TClosureEnv -> 1 | _, TClosureEnv -> 1
let rec arrow_return = function TArrow (_, b), _ -> arrow_return b | t -> t let rec arrow_return = function TArrow (_, b), _ -> arrow_return b | t -> t
let format = Print.typ_debug let format = Print.typ_debug
module Map = Map.Make (struct module Map = Map.Make (struct
type nonrec t = t type nonrec t = t
let compare = compare
let format = format let compare = compare
let format = format
end) end)