mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Typed defaults: translate types in scope lets as well in the new
compile without exception passe
This commit is contained in:
parent
f6027109d8
commit
576da177c5
@ -28,8 +28,6 @@ module A = Ast
|
||||
|
||||
The typing translation is to simply trnsform defult type into option types. *)
|
||||
|
||||
let translate_var : 'm D.expr Var.t -> 'm A.expr Var.t = Var.translate
|
||||
|
||||
let rec translate_typ (tau : typ) : typ =
|
||||
Mark.copy tau
|
||||
begin
|
||||
@ -103,6 +101,63 @@ and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
|
||||
Expr.map ~f:translate_expr (Mark.add mark e)
|
||||
| _ -> .
|
||||
|
||||
let translate_scope_body_expr (scope_body_expr : 'expr1 scope_body_expr) :
|
||||
'expr2 scope_body_expr Bindlib.box =
|
||||
Scope.fold_right_lets
|
||||
~f:(fun scope_let var_next acc ->
|
||||
Bindlib.box_apply2
|
||||
(fun scope_let_next scope_let_expr ->
|
||||
ScopeLet
|
||||
{
|
||||
scope_let with
|
||||
scope_let_next;
|
||||
scope_let_expr;
|
||||
scope_let_typ = translate_typ scope_let.scope_let_typ;
|
||||
})
|
||||
(Bindlib.bind_var (Var.translate var_next) acc)
|
||||
(Expr.Box.lift (translate_expr scope_let.scope_let_expr)))
|
||||
~init:(fun res ->
|
||||
Bindlib.box_apply
|
||||
(fun res -> Result res)
|
||||
(Expr.Box.lift (translate_expr res)))
|
||||
scope_body_expr
|
||||
|
||||
let translate_code_items scopes =
|
||||
let f = function
|
||||
| ScopeDef (name, body) ->
|
||||
let scope_input_var, scope_lets = Bindlib.unbind body.scope_body_expr in
|
||||
let new_body_expr = translate_scope_body_expr scope_lets in
|
||||
let new_body_expr =
|
||||
Bindlib.bind_var (Var.translate scope_input_var) new_body_expr
|
||||
in
|
||||
Bindlib.box_apply
|
||||
(fun scope_body_expr -> ScopeDef (name, { body with scope_body_expr }))
|
||||
new_body_expr
|
||||
| Topdef (name, typ, expr) ->
|
||||
Bindlib.box_apply
|
||||
(fun e -> Topdef (name, typ, e))
|
||||
(Expr.Box.lift (translate_expr expr))
|
||||
in
|
||||
Scope.map ~f ~varf:Var.translate scopes
|
||||
|
||||
let translate_program (prg : typed D.program) : untyped A.program =
|
||||
Program.untype
|
||||
@@ Bindlib.unbox (Program.map_exprs ~f:translate_expr ~varf:translate_var prg)
|
||||
@@ Bindlib.unbox
|
||||
@@ Bindlib.box_apply
|
||||
(fun code_items ->
|
||||
let ctx_enums =
|
||||
EnumName.Map.map
|
||||
(EnumConstructor.Map.map translate_typ)
|
||||
prg.decl_ctx.ctx_enums
|
||||
in
|
||||
let ctx_structs =
|
||||
StructName.Map.map
|
||||
(StructField.Map.map translate_typ)
|
||||
prg.decl_ctx.ctx_structs
|
||||
in
|
||||
{
|
||||
prg with
|
||||
code_items;
|
||||
decl_ctx = { prg.decl_ctx with ctx_enums; ctx_structs };
|
||||
})
|
||||
(translate_code_items prg.code_items)
|
||||
|
Loading…
Reference in New Issue
Block a user