CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Some code simplification (#487)

Browse Source
This commit is contained in:
Louis Gesbert 2023-07-05 12:01:06 +02:00 committed by GitHub
commit b63e7d2f2d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 9 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
compiler/lcalc/compile_with_exceptions.ml
View File

@ -19,11 +19,6 @@ open Shared_ast
module D = Dcalc.Ast
module A = Ast
type 'm ctx = unit
(** This translation no longer needs a context at the moment, but we keep
passing the argument through the functions in case the need arises with
further evolutions. *)
let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
let dummy_var = Var.make "_" in
let pos = Expr.pos e in
@ -33,13 +28,12 @@ let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
let translate_var : 'm D.expr Var.t -> 'm A.expr Var.t = Var.translate
let rec translate_default
(ctx : 'm ctx)
(exceptions : 'm D.expr list)
(just : 'm D.expr)
(cons : 'm D.expr)
(mark_default : 'm mark) : 'm A.expr boxed =
let exceptions =
List.map (fun except -> thunk_expr (translate_expr ctx except)) exceptions
List.map (fun except -> thunk_expr (translate_expr except)) exceptions
in
let pos = Expr.mark_pos mark_default in
let exceptions =
@ -49,92 +43,29 @@ let rec translate_default
(Expr.no_mark mark_default))
[
Expr.earray exceptions mark_default;
thunk_expr (translate_expr ctx just);
thunk_expr (translate_expr ctx cons);
thunk_expr (translate_expr just);
thunk_expr (translate_expr cons);
]
pos
in
exceptions
and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
let m = Mark.get e in
match Mark.remove e with
| EEmptyError -> Expr.eraise EmptyError m
| EErrorOnEmpty arg ->
Expr.ecatch (translate_expr ctx arg) EmptyError
Expr.ecatch (translate_expr arg) EmptyError
(Expr.eraise NoValueProvided m)
m
| EDefault { excepts; just; cons } ->
translate_default ctx excepts just cons (Mark.get e)
translate_default excepts just cons (Mark.get e)
| EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
| ( ELit _ | EApp _ | EArray _ | EVar _ | EExternal _ | EAbs _ | EIfThenElse _
| ETuple _ | ETupleAccess _ | EInj _ | EAssert _ | EStruct _
| EStructAccess _ | EMatch _ ) as e ->
Expr.map ~f:(translate_expr ctx) (Mark.add m e)
Expr.map ~f:translate_expr (Mark.add m e)
| _ -> .
let rec translate_scope_lets
(decl_ctx : decl_ctx)
(ctx : 'm ctx)
(scope_lets : 'm D.expr scope_body_expr) :
'm A.expr scope_body_expr Bindlib.box =
match scope_lets with
| Result e ->
Bindlib.box_apply (fun e -> Result e) (Expr.Box.lift (translate_expr ctx e))
| ScopeLet scope_let ->
let scope_let_var, scope_let_next =
Bindlib.unbind scope_let.scope_let_next
in
let new_scope_let_expr = translate_expr ctx scope_let.scope_let_expr in
let new_scope_next = translate_scope_lets decl_ctx ctx scope_let_next in
let new_scope_next =
Bindlib.bind_var (translate_var scope_let_var) new_scope_next
in
Bindlib.box_apply2
(fun new_scope_next new_scope_let_expr ->
ScopeLet
{
scope_let_typ = scope_let.scope_let_typ;
scope_let_kind = scope_let.scope_let_kind;
scope_let_pos = scope_let.scope_let_pos;
scope_let_next = new_scope_next;
scope_let_expr = new_scope_let_expr;
})
new_scope_next
(Expr.Box.lift new_scope_let_expr)
let translate_items
(decl_ctx : decl_ctx)
(ctx : 'm ctx)
(scopes : 'm D.expr code_item_list) : 'm A.expr code_item_list Bindlib.box =
Scope.map_ctx
~f:
(fun ctx -> function
| Topdef (name, ty, e) ->
( ctx,
Bindlib.box_apply
(fun e -> Topdef (name, ty, e))
(Expr.Box.lift (translate_expr ctx e)) )
| ScopeDef (name, body) ->
let scope_input_var, body_expr =
Bindlib.unbind body.scope_body_expr
in
let new_scope_body_expr =
translate_scope_lets decl_ctx ctx body_expr
in
let new_body =
Bindlib.bind_var (translate_var scope_input_var) new_scope_body_expr
in
( ctx,
Bindlib.box_apply
(fun scope_body_expr ->
ScopeDef (name, { body with scope_body_expr }))
new_body ))
~varf:translate_var ctx scopes
let translate_program (prgm : 'm D.program) : 'm A.program =
{
code_items =
Bindlib.unbox (translate_items prgm.decl_ctx () prgm.code_items);
decl_ctx = prgm.decl_ctx;
}
let translate_program (prg : 'm D.program) : 'm A.program =
Bindlib.unbox (Program.map_exprs ~f:translate_expr ~varf:translate_var prg)