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

fixing runtime merge errors

Browse Source
This commit is contained in:
adelaett 2023-03-30 11:02:35 +02:00
parent 6dee3874cc
commit 61830bc348
5 changed files with 21 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.nix/catala.nix
View File

@ -25,6 +25,7 @@
, zarith_stubs_js
, cohttp-lwt-unix
, ppx_expect
, ocaml-crunch
}:
buildDunePackage {

3
compiler/driver.ml
View File

@ -337,7 +337,8 @@ let driver source_file (options : Cli.options) : int =
prgm
in
let prgm =
Shared_ast.Program.untype @@ Shared_ast.Typing.program prgm
Shared_ast.Program.untype
@@ Shared_ast.Typing.program ~leave_unresolved:false prgm
in
let prgm =
if options.closure_conversion then (

3
compiler/lcalc/compile_without_exceptions.ml
View File

@ -207,7 +207,8 @@ let trans_var ctx (x : 'm D.expr Var.t) : 'm Ast.expr Var.t =
new_
let trans_op : (dcalc, 'a) Op.t -> (lcalc, 'a) Op.t = Operator.translate
let trans_op : type m. (dcalc, m) Op.t -> (lcalc, m) Op.t =
fun op -> Operator.translate None op
let rec trans ctx (e : 'm D.expr) : (lcalc, 'm mark) boxed_gexpr =
let m = Marked.get_mark e in

3
compiler/lcalc/from_dcalc.ml
View File

@ -18,4 +18,5 @@ let translate_program_with_exceptions =
Compile_with_exceptions.translate_program
let translate_program_without_exceptions p =
Shared_ast.Typing.program (Compile_without_exceptions.translate_program p)
Shared_ast.Typing.program ~leave_unresolved:true
(Compile_without_exceptions.translate_program p)

23
compiler/shared_ast/typing.ml
View File

@ -68,11 +68,13 @@ let rec typ_to_ast ~leave_unresolved (ty : unionfind_typ) : A.typ =
"Internal error: typing at this point could not be resolved"
(* Checks that there are no type variables remaining *)
(* let rec all_resolved ty = match Marked.unmark (UnionFind.get (UnionFind.find
ty)) with | TAny _ -> false | TLit _ | TStruct _ | TEnum _ -> true | TOption
t1 | TArray t1 -> all_resolved t1 | TArrow (t1, t2) -> List.for_all
all_resolved t1 && all_resolved t2 | TTuple ts -> List.for_all all_resolved
ts *)
let rec all_resolved ty =
match Marked.unmark (UnionFind.get (UnionFind.find ty)) with
| TAny _ -> false
| TLit _ | TStruct _ | TEnum _ -> true
| TOption t1 | TArray t1 -> all_resolved t1
| TArrow (t1, t2) -> List.for_all all_resolved t1 && all_resolved t2
| TTuple ts -> List.for_all all_resolved ts
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
let ty' =
@ -525,14 +527,17 @@ and typecheck_expr_top_down :
when name = Definitions.option_enum && cons = Definitions.some_constr ->
let cell_type = unionfind (TAny (Any.fresh ())) in
let mark = uf_mark (unionfind (TOption cell_type)) in
let e_enum' = typecheck_expr_top_down ctx env cell_type e_enum in
let e_enum' =
typecheck_expr_top_down ~leave_unresolved ctx env cell_type e_enum
in
Expr.einj e_enum' cons name mark
| A.EInj { name; cons; e = e_enum }
when name = Definitions.option_enum && cons = Definitions.none_constr ->
let cell_type = unionfind (TAny (Any.fresh ())) in
let mark = uf_mark (unionfind (TOption cell_type)) in
let e_enum' =
typecheck_expr_top_down ctx env (unionfind (TLit TUnit)) e_enum
typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TLit TUnit))
e_enum
in
Expr.einj e_enum' cons name mark
| A.EInj { name; cons; e = e_enum } ->
@ -554,13 +559,13 @@ and typecheck_expr_top_down :
in
let t_ret = TAny (Any.fresh ()) in
let mark = uf_mark (unionfind ~pos:e t_ret) in
let e1' = typecheck_expr_top_down ctx env t_arg e1 in
let e1' = typecheck_expr_top_down ~leave_unresolved ctx env t_arg e1 in
let cases' =
A.EnumConstructor.MapLabels.merge cases cases_ty ~f:(fun _ e e_ty ->
match e, e_ty with
| Some e, Some e_ty ->
Some
(typecheck_expr_top_down ctx env
(typecheck_expr_top_down ~leave_unresolved ctx env
(unionfind ~pos:e
(TArrow ([unionfind ~pos:e e_ty], unionfind ~pos:e t_ret)))
e)