Source file compile_with_exceptions.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
open Catala_utils
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
let arg_t = Marked.mark pos (TLit TUnit) in
Expr.make_abs [| dummy_var |] e [arg_t] pos
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
in
let pos = Expr.mark_pos mark_default in
let exceptions =
Expr.make_app
(Expr.make_var
(Var.translate A.handle_default)
(Expr.with_ty mark_default (Marked.mark pos TAny)))
[
Expr.earray exceptions mark_default;
thunk_expr (translate_expr ctx just);
thunk_expr (translate_expr ctx cons);
]
pos
in
exceptions
and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
| EVar v -> Expr.make_var (translate_var v) m
| EStruct { name; fields } ->
Expr.estruct name (StructField.Map.map (translate_expr ctx) fields) m
| EStructAccess { name; e; field } ->
Expr.estructaccess (translate_expr ctx e) field name m
| ETuple es -> Expr.etuple (List.map (translate_expr ctx) es) m
| ETupleAccess { e; index; size } ->
Expr.etupleaccess (translate_expr ctx e) index size m
| EInj { name; e; cons } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { name; e; cases } ->
Expr.ematch (translate_expr ctx e) name
(EnumConstructor.Map.map (translate_expr ctx) cases)
m
| EArray es -> Expr.earray (List.map (translate_expr ctx) es) m
| ELit
((LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
l) ->
Expr.elit l m
| ELit LEmptyError -> Expr.eraise EmptyError m
| EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
m
| EAssert e1 -> Expr.eassert (translate_expr ctx e1) m
| EErrorOnEmpty arg ->
Expr.ecatch (translate_expr ctx arg) EmptyError
(Expr.eraise NoValueProvided m)
m
| EApp { f; args } ->
Expr.eapp (translate_expr ctx f)
(List.map (translate_expr ctx) args)
(Marked.get_mark e)
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let new_body = translate_expr ctx body in
let new_binder = Expr.bind (Array.map translate_var vars) new_body in
Expr.eabs new_binder tys (Marked.get_mark e)
| EDefault { excepts = [exn]; just; cons } when !Cli.optimize_flag ->
Expr.ecatch (translate_expr ctx exn) EmptyError
(Expr.eifthenelse (translate_expr ctx just) (translate_expr ctx cons)
(Expr.eraise EmptyError (Marked.get_mark e))
(Marked.get_mark e))
(Marked.get_mark e)
| EDefault { excepts; just; cons } ->
translate_default ctx excepts just cons (Marked.get_mark 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;
}