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

Merge branch 'master' of github.com:CatalaLang/catala into dates_calc_lib

Browse Source
This commit is contained in:
Raphaël Monat 2022-08-30 15:14:51 +02:00
commit f60cfcc435
106 changed files with 7033 additions and 8162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -303,10 +303,10 @@ CLERK=$(CLERK_BIN) --exe $(CATALA_BIN) \
.FORCE:
test_suite: .FORCE
OCAMLRUNPARAM= $(CLERK) test tests
$(MAKE) -C tests pass_all_tests
test_examples: .FORCE
OCAMLRUNPARAM= $(CLERK) test examples
$(MAKE) -C examples pass_all_tests
#> tests : Run interpreter tests
tests: test_suite test_examples

426
compiler/dcalc/ast.ml
View File

@ -15,429 +15,11 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
include Astgen
include Astgen_utils
open Shared_ast
type lit = dcalc glit
type 'm expr = (dcalc, 'm mark) gexpr
and 'm marked_expr = (dcalc, 'm mark) marked_gexpr
type 'm naked_expr = (dcalc, 'm mark) naked_gexpr
and 'm expr = (dcalc, 'm mark) gexpr
type 'm program = ('m expr, 'm) program_generic
let no_mark (type m) : m mark -> m mark = function
| Untyped _ -> Untyped { pos = Pos.no_pos }
| Typed _ -> Typed { pos = Pos.no_pos; ty = Marked.mark Pos.no_pos TAny }
let mark_pos (type m) (m : m mark) : Pos.t =
match m with Untyped { pos } | Typed { pos; _ } -> pos
let pos (type m) (x : ('a, m) marked) : Pos.t = mark_pos (Marked.get_mark x)
let ty (_, m) : marked_typ = match m with Typed { ty; _ } -> ty
let with_ty (type m) (ty : marked_typ) (x : ('a, m) marked) : ('a, typed) marked
=
Marked.mark
(match Marked.get_mark x with
| Untyped { pos } -> Typed { pos; ty }
| Typed m -> Typed { m with ty })
(Marked.unmark x)
let map_expr ctx ~f e = Astgen_utils.map_gexpr ctx ~f e
let rec map_expr_top_down ~f e =
map_expr () ~f:(fun () -> map_expr_top_down ~f) (f e)
let map_expr_marks ~f e =
map_expr_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
let untype_expr e = map_expr_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e
type ('expr, 'm) box_expr_sig =
('expr, 'm) marked -> ('expr, 'm) marked Bindlib.box
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let box_expr : ('m expr, 'm) box_expr_sig =
fun e ->
let rec id_t () e = map_expr () ~f:id_t e in
id_t () e
open Astgen_utils
let untype_program prg =
{
prg with
scopes =
Bindlib.unbox
(map_exprs_in_scopes
~f:(fun e -> untype_expr e)
~varf:Var.translate prg.scopes);
}
type 'm var = 'm expr Var.t
type 'm vars = 'm expr Var.vars
let rec free_vars_expr (e : 'm marked_expr) : 'm expr Var.Set.t =
match Marked.unmark e with
| EVar v -> Var.Set.singleton v
| ETuple (es, _) | EArray es ->
es |> List.map free_vars_expr |> List.fold_left Var.Set.union Var.Set.empty
| ETupleAccess (e1, _, _, _)
| EAssert e1
| ErrorOnEmpty e1
| EInj (e1, _, _, _) ->
free_vars_expr e1
| EApp (e1, es) | EMatch (e1, es, _) ->
e1 :: es
|> List.map free_vars_expr
|> List.fold_left Var.Set.union Var.Set.empty
| EDefault (es, ejust, econs) ->
ejust :: econs :: es
|> List.map free_vars_expr
|> List.fold_left Var.Set.union Var.Set.empty
| EOp _ | ELit _ -> Var.Set.empty
| EIfThenElse (e1, e2, e3) ->
[e1; e2; e3]
|> List.map free_vars_expr
|> List.fold_left Var.Set.union Var.Set.empty
| EAbs (binder, _) ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right Var.Set.remove vs (free_vars_expr body)
let rec free_vars_scope_body_expr (scope_lets : ('m expr, 'm) scope_body_expr) :
'm expr Var.Set.t =
match scope_lets with
| Result e -> free_vars_expr e
| ScopeLet { scope_let_expr = e; scope_let_next = next; _ } ->
let v, body = Bindlib.unbind next in
Var.Set.union (free_vars_expr e)
(Var.Set.remove v (free_vars_scope_body_expr body))
let free_vars_scope_body (scope_body : ('m expr, 'm) scope_body) :
'm expr Var.Set.t =
let { scope_body_expr = binder; _ } = scope_body in
let v, body = Bindlib.unbind binder in
Var.Set.remove v (free_vars_scope_body_expr body)
let rec free_vars_scopes (scopes : ('m expr, 'm) scopes) : 'm expr Var.Set.t =
match scopes with
| Nil -> Var.Set.empty
| ScopeDef { scope_body = body; scope_next = next; _ } ->
let v, next = Bindlib.unbind next in
Var.Set.union
(Var.Set.remove v (free_vars_scopes next))
(free_vars_scope_body body)
let make_var ((x, mark) : ('m expr Bindlib.var, 'm) marked) :
'm marked_expr Bindlib.box =
Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
type ('e, 'm) make_abs_sig =
'e Bindlib.mvar ->
('e, 'm) marked Bindlib.box ->
typ Marked.pos list ->
'm mark ->
('e, 'm) marked Bindlib.box
let (make_abs : ('m expr, 'm) make_abs_sig) =
fun xs e taus mark ->
Bindlib.box_apply (fun b -> EAbs (b, taus), mark) (Bindlib.bind_mvar xs e)
let make_app :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box =
fun e u mark ->
Bindlib.box_apply2 (fun e u -> EApp (e, u), mark) e (Bindlib.box_list u)
type ('expr, 'm) make_let_in_sig =
'expr Bindlib.var ->
typ Marked.pos ->
('expr, 'm) marked Bindlib.box ->
('expr, 'm) marked Bindlib.box ->
Pos.t ->
('expr, 'm) marked Bindlib.box
let map_mark
(type m)
(pos_f : Pos.t -> Pos.t)
(ty_f : marked_typ -> marked_typ)
(m : m mark) : m mark =
match m with
| Untyped { pos } -> Untyped { pos = pos_f pos }
| Typed { pos; ty } -> Typed { pos = pos_f pos; ty = ty_f ty }
let map_mark2
(type m)
(pos_f : Pos.t -> Pos.t -> Pos.t)
(ty_f : typed -> typed -> marked_typ)
(m1 : m mark)
(m2 : m mark) : m mark =
match m1, m2 with
| Untyped m1, Untyped m2 -> Untyped { pos = pos_f m1.pos m2.pos }
| Typed m1, Typed m2 -> Typed { pos = pos_f m1.pos m2.pos; ty = ty_f m1 m2 }
let fold_marks
(type m)
(pos_f : Pos.t list -> Pos.t)
(ty_f : typed list -> marked_typ)
(ms : m mark list) : m mark =
match ms with
| [] -> invalid_arg "Dcalc.Ast.fold_mark"
| Untyped _ :: _ as ms ->
Untyped { pos = pos_f (List.map (function Untyped { pos } -> pos) ms) }
| Typed _ :: _ ->
Typed
{
pos = pos_f (List.map (function Typed { pos; _ } -> pos) ms);
ty = ty_f (List.map (function Typed m -> m) ms);
}
let empty_thunked_term mark : 'm marked_expr =
let silent = Var.make "_" in
let pos = mark_pos mark in
Bindlib.unbox
(make_abs [| silent |]
(Bindlib.box (ELit LEmptyError, mark))
[TLit TUnit, pos]
(map_mark
(fun pos -> pos)
(fun ty ->
Marked.mark pos (TArrow (Marked.mark pos (TLit TUnit), ty)))
mark))
let (make_let_in : ('m expr, 'm) make_let_in_sig) =
fun x tau e1 e2 pos ->
let m_e1 = Marked.get_mark (Bindlib.unbox e1) in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (TArrow (m1.ty, m2.ty)))
m_e1 m_e2
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let is_value (e : 'e marked_expr) : bool =
match Marked.unmark e with ELit _ | EAbs _ | EOp _ -> true | _ -> false
let rec equal_typs (ty1 : typ Marked.pos) (ty2 : typ Marked.pos) : bool =
match Marked.unmark ty1, Marked.unmark ty2 with
| TLit l1, TLit l2 -> l1 = l2
| TTuple (tys1, n1), TTuple (tys2, n2) -> n1 = n2 && equal_typs_list tys1 tys2
| TEnum (tys1, n1), TEnum (tys2, n2) -> n1 = n2 && equal_typs_list tys1 tys2
| TArrow (t1, t1'), TArrow (t2, t2') -> equal_typs t1 t2 && equal_typs t1' t2'
| TArray t1, TArray t2 -> equal_typs t1 t2
| TAny, TAny -> true
| _, _ -> false
and equal_typs_list (tys1 : typ Marked.pos list) (tys2 : typ Marked.pos list) :
bool =
List.length tys1 = List.length tys2
&& (* OCaml && operator short-circuits when a clause is false, we can safely
assume here that both lists have equal length *)
List.for_all (fun (x, y) -> equal_typs x y) (List.combine tys1 tys2)
let equal_log_entries (l1 : log_entry) (l2 : log_entry) : bool =
match l1, l2 with
| VarDef t1, VarDef t2 -> equal_typs (t1, Pos.no_pos) (t2, Pos.no_pos)
| x, y -> x = y
let equal_unops (op1 : unop) (op2 : unop) : bool =
match op1, op2 with
(* Log entries contain a typ which contain position information, we thus need
to descend into them *)
| Log (l1, info1), Log (l2, info2) -> equal_log_entries l1 l2 && info1 = info2
(* All the other cases can be discharged through equality *)
| _ -> op1 = op2
let equal_ops (op1 : operator) (op2 : operator) : bool =
match op1, op2 with
| Ternop op1, Ternop op2 -> op1 = op2
| Binop op1, Binop op2 -> op1 = op2
| Unop op1, Unop op2 -> equal_unops op1 op2
| _, _ -> false
let rec equal_exprs (e1 : 'm marked_expr) (e2 : 'm marked_expr) : bool =
match Marked.unmark e1, Marked.unmark e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple (es1, n1), ETuple (es2, n2) -> n1 = n2 && equal_exprs_list es1 es2
| ETupleAccess (e1, id1, n1, tys1), ETupleAccess (e2, id2, n2, tys2) ->
equal_exprs e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
| EInj (e1, id1, n1, tys1), EInj (e2, id2, n2, tys2) ->
equal_exprs e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
n1 = n2 && equal_exprs e1 e2 && equal_exprs_list cases1 cases2
| EArray es1, EArray es2 -> equal_exprs_list es1 es2
| ELit l1, ELit l2 -> l1 = l2
| EAbs (b1, tys1), EAbs (b2, tys2) ->
equal_typs_list tys1 tys2
&&
let vars1, body1 = Bindlib.unmbind b1 in
let body2 = Bindlib.msubst b2 (Array.map (fun x -> EVar x) vars1) in
equal_exprs body1 body2
| EAssert e1, EAssert e2 -> equal_exprs e1 e2
| EOp op1, EOp op2 -> equal_ops op1 op2
| EDefault (exc1, def1, cons1), EDefault (exc2, def2, cons2) ->
equal_exprs def1 def2
&& equal_exprs cons1 cons2
&& equal_exprs_list exc1 exc2
| EIfThenElse (if1, then1, else1), EIfThenElse (if2, then2, else2) ->
equal_exprs if1 if2 && equal_exprs then1 then2 && equal_exprs else1 else2
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal_exprs e1 e2
| _, _ -> false
and equal_exprs_list (es1 : 'e marked_expr list) (es2 : 'm marked_expr list) :
bool =
List.length es1 = List.length es2
&& (* OCaml && operator short-circuits when a clause is false, we can safely
assume here that both lists have equal length *)
List.for_all (fun (x, y) -> equal_exprs x y) (List.combine es1 es2)
let rec unfold_scope_body_expr
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(scope_let : ('expr, 'm) scope_body_expr) : ('expr, 'm) marked Bindlib.box =
match scope_let with
| Result e -> box_expr e
| ScopeLet
{
scope_let_kind = _;
scope_let_typ;
scope_let_expr;
scope_let_next;
scope_let_pos;
} ->
let var, next = Bindlib.unbind scope_let_next in
make_let_in var scope_let_typ (box_expr scope_let_expr)
(unfold_scope_body_expr ~box_expr ~make_let_in ctx next)
scope_let_pos
let build_whole_scope_expr
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_abs : ('expr, 'm) make_abs_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(body : ('expr, 'm) scope_body)
(mark_scope : 'm mark) : ('expr, 'm) marked Bindlib.box =
let var, body_expr = Bindlib.unbind body.scope_body_expr in
let body_expr = unfold_scope_body_expr ~box_expr ~make_let_in ctx body_expr in
make_abs (Array.of_list [var]) body_expr
[
( TTuple
( List.map snd
(StructMap.find body.scope_body_input_struct ctx.ctx_structs),
Some body.scope_body_input_struct ),
mark_pos mark_scope );
]
mark_scope
let build_scope_typ_from_sig
(ctx : decl_ctx)
(scope_input_struct_name : StructName.t)
(scope_return_struct_name : StructName.t)
(pos : Pos.t) : typ Marked.pos =
let scope_sig = StructMap.find scope_input_struct_name ctx.ctx_structs in
let scope_return_typ =
StructMap.find scope_return_struct_name ctx.ctx_structs
in
let result_typ =
TTuple (List.map snd scope_return_typ, Some scope_return_struct_name), pos
in
let input_typ =
TTuple (List.map snd scope_sig, Some scope_input_struct_name), pos
in
TArrow (input_typ, result_typ), pos
type 'expr scope_name_or_var =
| ScopeName of ScopeName.t
| ScopeVar of 'expr Bindlib.var
let get_scope_body_mark scope_body =
match snd (Bindlib.unbind scope_body.scope_body_expr) with
| Result e | ScopeLet { scope_let_expr = e; _ } -> Marked.get_mark e
let rec unfold_scopes
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_abs : ('expr, 'm) make_abs_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(s : ('expr, 'm) scopes)
(mark : 'm mark)
(main_scope : 'expr scope_name_or_var) : ('expr, 'm) marked Bindlib.box =
match s with
| Nil -> (
match main_scope with
| ScopeVar v -> Bindlib.box_apply (fun v -> v, mark) (Bindlib.box_var v)
| ScopeName _ -> failwith "should not happen")
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, scope_next = Bindlib.unbind scope_next in
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
let scope_body_mark = get_scope_body_mark scope_body in
let main_scope =
match main_scope with
| ScopeVar v -> ScopeVar v
| ScopeName n ->
if ScopeName.compare n scope_name = 0 then ScopeVar scope_var
else ScopeName n
in
make_let_in scope_var
(build_scope_typ_from_sig ctx scope_body.scope_body_input_struct
scope_body.scope_body_output_struct scope_pos)
(build_whole_scope_expr ~box_expr ~make_abs ~make_let_in ctx scope_body
scope_body_mark)
(unfold_scopes ~box_expr ~make_abs ~make_let_in ctx scope_next mark
main_scope)
scope_pos
let rec find_scope name vars = function
| Nil -> raise Not_found
| ScopeDef { scope_name; scope_body; _ } when scope_name = name ->
List.rev vars, scope_body
| ScopeDef { scope_next; _ } ->
let var, next = Bindlib.unbind scope_next in
find_scope name (var :: vars) next
let build_whole_program_expr
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_abs : ('expr, 'm) make_abs_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(p : ('expr, 'm) program_generic)
(main_scope : ScopeName.t) : ('expr, 'm) marked Bindlib.box =
let _, main_scope_body = find_scope main_scope [] p.scopes in
unfold_scopes ~box_expr ~make_abs ~make_let_in p.decl_ctx p.scopes
(get_scope_body_mark main_scope_body)
(ScopeName main_scope)
let rec expr_size (e : 'm marked_expr) : int =
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) | EArray args ->
List.fold_left (fun acc arg -> acc + expr_size arg) 1 args
| ETupleAccess (e1, _, _, _)
| EInj (e1, _, _, _)
| EAssert e1
| ErrorOnEmpty e1 ->
expr_size e1 + 1
| EMatch (arg, args, _) | EApp (arg, args) ->
List.fold_left (fun acc arg -> acc + expr_size arg) (1 + expr_size arg) args
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
1 + expr_size body
| EIfThenElse (e1, e2, e3) -> 1 + expr_size e1 + expr_size e2 + expr_size e3
| EDefault (exceptions, just, cons) ->
List.fold_left
(fun acc except -> acc + expr_size except)
(1 + expr_size just + expr_size cons)
exceptions
let remove_logging_calls (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let rec f () e =
match Marked.unmark e with
| EApp ((EOp (Unop (Log _)), _), [arg]) -> map_expr () ~f arg
| _ -> map_expr () ~f e
in
f () e
type 'm program = 'm expr Shared_ast.program

255
compiler/dcalc/ast.mli
View File

@ -17,258 +17,11 @@
(** Abstract syntax tree of the default calculus intermediate representation *)
open Utils
include module type of Astgen
include module type of Astgen_utils
open Shared_ast
type lit = dcalc glit
type 'm expr = (dcalc, 'm mark) gexpr
and 'm marked_expr = (dcalc, 'm mark) marked_gexpr
type 'm naked_expr = (dcalc, 'm mark) naked_gexpr
and 'm expr = (dcalc, 'm mark) gexpr
type 'm program = ('m expr, 'm) program_generic
(** {1 Helpers} *)
(** {2 Variables} *)
type 'm var = 'm expr Var.t
type 'm vars = 'm expr Var.vars
val free_vars_expr : 'm marked_expr -> 'm expr Var.Set.t
val free_vars_scope_body_expr :
('m expr, 'm) scope_body_expr -> 'm expr Var.Set.t
val free_vars_scope_body : ('m expr, 'm) scope_body -> 'm expr Var.Set.t
val free_vars_scopes : ('m expr, 'm) scopes -> 'm expr Var.Set.t
val make_var : ('m var, 'm) marked -> 'm marked_expr Bindlib.box
(** {2 Manipulation of marks} *)
val no_mark : 'm mark -> 'm mark
val mark_pos : 'm mark -> Pos.t
val pos : ('a, 'm) marked -> Pos.t
val ty : ('a, typed) marked -> marked_typ
val with_ty : marked_typ -> ('a, 'm) marked -> ('a, typed) marked
(** All the following functions will resolve the types if called on an
[Inferring] type *)
val map_mark :
(Pos.t -> Pos.t) -> (marked_typ -> marked_typ) -> 'm mark -> 'm mark
val map_mark2 :
(Pos.t -> Pos.t -> Pos.t) ->
(typed -> typed -> marked_typ) ->
'm mark ->
'm mark ->
'm mark
val fold_marks :
(Pos.t list -> Pos.t) -> (typed list -> marked_typ) -> 'm mark list -> 'm mark
val get_scope_body_mark : ('expr, 'm) scope_body -> 'm mark
val untype_expr : 'm marked_expr -> untyped marked_expr Bindlib.box
val untype_program : 'm program -> untyped program
(** {2 Boxed constructors} *)
val evar : 'm expr Bindlib.var -> 'm mark -> 'm marked_expr Bindlib.box
val etuple :
'm marked_expr Bindlib.box list ->
StructName.t option ->
'm mark ->
'm marked_expr Bindlib.box
val etupleaccess :
'm marked_expr Bindlib.box ->
int ->
StructName.t option ->
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val einj :
'm marked_expr Bindlib.box ->
int ->
EnumName.t ->
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val ematch :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
EnumName.t ->
'm mark ->
'm marked_expr Bindlib.box
val earray :
'm marked_expr Bindlib.box list -> 'm mark -> 'm marked_expr Bindlib.box
val elit : lit -> 'm mark -> 'm marked_expr Bindlib.box
val eabs :
('m expr, 'm marked_expr) Bindlib.mbinder Bindlib.box ->
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val eapp :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val eassert :
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
val eop : operator -> 'm mark -> 'm marked_expr Bindlib.box
val edefault :
'm marked_expr Bindlib.box list ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eifthenelse :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eerroronempty :
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
type ('expr, 'm) box_expr_sig =
('expr, 'm) marked -> ('expr, 'm) marked Bindlib.box
val box_expr : ('m expr, 'm) box_expr_sig
(**{2 Program traversal}*)
(** Be careful when using these traversal functions, as the bound variables they
open will be different at each traversal. *)
val map_expr :
'a ->
f:('a -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box) ->
('m1 expr, 'm2 mark) Marked.t ->
'm2 marked_expr Bindlib.box
(** If you want to apply a map transform to an expression, you can save up
writing a painful match over all the cases of the AST. For instance, if you
want to remove all errors on empty, you can write
{[
let remove_error_empty =
let rec f () e =
match Marked.unmark e with
| ErrorOnEmpty e1 -> map_expr () f e1
| _ -> map_expr () f e
in
f () e
]}
The first argument of map_expr is an optional context that you can carry
around during your map traversal. *)
val map_expr_top_down :
f:('m1 marked_expr -> ('m1 expr, 'm2 mark) Marked.t) ->
'm1 marked_expr ->
'm2 marked_expr Bindlib.box
(** Recursively applies [f] to the nodes of the expression tree. The type
returned by [f] is hybrid since the mark at top-level has been rewritten,
but not yet the marks in the subtrees. *)
val map_expr_marks :
f:('m1 mark -> 'm2 mark) -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box
(** {2 Boxed term constructors} *)
type ('e, 'm) make_abs_sig =
'e Bindlib.mvar ->
('e, 'm) marked Bindlib.box ->
marked_typ list ->
'm mark ->
('e, 'm) marked Bindlib.box
val make_abs : ('m expr, 'm) make_abs_sig
val make_app :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
type ('expr, 'm) make_let_in_sig =
'expr Bindlib.var ->
marked_typ ->
('expr, 'm) marked Bindlib.box ->
('expr, 'm) marked Bindlib.box ->
Pos.t ->
('expr, 'm) marked Bindlib.box
val make_let_in : ('m expr, 'm) make_let_in_sig
(**{2 Other}*)
val empty_thunked_term : 'm mark -> 'm marked_expr
val is_value : 'm marked_expr -> bool
val equal_exprs : 'm marked_expr -> 'm marked_expr -> bool
(** Determines if two expressions are equal, omitting their position information *)
(** {1 AST manipulation helpers}*)
val build_whole_scope_expr :
box_expr:('expr, 'm) box_expr_sig ->
make_abs:('expr, 'm) make_abs_sig ->
make_let_in:('expr, 'm) make_let_in_sig ->
decl_ctx ->
('expr, 'm) scope_body ->
'm mark ->
('expr, 'm) marked Bindlib.box
(** Usage: [build_whole_scope_expr ctx body scope_position] where
[scope_position] corresponds to the line of the scope declaration for
instance. *)
type 'expr scope_name_or_var =
| ScopeName of ScopeName.t
| ScopeVar of 'expr Bindlib.var
val unfold_scopes :
box_expr:('expr, 'm) box_expr_sig ->
make_abs:('expr, 'm) make_abs_sig ->
make_let_in:('expr, 'm) make_let_in_sig ->
decl_ctx ->
('expr, 'm) scopes ->
'm mark ->
'expr scope_name_or_var ->
('expr, 'm) marked Bindlib.box
val build_whole_program_expr :
box_expr:('expr, 'm) box_expr_sig ->
make_abs:('expr, 'm) make_abs_sig ->
make_let_in:('expr, 'm) make_let_in_sig ->
('expr, 'm) program_generic ->
ScopeName.t ->
('expr, 'm) marked Bindlib.box
(** Usage: [build_whole_program_expr program main_scope] builds an expression
corresponding to the main program and returning the main scope as a
function. *)
val expr_size : 'm marked_expr -> int
(** Used by the optimizer to know when to stop *)
val remove_logging_calls : 'm marked_expr -> 'm marked_expr Bindlib.box
(** Removes all calls to [Log] unary operators in the AST, replacing them by
their argument. *)
val build_scope_typ_from_sig :
decl_ctx -> StructName.t -> StructName.t -> Pos.t -> typ Marked.pos
(** [build_scope_typ_from_sig ctx in_struct out_struct pos] builds the arrow
type for the specified scope *)
type 'm program = 'm expr Shared_ast.program

2
compiler/dcalc/dune
View File

@ -1,7 +1,7 @@
(library
(name dcalc)
(public_name catala.dcalc)
(libraries bindlib unionFind utils re ubase catala.runtime_ocaml)
(libraries bindlib unionFind utils re ubase catala.runtime_ocaml shared_ast)
(preprocess
(pps visitors.ppx)))

492
compiler/dcalc/interpreter.ml
View File

@ -17,12 +17,12 @@
(** Reference interpreter for the default calculus *)
open Utils
module A = Ast
open Shared_ast
module Runtime = Runtime_ocaml.Runtime
(** {1 Helpers} *)
let is_empty_error (e : 'm A.marked_expr) : bool =
let is_empty_error (e : 'm Ast.expr) : bool =
match Marked.unmark e with ELit LEmptyError -> true | _ -> false
let log_indent = ref 0
@ -30,32 +30,33 @@ let log_indent = ref 0
(** {1 Evaluation} *)
let rec evaluate_operator
(ctx : Ast.decl_ctx)
(op : A.operator)
(ctx : decl_ctx)
(op : operator)
(pos : Pos.t)
(args : 'm A.marked_expr list) : 'm A.expr =
(args : 'm Ast.expr list) : 'm Ast.naked_expr =
(* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use
[op] to raise multispanned errors. *)
let apply_div_or_raise_err (div : unit -> 'm A.expr) : 'm A.expr =
let apply_div_or_raise_err (div : unit -> 'm Ast.naked_expr) :
'm Ast.naked_expr =
try div ()
with Division_by_zero ->
Errors.raise_multispanned_error
[
Some "The division operator:", pos;
Some "The null denominator:", Ast.pos (List.nth args 1);
Some "The null denominator:", Expr.pos (List.nth args 1);
]
"division by zero at runtime"
in
let get_binop_args_pos = function
| (arg0 :: arg1 :: _ : 'm A.marked_expr list) ->
[None, Ast.pos arg0; None, Ast.pos arg1]
| (arg0 :: arg1 :: _ : 'm Ast.expr list) ->
[None, Expr.pos arg0; None, Expr.pos arg1]
| _ -> assert false
in
(* Try to apply [cmp] and if a [UncomparableDurations] exceptions is catched,
use [args] to raise multispanned errors. *)
let apply_cmp_or_raise_err
(cmp : unit -> 'm A.expr)
(args : 'm A.marked_expr list) : 'm A.expr =
(cmp : unit -> 'm Ast.naked_expr)
(args : 'm Ast.expr list) : 'm Ast.naked_expr =
try cmp ()
with Runtime.UncomparableDurations ->
Errors.raise_multispanned_error (get_binop_args_pos args)
@ -63,218 +64,209 @@ let rec evaluate_operator
precise number of days"
in
match op, List.map Marked.unmark args with
| A.Ternop A.Fold, [_f; _init; EArray es] ->
| Ternop Fold, [_f; _init; EArray es] ->
Marked.unmark
(List.fold_left
(fun acc e' ->
evaluate_expr ctx
(Marked.same_mark_as (A.EApp (List.nth args 0, [acc; e'])) e'))
(Marked.same_mark_as (EApp (List.nth args 0, [acc; e'])) e'))
(List.nth args 1) es)
| A.Binop A.And, [ELit (LBool b1); ELit (LBool b2)] ->
A.ELit (LBool (b1 && b2))
| A.Binop A.Or, [ELit (LBool b1); ELit (LBool b2)] ->
A.ELit (LBool (b1 || b2))
| A.Binop A.Xor, [ELit (LBool b1); ELit (LBool b2)] ->
A.ELit (LBool (b1 <> b2))
| A.Binop (A.Add KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 +! i2))
| A.Binop (A.Sub KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 -! i2))
| A.Binop (A.Mult KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 *! i2))
| A.Binop (A.Div KInt), [ELit (LInt i1); ELit (LInt i2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LInt Runtime.(i1 /! i2)))
| A.Binop (A.Add KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 +& i2))
| A.Binop (A.Sub KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 -& i2))
| A.Binop (A.Mult KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 *& i2))
| A.Binop (A.Div KRat), [ELit (LRat i1); ELit (LRat i2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(i1 /& i2)))
| A.Binop (A.Add KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LMoney Runtime.(m1 +$ m2))
| A.Binop (A.Sub KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LMoney Runtime.(m1 -$ m2))
| A.Binop (A.Mult KMoney), [ELit (LMoney m1); ELit (LRat m2)] ->
A.ELit (LMoney Runtime.(m1 *$ m2))
| A.Binop (A.Div KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(m1 /$ m2)))
| A.Binop (A.Add KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LDuration Runtime.(d1 +^ d2))
| A.Binop (A.Sub KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LDuration Runtime.(d1 -^ d2))
| A.Binop (A.Sub KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LDuration Runtime.(d1 -@ d2))
| A.Binop (A.Add KDate), [ELit (LDate d1); ELit (LDuration d2)] ->
A.ELit (LDate Runtime.(d1 +@ d2))
| A.Binop (A.Mult KDuration), [ELit (LDuration d1); ELit (LInt i1)] ->
A.ELit (LDuration Runtime.(d1 *^ i1))
| A.Binop (A.Lt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 <! i2))
| A.Binop (A.Lte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 <=! i2))
| A.Binop (A.Gt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 >! i2))
| A.Binop (A.Gte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 >=! i2))
| A.Binop (A.Lt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 <& i2))
| A.Binop (A.Lte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 <=& i2))
| A.Binop (A.Gt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 >& i2))
| A.Binop (A.Gte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 >=& i2))
| A.Binop (A.Lt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 <$ m2))
| A.Binop (A.Lte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 <=$ m2))
| A.Binop (A.Gt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 >$ m2))
| A.Binop (A.Gte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 >=$ m2))
| A.Binop (A.Lt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <^ d2))) args
| A.Binop (A.Lte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <=^ d2))) args
| A.Binop (A.Gt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >^ d2))) args
| A.Binop (A.Gte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >=^ d2))) args
| A.Binop (A.Lt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 <@ d2))
| A.Binop (A.Lte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 <=@ d2))
| A.Binop (A.Gt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 >@ d2))
| A.Binop (A.Gte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 >=@ d2))
| A.Binop A.Eq, [ELit LUnit; ELit LUnit] -> A.ELit (LBool true)
| A.Binop A.Eq, [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LBool Runtime.(d1 =^ d2))
| A.Binop A.Eq, [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 =@ d2))
| A.Binop A.Eq, [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 =$ m2))
| A.Binop A.Eq, [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 =& i2))
| A.Binop A.Eq, [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 =! i2))
| A.Binop A.Eq, [ELit (LBool b1); ELit (LBool b2)] -> A.ELit (LBool (b1 = b2))
| A.Binop A.Eq, [EArray es1; EArray es2] ->
A.ELit
| Binop And, [ELit (LBool b1); ELit (LBool b2)] -> ELit (LBool (b1 && b2))
| Binop Or, [ELit (LBool b1); ELit (LBool b2)] -> ELit (LBool (b1 || b2))
| Binop Xor, [ELit (LBool b1); ELit (LBool b2)] -> ELit (LBool (b1 <> b2))
| Binop (Add KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LInt Runtime.(i1 +! i2))
| Binop (Sub KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LInt Runtime.(i1 -! i2))
| Binop (Mult KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LInt Runtime.(i1 *! i2))
| Binop (Div KInt), [ELit (LInt i1); ELit (LInt i2)] ->
apply_div_or_raise_err (fun _ -> ELit (LInt Runtime.(i1 /! i2)))
| Binop (Add KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LRat Runtime.(i1 +& i2))
| Binop (Sub KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LRat Runtime.(i1 -& i2))
| Binop (Mult KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LRat Runtime.(i1 *& i2))
| Binop (Div KRat), [ELit (LRat i1); ELit (LRat i2)] ->
apply_div_or_raise_err (fun _ -> ELit (LRat Runtime.(i1 /& i2)))
| Binop (Add KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LMoney Runtime.(m1 +$ m2))
| Binop (Sub KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LMoney Runtime.(m1 -$ m2))
| Binop (Mult KMoney), [ELit (LMoney m1); ELit (LRat m2)] ->
ELit (LMoney Runtime.(m1 *$ m2))
| Binop (Div KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
apply_div_or_raise_err (fun _ -> ELit (LRat Runtime.(m1 /$ m2)))
| Binop (Add KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
ELit (LDuration Runtime.(d1 +^ d2))
| Binop (Sub KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
ELit (LDuration Runtime.(d1 -^ d2))
| Binop (Sub KDate), [ELit (LDate d1); ELit (LDate d2)] ->
ELit (LDuration Runtime.(d1 -@ d2))
| Binop (Add KDate), [ELit (LDate d1); ELit (LDuration d2)] ->
ELit (LDate Runtime.(d1 +@ d2))
| Binop (Mult KDuration), [ELit (LDuration d1); ELit (LInt i1)] ->
ELit (LDuration Runtime.(d1 *^ i1))
| Binop (Lt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LBool Runtime.(i1 <! i2))
| Binop (Lte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LBool Runtime.(i1 <=! i2))
| Binop (Gt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LBool Runtime.(i1 >! i2))
| Binop (Gte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LBool Runtime.(i1 >=! i2))
| Binop (Lt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LBool Runtime.(i1 <& i2))
| Binop (Lte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LBool Runtime.(i1 <=& i2))
| Binop (Gt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LBool Runtime.(i1 >& i2))
| Binop (Gte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LBool Runtime.(i1 >=& i2))
| Binop (Lt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LBool Runtime.(m1 <$ m2))
| Binop (Lte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LBool Runtime.(m1 <=$ m2))
| Binop (Gt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LBool Runtime.(m1 >$ m2))
| Binop (Gte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LBool Runtime.(m1 >=$ m2))
| Binop (Lt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> ELit (LBool Runtime.(d1 <^ d2))) args
| Binop (Lte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> ELit (LBool Runtime.(d1 <=^ d2))) args
| Binop (Gt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> ELit (LBool Runtime.(d1 >^ d2))) args
| Binop (Gte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> ELit (LBool Runtime.(d1 >=^ d2))) args
| Binop (Lt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
ELit (LBool Runtime.(d1 <@ d2))
| Binop (Lte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
ELit (LBool Runtime.(d1 <=@ d2))
| Binop (Gt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
ELit (LBool Runtime.(d1 >@ d2))
| Binop (Gte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
ELit (LBool Runtime.(d1 >=@ d2))
| Binop Eq, [ELit LUnit; ELit LUnit] -> ELit (LBool true)
| Binop Eq, [ELit (LDuration d1); ELit (LDuration d2)] ->
ELit (LBool Runtime.(d1 =^ d2))
| Binop Eq, [ELit (LDate d1); ELit (LDate d2)] ->
ELit (LBool Runtime.(d1 =@ d2))
| Binop Eq, [ELit (LMoney m1); ELit (LMoney m2)] ->
ELit (LBool Runtime.(m1 =$ m2))
| Binop Eq, [ELit (LRat i1); ELit (LRat i2)] ->
ELit (LBool Runtime.(i1 =& i2))
| Binop Eq, [ELit (LInt i1); ELit (LInt i2)] ->
ELit (LBool Runtime.(i1 =! i2))
| Binop Eq, [ELit (LBool b1); ELit (LBool b2)] -> ELit (LBool (b1 = b2))
| Binop Eq, [EArray es1; EArray es2] ->
ELit
(LBool
(try
List.for_all2
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| A.ELit (LBool b) -> b
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [ETuple (es1, s1); ETuple (es2, s2)] ->
A.ELit
| Binop Eq, [ETuple (es1, s1); ETuple (es2, s2)] ->
ELit
(LBool
(try
s1 = s2
&& List.for_all2
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| A.ELit (LBool b) -> b
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [EInj (e1, i1, en1, _ts1); EInj (e2, i2, en2, _ts2)] ->
A.ELit
| Binop Eq, [EInj (e1, i1, en1, _ts1); EInj (e2, i2, en2, _ts2)] ->
ELit
(LBool
(try
en1 = en2
&& i1 = i2
&&
match evaluate_operator ctx op pos [e1; e2] with
| A.ELit (LBool b) -> b
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
with Invalid_argument _ -> false))
| A.Binop A.Eq, [_; _] ->
A.ELit (LBool false) (* comparing anything else return false *)
| A.Binop A.Neq, [_; _] -> (
match evaluate_operator ctx (A.Binop A.Eq) pos args with
| A.ELit (A.LBool b) -> A.ELit (A.LBool (not b))
| Binop Eq, [_; _] ->
ELit (LBool false) (* comparing anything else return false *)
| Binop Neq, [_; _] -> (
match evaluate_operator ctx (Binop Eq) pos args with
| ELit (LBool b) -> ELit (LBool (not b))
| _ -> assert false (*should not happen *))
| A.Binop A.Concat, [A.EArray es1; A.EArray es2] -> A.EArray (es1 @ es2)
| A.Binop A.Map, [_; A.EArray es] ->
A.EArray
| Binop Concat, [EArray es1; EArray es2] -> EArray (es1 @ es2)
| Binop Map, [_; EArray es] ->
EArray
(List.map
(fun e' ->
evaluate_expr ctx
(Marked.same_mark_as (A.EApp (List.nth args 0, [e'])) e'))
(Marked.same_mark_as (EApp (List.nth args 0, [e'])) e'))
es)
| A.Binop A.Filter, [_; A.EArray es] ->
A.EArray
| Binop Filter, [_; EArray es] ->
EArray
(List.filter
(fun e' ->
match
evaluate_expr ctx
(Marked.same_mark_as (A.EApp (List.nth args 0, [e'])) e')
(Marked.same_mark_as (EApp (List.nth args 0, [e'])) e')
with
| A.ELit (A.LBool b), _ -> b
| ELit (LBool b), _ -> b
| _ ->
Errors.raise_spanned_error
(A.pos (List.nth args 0))
(Expr.pos (List.nth args 0))
"This predicate evaluated to something else than a boolean \
(should not happen if the term was well-typed)")
es)
| A.Binop _, ([ELit LEmptyError; _] | [_; ELit LEmptyError]) ->
A.ELit LEmptyError
| A.Unop (A.Minus KInt), [ELit (LInt i)] ->
A.ELit (LInt Runtime.(integer_of_int 0 -! i))
| A.Unop (A.Minus KRat), [ELit (LRat i)] ->
A.ELit (LRat Runtime.(decimal_of_string "0" -& i))
| A.Unop (A.Minus KMoney), [ELit (LMoney i)] ->
A.ELit (LMoney Runtime.(money_of_units_int 0 -$ i))
| A.Unop (A.Minus KDuration), [ELit (LDuration i)] ->
A.ELit (LDuration Runtime.(~-^i))
| A.Unop A.Not, [ELit (LBool b)] -> A.ELit (LBool (not b))
| A.Unop A.Length, [EArray es] ->
A.ELit (LInt (Runtime.integer_of_int (List.length es)))
| A.Unop A.GetDay, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(day_of_month_of_date d))
| A.Unop A.GetMonth, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(month_number_of_date d))
| A.Unop A.GetYear, [ELit (LDate d)] -> A.ELit (LInt Runtime.(year_of_date d))
| A.Unop A.FirstDayOfMonth, [ELit (LDate d)] ->
A.ELit (LDate Runtime.(first_day_of_month d))
| A.Unop A.LastDayOfMonth, [ELit (LDate d)] ->
A.ELit (LDate Runtime.(first_day_of_month d))
| A.Unop A.IntToRat, [ELit (LInt i)] ->
A.ELit (LRat Runtime.(decimal_of_integer i))
| A.Unop A.MoneyToRat, [ELit (LMoney i)] ->
A.ELit (LRat Runtime.(decimal_of_money i))
| A.Unop A.RatToMoney, [ELit (LRat i)] ->
A.ELit (LMoney Runtime.(money_of_decimal i))
| A.Unop A.RoundMoney, [ELit (LMoney m)] ->
A.ELit (LMoney Runtime.(money_round m))
| A.Unop A.RoundDecimal, [ELit (LRat m)] ->
A.ELit (LRat Runtime.(decimal_round m))
| A.Unop (A.Log (entry, infos)), [e'] ->
| Binop _, ([ELit LEmptyError; _] | [_; ELit LEmptyError]) -> ELit LEmptyError
| Unop (Minus KInt), [ELit (LInt i)] ->
ELit (LInt Runtime.(integer_of_int 0 -! i))
| Unop (Minus KRat), [ELit (LRat i)] ->
ELit (LRat Runtime.(decimal_of_string "0" -& i))
| Unop (Minus KMoney), [ELit (LMoney i)] ->
ELit (LMoney Runtime.(money_of_units_int 0 -$ i))
| Unop (Minus KDuration), [ELit (LDuration i)] ->
ELit (LDuration Runtime.(~-^i))
| Unop Not, [ELit (LBool b)] -> ELit (LBool (not b))
| Unop Length, [EArray es] ->
ELit (LInt (Runtime.integer_of_int (List.length es)))
| Unop GetDay, [ELit (LDate d)] ->
ELit (LInt Runtime.(day_of_month_of_date d))
| Unop GetMonth, [ELit (LDate d)] ->
ELit (LInt Runtime.(month_number_of_date d))
| Unop GetYear, [ELit (LDate d)] -> ELit (LInt Runtime.(year_of_date d))
| Unop FirstDayOfMonth, [ELit (LDate d)] ->
ELit (LDate Runtime.(first_day_of_month d))
| Unop LastDayOfMonth, [ELit (LDate d)] ->
ELit (LDate Runtime.(first_day_of_month d))
| Unop IntToRat, [ELit (LInt i)] -> ELit (LRat Runtime.(decimal_of_integer i))
| Unop MoneyToRat, [ELit (LMoney i)] ->
ELit (LRat Runtime.(decimal_of_money i))
| Unop RatToMoney, [ELit (LRat i)] ->
ELit (LMoney Runtime.(money_of_decimal i))
| Unop RoundMoney, [ELit (LMoney m)] -> ELit (LMoney Runtime.(money_round m))
| Unop RoundDecimal, [ELit (LRat m)] -> ELit (LRat Runtime.(decimal_round m))
| Unop (Log (entry, infos)), [e'] ->
if !Cli.trace_flag then (
match entry with
| VarDef _ ->
(* TODO: this usage of Format is broken, Formatting requires that all is
formatted in one pass, without going through intermediate "%s" *)
Cli.log_format "%*s%a %a: %s" (!log_indent * 2) ""
Print.format_log_entry entry Print.format_uid_list infos
Cli.log_format "%*s%a %a: %s" (!log_indent * 2) "" Print.log_entry entry
Print.uid_list infos
(match e' with
| Ast.EAbs _ -> Cli.with_style [ANSITerminal.green] "<function>"
| EAbs _ -> Cli.with_style [ANSITerminal.green] "<function>"
| _ ->
let expr_str =
Format.asprintf "%a"
(Print.format_expr ctx ~debug:false)
(List.hd args)
Format.asprintf "%a" (Expr.format ctx ~debug:false) (List.hd args)
in
let expr_str =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
@ -285,23 +277,23 @@ let rec evaluate_operator
| PosRecordIfTrueBool -> (
match pos <> Pos.no_pos, e' with
| true, ELit (LBool true) ->
Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) ""
Print.format_log_entry entry
Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) "" Print.log_entry
entry
(Cli.with_style [ANSITerminal.green] "Definition applied")
(Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) (fun _ ->
Format.asprintf "%*s" (!log_indent * 2) ""))
| _ -> ())
| BeginCall ->
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry
entry Print.format_uid_list infos;
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry
Print.uid_list infos;
log_indent := !log_indent + 1
| EndCall ->
log_indent := !log_indent - 1;
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry
entry Print.format_uid_list infos)
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry
Print.uid_list infos)
else ();
e'
| A.Unop _, [ELit LEmptyError] -> A.ELit LEmptyError
| Unop _, [ELit LEmptyError] -> ELit LEmptyError
| _ ->
Errors.raise_multispanned_error
([Some "Operator:", pos]
@ -309,18 +301,17 @@ let rec evaluate_operator
(fun i arg ->
( Some
(Format.asprintf "Argument n°%d, value %a" (i + 1)
(Print.format_expr ctx ~debug:true)
(Expr.format ctx ~debug:true)
arg),
A.pos arg ))
Expr.pos arg ))
args)
"Operator applied to the wrong arguments\n\
(should not happen if the term was well-typed)"
and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
=
and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
match Marked.unmark e with
| EVar _ ->
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"free variable found at evaluation (should not happen if term was \
well-typed"
| EApp (e1, args) -> (
@ -332,22 +323,23 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
evaluate_expr ctx
(Bindlib.msubst binder (Array.of_list (List.map Marked.unmark args)))
else
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder)
(List.length args)
| EOp op -> Marked.same_mark_as (evaluate_operator ctx op (A.pos e) args) e
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| EOp op ->
Marked.same_mark_as (evaluate_operator ctx op (Expr.pos e) args) e
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| EAbs _ | ELit _ | EOp _ -> e (* these are values *)
| ETuple (es, s) ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then
Marked.same_mark_as (A.ELit LEmptyError) e
else Marked.same_mark_as (A.ETuple (new_es, s)) e
Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (ETuple (new_es, s)) e
| ETupleAccess (e1, n, s, _) -> (
let e1 = evaluate_expr ctx e1 in
match Marked.unmark e1 with
@ -357,49 +349,49 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
| Some s, Some s' when s = s' -> ()
| _ ->
Errors.raise_multispanned_error
[None, A.pos e; None, A.pos e1]
[None, Expr.pos e; None, Expr.pos e1]
"Error during tuple access: not the same structs (should not happen \
if the term was well-typed)");
match List.nth_opt es n with
| Some e' -> e'
| None ->
Errors.raise_spanned_error (A.pos e1)
Errors.raise_spanned_error (Expr.pos e1)
"The tuple has %d components but the %i-th element was requested \
(should not happen if the term was well-type)"
(List.length es) n)
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (A.pos e1)
Errors.raise_spanned_error (Expr.pos e1)
"The expression %a should be a tuple with %d components but is not \
(should not happen if the term was well-typed)"
(Print.format_expr ctx ~debug:true)
(Expr.format ctx ~debug:true)
e n)
| EInj (e1, n, en, ts) ->
let e1' = evaluate_expr ctx e1 in
if is_empty_error e1' then Marked.same_mark_as (A.ELit LEmptyError) e
else Marked.same_mark_as (A.EInj (e1', n, en, ts)) e
if is_empty_error e1' then Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (EInj (e1', n, en, ts)) e
| EMatch (e1, es, e_name) -> (
let e1 = evaluate_expr ctx e1 in
match Marked.unmark e1 with
| A.EInj (e1, n, e_name', _) ->
| EInj (e1, n, e_name', _) ->
if e_name <> e_name' then
Errors.raise_multispanned_error
[None, A.pos e; None, A.pos e1]
[None, Expr.pos e; None, Expr.pos e1]
"Error during match: two different enums found (should not happend \
if the term was well-typed)";
let es_n =
match List.nth_opt es n with
| Some es_n -> es_n
| None ->
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"sum type index error (should not happend if the term was \
well-typed)"
in
let new_e = Marked.same_mark_as (A.EApp (es_n, [e1])) e in
let new_e = Marked.same_mark_as (EApp (es_n, [e1])) e in
evaluate_expr ctx new_e
| A.ELit A.LEmptyError -> Marked.same_mark_as (A.ELit A.LEmptyError) e
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (A.pos e1)
Errors.raise_spanned_error (Expr.pos e1)
"Expected a term having a sum type as an argument to a match (should \
not happend if the term was well-typed")
| EDefault (exceptions, just, cons) -> (
@ -409,11 +401,11 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
| 0 -> (
let just = evaluate_expr ctx just in
match Marked.unmark just with
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| ELit (LBool true) -> evaluate_expr ctx cons
| ELit (LBool false) -> Marked.same_mark_as (A.ELit LEmptyError) e
| ELit (LBool false) -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) exceptions
@ -421,7 +413,7 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
Errors.raise_multispanned_error
(List.map
(fun except ->
Some "This consequence has a valid justification:", A.pos except)
Some "This consequence has a valid justification:", Expr.pos except)
(List.filter (fun sub -> not (is_empty_error sub)) exceptions))
"There is a conflict between multiple valid consequences for assigning \
the same variable.")
@ -429,82 +421,78 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
match Marked.unmark (evaluate_expr ctx cond) with
| ELit (LBool true) -> evaluate_expr ctx et
| ELit (LBool false) -> evaluate_expr ctx ef
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (A.pos cond)
Errors.raise_spanned_error (Expr.pos cond)
"Expected a boolean literal for the result of this condition (should \
not happen if the term was well-typed)")
| EArray es ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then
Marked.same_mark_as (A.ELit LEmptyError) e
else Marked.same_mark_as (A.EArray new_es) e
Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (EArray new_es) e
| ErrorOnEmpty e' ->
let e' = evaluate_expr ctx e' in
if Marked.unmark e' = A.ELit LEmptyError then
Errors.raise_spanned_error (A.pos e')
if Marked.unmark e' = ELit LEmptyError then
Errors.raise_spanned_error (Expr.pos e')
"This variable evaluated to an empty term (no rule that defined it \
applied in this situation)"
else e'
| EAssert e' -> (
match Marked.unmark (evaluate_expr ctx e') with
| ELit (LBool true) -> Marked.same_mark_as (Ast.ELit LUnit) e'
| ELit (LBool true) -> Marked.same_mark_as (ELit LUnit) e'
| ELit (LBool false) -> (
match Marked.unmark e' with
| Ast.ErrorOnEmpty
| ErrorOnEmpty
( EApp
( (Ast.EOp (Binop op), _),
[((ELit _, _) as e1); ((ELit _, _) as e2)] ),
((EOp (Binop op), _), [((ELit _, _) as e1); ((ELit _, _) as e2)]),
_ )
| EApp
( (Ast.EOp (Ast.Unop (Ast.Log _)), _),
( (EOp (Unop (Log _)), _),
[
( Ast.EApp
( (Ast.EOp (Binop op), _),
( EApp
( (EOp (Binop op), _),
[((ELit _, _) as e1); ((ELit _, _) as e2)] ),
_ );
] )
| EApp
((Ast.EOp (Binop op), _), [((ELit _, _) as e1); ((ELit _, _) as e2)])
| EApp ((EOp (Binop op), _), [((ELit _, _) as e1); ((ELit _, _) as e2)])
->
Errors.raise_spanned_error (A.pos e') "Assertion failed: %a %a %a"
(Print.format_expr ctx ~debug:false)
e1 Print.format_binop op
(Print.format_expr ctx ~debug:false)
Errors.raise_spanned_error (Expr.pos e') "Assertion failed: %a %a %a"
(Expr.format ctx ~debug:false)
e1 Print.binop op
(Expr.format ctx ~debug:false)
e2
| _ ->
Cli.debug_format "%a" (Print.format_expr ctx) e';
Errors.raise_spanned_error (A.pos e') "Assertion failed")
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
Cli.debug_format "%a" (Expr.format ctx) e';
Errors.raise_spanned_error (Expr.pos e') "Assertion failed")
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (A.pos e')
Errors.raise_spanned_error (Expr.pos e')
"Expected a boolean literal for the result of this assertion (should \
not happen if the term was well-typed)")
(** {1 API} *)
let interpret_program :
'm.
Ast.decl_ctx ->
'm Ast.marked_expr ->
(Uid.MarkedString.info * 'm Ast.marked_expr) list =
fun (ctx : Ast.decl_ctx) (e : 'm Ast.marked_expr) :
(Uid.MarkedString.info * 'm Ast.marked_expr) list ->
'm. decl_ctx -> 'm Ast.expr -> (Uid.MarkedString.info * 'm Ast.expr) list
=
fun (ctx : decl_ctx) (e : 'm Ast.expr) :
(Uid.MarkedString.info * 'm Ast.expr) list ->
match evaluate_expr ctx e with
| Ast.EAbs (_, [((Ast.TTuple (taus, Some s_in), _) as targs)]), mark_e ->
begin
| EAbs (_, [((TStruct s_in, _) as targs)]), mark_e -> begin
(* At this point, the interpreter seeks to execute the scope but does not
have a way to retrieve input values from the command line. [taus] contain
the types of the scope arguments. For [context] arguments, we cann
provide an empty thunked term. But for [input] arguments of another type,
we cannot provide anything so we have to fail. *)
the types of the scope arguments. For [context] arguments, we can provide
an empty thunked term. But for [input] arguments of another type, we
cannot provide anything so we have to fail. *)
let taus = StructMap.find s_in ctx.ctx_structs in
let application_term =
List.map
(fun ty ->
(fun (_, ty) ->
match Marked.unmark ty with
| A.TArrow ((A.TLit A.TUnit, _), ty_in) ->
Ast.empty_thunked_term
(A.map_mark (fun pos -> pos) (fun _ -> ty_in) mark_e)
| TArrow ((TLit TUnit, _), ty_in) ->
Expr.empty_thunked_term
(Expr.map_mark (fun pos -> pos) (fun _ -> ty_in) mark_e)
| _ ->
Errors.raise_spanned_error (Marked.get_mark ty)
"This scope needs input arguments to be executed. But the Catala \
@ -515,44 +503,44 @@ let interpret_program :
taus
in
let to_interpret =
( Ast.EApp
( EApp
( e,
[
( Ast.ETuple (application_term, Some s_in),
( ETuple (application_term, Some s_in),
let pos =
match application_term with
| a :: _ -> A.pos a
| a :: _ -> Expr.pos a
| [] -> Pos.no_pos
in
A.map_mark (fun _ -> pos) (fun _ -> targs) mark_e );
Expr.map_mark (fun _ -> pos) (fun _ -> targs) mark_e );
] ),
A.map_mark
Expr.map_mark
(fun pos -> pos)
(fun ty ->
match application_term, ty with
| [], t_out -> t_out
| _ :: _, (A.TArrow (_, t_out), _) -> t_out
| _ :: _, (TArrow (_, t_out), _) -> t_out
| _ :: _, (_, bad_pos) ->
Errors.raise_spanned_error bad_pos
"@[<hv 2>(bug) Result of interpretation doesn't have the \
expected type:@ @[%a@]@]"
(Print.format_typ ctx) (fst @@ ty))
(Print.typ ctx) ty)
mark_e )
in
match Marked.unmark (evaluate_expr ctx to_interpret) with
| Ast.ETuple (args, Some s_out) ->
| ETuple (args, Some s_out) ->
let s_out_fields =
List.map
(fun (f, _) -> Ast.StructFieldName.get_info f)
(Ast.StructMap.find s_out ctx.ctx_structs)
(fun (f, _) -> StructFieldName.get_info f)
(StructMap.find s_out ctx.ctx_structs)
in
List.map2 (fun arg var -> var, arg) args s_out_fields
| _ ->
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Errors.raise_spanned_error (A.pos e)
Errors.raise_spanned_error (Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"

7
compiler/dcalc/interpreter.mli
View File

@ -17,14 +17,13 @@
(** Reference interpreter for the default calculus *)
open Utils
open Shared_ast
val evaluate_expr : Ast.decl_ctx -> 'm Ast.marked_expr -> 'm Ast.marked_expr
val evaluate_expr : decl_ctx -> 'm Ast.expr -> 'm Ast.expr
(** Evaluates an expression according to the semantics of the default calculus. *)
val interpret_program :
Ast.decl_ctx ->
'm Ast.marked_expr ->
(Uid.MarkedString.info * 'm Ast.marked_expr) list
decl_ctx -> 'm Ast.expr -> (Uid.MarkedString.info * 'm Ast.expr) list
(** Interprets a program. This function expects an expression typed as a
function whose argument are all thunked. The function is executed by
providing for each argument a thunked empty default. Returns a list of all

31
compiler/dcalc/optimizations.ml
View File

@ -15,15 +15,16 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Shared_ast
open Ast
type partial_evaluation_ctx = {
var_values : (typed expr, typed marked_expr) Var.Map.t;
var_values : (typed expr, typed expr) Var.Map.t;
decl_ctx : decl_ctx;
}
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr) :
'm marked_expr Bindlib.box =
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm expr) :
'm expr Bindlib.box =
let pos = Marked.get_mark e in
let rec_helper = partial_evaluation ctx in
match Marked.unmark e with
@ -82,7 +83,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr) :
(fun arg arms ->
match arg, arms with
| (EInj (e1, i, e_name', _ts), _), _
when Ast.EnumName.compare e_name e_name' = 0 ->
when EnumName.compare e_name e_name' = 0 ->
(* iota reduction *)
EApp (List.nth arms i, [e1]), pos
| _ -> EMatch (arg, arms, e_name), pos)
@ -127,7 +128,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr) :
with
| exceptions, just, cons
when List.fold_left
(fun nb except -> if is_value except then nb + 1 else nb)
(fun nb except -> if Expr.is_value except then nb + 1 else nb)
0 exceptions
> 1 ->
(* at this point we know a conflict error will be triggered so we just
@ -135,7 +136,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr) :
beautiful right error message *)
Interpreter.evaluate_expr ctx.decl_ctx
(EDefault (exceptions, just, cons), pos)
| [except], _, _ when is_value except ->
| [except], _, _ when Expr.is_value except ->
(* if there is only one exception and it is a non-empty value it is
always chosen *)
except
@ -177,20 +178,20 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr) :
( ELit (LBool false)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool false), _)]) ) ) ->
e1
| _ when equal_exprs e2 e3 -> e2
| _ when Expr.equal e2 e3 -> e2
| _ -> EIfThenElse (e1, e2, e3), pos)
(rec_helper e1) (rec_helper e2) (rec_helper e3)
| ErrorOnEmpty e1 ->
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, pos) (rec_helper e1)
let optimize_expr (decl_ctx : decl_ctx) (e : 'm marked_expr) =
let optimize_expr (decl_ctx : decl_ctx) (e : 'm expr) =
partial_evaluation { var_values = Var.Map.empty; decl_ctx } e
let rec scope_lets_map
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(ctx : 'a)
(scope_body_expr : ('m expr, 'm) scope_body_expr) :
('m expr, 'm) scope_body_expr Bindlib.box =
(scope_body_expr : 'm expr scope_body_expr) :
'm expr scope_body_expr Bindlib.box =
match scope_body_expr with
| Result e -> Bindlib.box_apply (fun e' -> Result e') (t ctx e)
| ScopeLet scope_let ->
@ -209,9 +210,9 @@ let rec scope_lets_map
new_scope_let_expr new_next
let rec scopes_map
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(ctx : 'a)
(scopes : ('m expr, 'm) scopes) : ('m expr, 'm) scopes Bindlib.box =
(scopes : 'm expr scopes) : 'm expr scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box Nil
| ScopeDef scope_def ->
@ -240,7 +241,7 @@ let rec scopes_map
new_scope_body_expr new_scope_next
let program_map
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(ctx : 'a)
(p : 'm program) : 'm program Bindlib.box =
Bindlib.box_apply
@ -252,4 +253,4 @@ let optimize_program (p : 'm program) : untyped program =
(program_map partial_evaluation
{ var_values = Var.Map.empty; decl_ctx = p.decl_ctx }
p)
|> untype_program
|> Program.untype

3
compiler/dcalc/optimizations.mli
View File

@ -17,7 +17,8 @@
(** Optimization passes for default calculus programs and expressions *)
open Shared_ast
open Ast
val optimize_expr : decl_ctx -> 'm marked_expr -> 'm marked_expr Bindlib.box
val optimize_expr : decl_ctx -> 'm expr -> 'm expr Bindlib.box
val optimize_program : 'm program -> untyped program

359
compiler/dcalc/print.ml
View File

@ -1,359 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
open String_common
let typ_needs_parens (e : typ) : bool =
match e with TArrow _ | TArray _ -> true | _ -> false
let format_uid_list
(fmt : Format.formatter)
(infos : Uid.MarkedString.info list) : unit =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info ->
Format.fprintf fmt "%a"
(Utils.Cli.format_with_style
(if begins_with_uppercase (Marked.unmark info) then
[ANSITerminal.red]
else []))
(Format.asprintf "%a" Utils.Uid.MarkedString.format_info info)))
infos
let format_keyword (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.red]) s
let format_base_type (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.yellow]) s
let format_punctuation (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.cyan]) s
let format_operator (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.green]) s
let format_lit_style (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.yellow]) s
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
format_base_type fmt
(match l with
| TUnit -> "unit"
| TBool -> "bool"
| TInt -> "integer"
| TRat -> "decimal"
| TMoney -> "money"
| TDuration -> "duration"
| TDate -> "date")
let format_enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) :
unit =
Format.fprintf fmt "%a"
(Utils.Cli.format_with_style [ANSITerminal.magenta])
(Format.asprintf "%a" EnumConstructor.format_t c)
let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ) :
unit =
let format_typ = format_typ ctx in
let format_typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match typ with
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TTuple (ts, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " format_operator "*")
(fun fmt t -> Format.fprintf fmt "%a" format_typ t))
(List.map Marked.unmark ts)
| TTuple (_args, Some s) ->
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" Ast.StructName.format_t s
format_punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "%a@ " format_punctuation ";")
(fun fmt (field, typ) ->
Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\""
StructFieldName.format_t field format_punctuation "\""
format_punctuation ":" format_typ typ))
(List.map
(fun (c, t) -> c, Marked.unmark t)
(StructMap.find s ctx.ctx_structs))
format_punctuation "}"
| TEnum (_, e) ->
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" Ast.EnumName.format_t e
format_punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "@ %a@ " format_punctuation "|")
(fun fmt (case, typ) ->
Format.fprintf fmt "%a%a@ %a" format_enum_constructor case
format_punctuation ":" format_typ typ))
(List.map
(fun (c, t) -> c, Marked.unmark t)
(EnumMap.find e ctx.ctx_enums))
format_punctuation "]"
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens
(Marked.unmark t1) format_operator "→" format_typ (Marked.unmark t2)
| TArray t1 ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_base_type "array" format_typ
(Marked.unmark t1)
| TAny -> format_base_type fmt "any"
(* (EmileRolley) NOTE: seems to be factorizable with Lcalc.Print.format_lit. *)
let format_lit (fmt : Format.formatter) (l : lit) : unit =
match l with
| LBool b -> format_lit_style fmt (string_of_bool b)
| LInt i -> format_lit_style fmt (Runtime.integer_to_string i)
| LEmptyError -> format_lit_style fmt "∅ "
| LUnit -> format_lit_style fmt "()"
| LRat i ->
format_lit_style fmt
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
| LMoney e -> (
match !Utils.Cli.locale_lang with
| En ->
format_lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e))
| Fr ->
format_lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e))
| Pl ->
format_lit_style fmt
(Format.asprintf "%s PLN" (Runtime.money_to_string e)))
| LDate d -> format_lit_style fmt (Runtime.date_to_string d)
| LDuration d -> format_lit_style fmt (Runtime.duration_to_string d)
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> ""
| KRat -> "."
| KMoney -> "$"
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : binop) : unit =
format_operator fmt
(match op with
| Add k -> Format.asprintf "+%a" format_op_kind k
| Sub k -> Format.asprintf "-%a" format_op_kind k
| Mult k -> Format.asprintf "*%a" format_op_kind k
| Div k -> Format.asprintf "/%a" format_op_kind k
| And -> "&&"
| Or -> "||"
| Xor -> "xor"
| Eq -> "="
| Neq -> "!="
| Lt k -> Format.asprintf "%s%a" "<" format_op_kind k
| Lte k -> Format.asprintf "%s%a" "<=" format_op_kind k
| Gt k -> Format.asprintf "%s%a" ">" format_op_kind k
| Gte k -> Format.asprintf "%s%a" ">=" format_op_kind k
| Concat -> "++"
| Map -> "map"
| Filter -> "filter")
let format_ternop (fmt : Format.formatter) (op : ternop) : unit =
match op with Fold -> format_keyword fmt "fold"
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "@<2>%s"
(match entry with
| VarDef _ -> Utils.Cli.with_style [ANSITerminal.blue] "≔ "
| BeginCall -> Utils.Cli.with_style [ANSITerminal.yellow] "→ "
| EndCall -> Utils.Cli.with_style [ANSITerminal.yellow] "← "
| PosRecordIfTrueBool -> Utils.Cli.with_style [ANSITerminal.green] "☛ ")
let format_unop (fmt : Format.formatter) (op : unop) : unit =
Format.fprintf fmt "%s"
(match op with
| Minus _ -> "-"
| Not -> "~"
| Log (entry, infos) ->
Format.asprintf "log@[<hov 2>[%a|%a]@]" format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
infos
| Length -> "length"
| IntToRat -> "int_to_rat"
| MoneyToRat -> "money_to_rat"
| RatToMoney -> "rat_to_money"
| GetDay -> "get_day"
| GetMonth -> "get_month"
| GetYear -> "get_year"
| FirstDayOfMonth -> "first_day_of_month"
| LastDayOfMonth -> "last_day_of_month"
| RoundMoney -> "round_money"
| RoundDecimal -> "round_decimal")
let needs_parens (e : 'm marked_expr) : bool =
match Marked.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let format_var (fmt : Format.formatter) (v : 'm Ast.var) : unit =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let rec format_expr
?(debug : bool = false)
(ctx : Ast.decl_ctx)
(fmt : Format.formatter)
(e : 'm marked_expr) : unit =
let format_expr = format_expr ~debug ctx in
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e
format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation ")"
| ETuple (es, Some s) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a%a%a@]@]"
Ast.StructName.format_t s format_punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "%a@ " format_punctuation ";")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\""
Ast.StructFieldName.format_t struct_field format_punctuation "\""
format_punctuation "=" format_expr e))
(List.combine es (List.map fst (Ast.StructMap.find s ctx.ctx_structs)))
format_punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation "]"
| ETupleAccess (e1, n, s, _ts) -> (
match s with
| None ->
Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n
| Some s ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_operator "."
format_punctuation "\"" Ast.StructFieldName.format_t
(fst (List.nth (Ast.StructMap.find s ctx.ctx_structs) n))
format_punctuation "\"")
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_enum_constructor
(fst (List.nth (Ast.EnumMap.find en ctx.ctx_enums) n))
format_expr e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" format_keyword
"match" format_expr e format_keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (e, c) ->
Format.fprintf fmt "@[<hov 2>%a %a%a@ %a@]" format_punctuation "|"
format_enum_constructor c format_punctuation ":" format_expr e))
(List.combine es (List.map fst (Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> format_lit fmt l
| EApp ((EAbs (binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau =
List.map2 (fun x tau -> x, Marked.unmark tau) (Array.to_list xs) taus
in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n"
format_keyword "let" format_var x format_punctuation ":"
(format_typ ctx) tau format_punctuation "=" format_expr arg
format_keyword "in"))
xs_tau_arg format_expr body
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau =
List.map2 (fun x tau -> x, Marked.unmark tau) (Array.to_list xs) taus
in
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" format_punctuation
"λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x
format_punctuation ":" (format_typ ctx) tau format_punctuation ")"))
xs_tau format_punctuation "→" format_expr body
| EApp ((EOp (Binop ((Ast.Map | Ast.Filter) as op)), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop op
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
format_expr fmt arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop op format_with_parens
arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if"
format_expr e1 format_keyword "then" format_expr e2 format_keyword "else"
format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop op
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a%a@]" format_punctuation "⟨"
format_expr just format_punctuation "⊢" format_expr cons
format_punctuation "⟩"
else
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@ %a@ %a%a@]" format_punctuation
"⟨"
(Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "%a@ " format_punctuation ",")
format_expr)
exceptions format_punctuation "|" format_expr just format_punctuation
"⊢" format_expr cons format_punctuation "⟩"
| ErrorOnEmpty e' ->
Format.fprintf fmt "%a@ %a" format_operator "error_empty" format_with_parens
e'
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" format_keyword "assert"
format_punctuation "(" format_expr e' format_punctuation ")"
let format_scope
?(debug : bool = false)
(ctx : decl_ctx)
(fmt : Format.formatter)
((n, s) : Ast.ScopeName.t * ('m Ast.expr, 'm) scope_body) =
Format.fprintf fmt "@[<hov 2>%a %a =@ %a@]" format_keyword "let"
Ast.ScopeName.format_t n (format_expr ctx ~debug)
(Bindlib.unbox
(Ast.build_whole_scope_expr ~make_abs:Ast.make_abs
~make_let_in:Ast.make_let_in ~box_expr:Ast.box_expr ctx s
(Ast.map_mark
(fun _ -> Marked.get_mark (Ast.ScopeName.get_info n))
(fun ty -> ty)
(Ast.get_scope_body_mark s))))

55
compiler/dcalc/print.mli
View File

@ -1,55 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Printing functions for the default calculus AST *)
open Utils
(** {1 Common syntax highlighting helpers}*)
val format_base_type : Format.formatter -> string -> unit
val format_keyword : Format.formatter -> string -> unit
val format_punctuation : Format.formatter -> string -> unit
val format_operator : Format.formatter -> string -> unit
val format_lit_style : Format.formatter -> string -> unit
(** {1 Formatters} *)
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_enum_constructor : Format.formatter -> Ast.EnumConstructor.t -> unit
val format_tlit : Format.formatter -> Ast.typ_lit -> unit
val format_typ : Ast.decl_ctx -> Format.formatter -> Ast.typ -> unit
val format_lit : Format.formatter -> Ast.lit -> unit
val format_op_kind : Format.formatter -> Ast.op_kind -> unit
val format_binop : Format.formatter -> Ast.binop -> unit
val format_ternop : Format.formatter -> Ast.ternop -> unit
val format_log_entry : Format.formatter -> Ast.log_entry -> unit
val format_unop : Format.formatter -> Ast.unop -> unit
val format_var : Format.formatter -> 'm Ast.var -> unit
val format_expr :
?debug:bool (** [true] for debug printing *) ->
Ast.decl_ctx ->
Format.formatter ->
'm Ast.marked_expr ->
unit
val format_scope :
?debug:bool (** [true] for debug printing *) ->
Ast.decl_ctx ->
Format.formatter ->
Ast.ScopeName.t * ('m Ast.expr, 'm) Ast.scope_body ->
unit

261
compiler/dcalc/typing.ml
View File

@ -18,100 +18,105 @@
inference using the classical W algorithm with union-find unification. *)
open Utils
module A = Astgen
module A = Shared_ast
module Any =
Utils.Uid.Make
(struct
type info = unit
let to_string _ = "any"
let format_info fmt () = Format.fprintf fmt "any"
let equal _ _ = true
let compare _ _ = 0
end)
()
type unionfind_typ = typ Marked.pos UnionFind.elem
(** We do not reuse {!type: Dcalc.Ast.typ} because we have to include a new
[TAny] variant. Indeed, error terms can have any type and this has to be
type unionfind_typ = naked_typ Marked.pos UnionFind.elem
(** We do not reuse {!type: Dcalc.Ast.naked_typ} because we have to include a
new [TAny] variant. Indeed, error terms can have any type and this has to be
captured by the type sytem. *)
and typ =
and naked_typ =
| TLit of A.typ_lit
| TArrow of unionfind_typ * unionfind_typ
| TTuple of unionfind_typ list * A.StructName.t option
| TEnum of unionfind_typ list * A.EnumName.t
| TTuple of unionfind_typ list
| TStruct of A.StructName.t
| TEnum of A.EnumName.t
| TOption of unionfind_typ
| TArray of unionfind_typ
| TAny of Any.t
let rec typ_to_ast (ty : unionfind_typ) : A.marked_typ =
let rec typ_to_ast (ty : unionfind_typ) : A.typ =
let ty, pos = UnionFind.get (UnionFind.find ty) in
match ty with
| TLit l -> TLit l, pos
| TTuple (ts, s) -> TTuple (List.map typ_to_ast ts, s), pos
| TEnum (ts, e) -> TEnum (List.map typ_to_ast ts, e), pos
| TArrow (t1, t2) -> TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TAny _ -> TAny, pos
| TArray t1 -> TArray (typ_to_ast t1), pos
| TLit l -> A.TLit l, pos
| TTuple ts -> A.TTuple (List.map typ_to_ast ts), pos
| TStruct s -> A.TStruct s, pos
| TEnum e -> A.TEnum e, pos
| TOption t -> A.TOption (typ_to_ast t), pos
| TArrow (t1, t2) -> A.TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TAny _ -> A.TAny, pos
| TArray t1 -> A.TArray (typ_to_ast t1), pos
let rec ast_to_typ (ty : A.marked_typ) : unionfind_typ =
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
let ty' =
match Marked.unmark ty with
| TLit l -> TLit l
| TArrow (t1, t2) -> TArrow (ast_to_typ t1, ast_to_typ t2)
| TTuple (ts, s) -> TTuple (List.map (fun t -> ast_to_typ t) ts, s)
| TEnum (ts, e) -> TEnum (List.map (fun t -> ast_to_typ t) ts, e)
| TArray t -> TArray (ast_to_typ t)
| TAny -> TAny (Any.fresh ())
| A.TLit l -> TLit l
| A.TArrow (t1, t2) -> TArrow (ast_to_typ t1, ast_to_typ t2)
| A.TTuple ts -> TTuple (List.map ast_to_typ ts)
| A.TStruct s -> TStruct s
| A.TEnum e -> TEnum e
| A.TOption t -> TOption (ast_to_typ t)
| A.TArray t -> TArray (ast_to_typ t)
| A.TAny -> TAny (Any.fresh ())
in
UnionFind.make (Marked.same_mark_as ty' ty)
(** {1 Types and unification} *)
let typ_needs_parens (t : typ Marked.pos UnionFind.elem) : bool =
let typ_needs_parens (t : unionfind_typ) : bool =
let t = UnionFind.get (UnionFind.find t) in
match Marked.unmark t with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ
(ctx : Ast.decl_ctx)
(ctx : A.decl_ctx)
(fmt : Format.formatter)
(typ : typ Marked.pos UnionFind.elem) : unit =
(naked_typ : unionfind_typ) : unit =
let format_typ = format_typ ctx in
let format_typ_with_parens
(fmt : Format.formatter)
(t : typ Marked.pos UnionFind.elem) =
let format_typ_with_parens (fmt : Format.formatter) (t : unionfind_typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
let typ = UnionFind.get (UnionFind.find typ) in
match Marked.unmark typ with
| TLit l -> Format.fprintf fmt "%a" Print.format_tlit l
| TTuple (ts, None) ->
let naked_typ = UnionFind.get (UnionFind.find naked_typ) in
match Marked.unmark naked_typ with
| TLit l -> Format.fprintf fmt "%a" A.Print.tlit l
| TTuple ts ->
Format.fprintf fmt "@[<hov 2>(%a)]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ t))
ts
| TTuple (_ts, Some s) -> Format.fprintf fmt "%a" Ast.StructName.format_t s
| TEnum (_ts, e) -> Format.fprintf fmt "%a" Ast.EnumName.format_t e
| TStruct s -> Format.fprintf fmt "%a" A.StructName.format_t s
| TEnum e -> Format.fprintf fmt "%a" A.EnumName.format_t e
| TOption t ->
Format.fprintf fmt "@[<hov 2>%a@ %s@]" format_typ_with_parens t "eoption"
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a →@ %a@]" format_typ_with_parens t1
format_typ t2
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ t1
| TAny d -> Format.fprintf fmt "any[%d]" (Any.hash d)
exception
Type_error of
A.any_marked_expr
* typ Marked.pos UnionFind.elem
* typ Marked.pos UnionFind.elem
exception Type_error of A.any_expr * unionfind_typ * unionfind_typ
type mark = { pos : Pos.t; uf : unionfind_typ }
(** Raises an error if unification cannot be performed *)
let rec unify
(ctx : Ast.decl_ctx)
(e : ('a, 'm A.mark) Ast.marked_gexpr) (* used for error context *)
(t1 : typ Marked.pos UnionFind.elem)
(t2 : typ Marked.pos UnionFind.elem) : unit =
(ctx : A.decl_ctx)
(e : ('a, 'm A.mark) A.gexpr) (* used for error context *)
(t1 : unionfind_typ)
(t2 : unionfind_typ) : unit =
let unify = unify ctx in
(* Cli.debug_format "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx)
t2; *)
@ -125,25 +130,29 @@ let rec unify
unify e t11 t21;
unify e t12 t22;
None
| TTuple (ts1, s1), TTuple (ts2, s2) ->
if s1 = s2 && List.length ts1 = List.length ts2 then begin
| TTuple ts1, TTuple ts2 ->
if List.length ts1 = List.length ts2 then begin
List.iter2 (unify e) ts1 ts2;
None
end
else raise_type_error ()
| TEnum (ts1, e1), TEnum (ts2, e2) ->
if e1 = e2 && List.length ts1 = List.length ts2 then begin
List.iter2 (unify e) ts1 ts2;
| TStruct s1, TStruct s2 ->
if A.StructName.equal s1 s2 then None else raise_type_error ()
| TEnum e1, TEnum e2 ->
if A.EnumName.equal e1 e2 then None else raise_type_error ()
| TOption t1, TOption t2 ->
unify e t1 t2;
None
end
else raise_type_error ()
| TArray t1', TArray t2' ->
unify e t1' t2';
None
| TAny _, TAny _ -> None
| TAny _, _ -> Some t2_repr
| _, TAny _ -> Some t1_repr
| _ -> raise_type_error ()
| ( ( TLit _ | TArrow _ | TTuple _ | TStruct _ | TEnum _ | TOption _
| TArray _ ),
_ ) ->
raise_type_error ()
in
let t_union = UnionFind.union t1 t2 in
match repr with None -> () | Some t_repr -> UnionFind.set t_union t_repr
@ -194,7 +203,7 @@ let handle_type_error ctx e t1 t2 =
This allows us to have a simpler type system, while we argue the syntactic
burden of operator annotations helps the programmer visualize the type flow
in the code. *)
let op_type (op : A.operator Marked.pos) : typ Marked.pos UnionFind.elem =
let op_type (op : A.operator Marked.pos) : unionfind_typ =
let pos = Marked.get_mark op in
let bt = UnionFind.make (TLit TBool, pos) in
let it = UnionFind.make (TLit TInt, pos) in
@ -260,9 +269,9 @@ let op_type (op : A.operator Marked.pos) : typ Marked.pos UnionFind.elem =
(** {1 Double-directed typing} *)
type 'e env = ('e, typ Marked.pos UnionFind.elem) Var.Map.t
type 'e env = ('e, unionfind_typ) A.Var.Map.t
let add_pos e ty = Marked.mark (Ast.pos e) ty
let add_pos e ty = Marked.mark (A.Expr.pos e) ty
let ty (_, { uf; _ }) = uf
let ( let+ ) x f = Bindlib.box_apply f x
let ( and+ ) x1 x2 = Bindlib.box_pair x1 x2
@ -289,25 +298,25 @@ let box_ty e = Bindlib.unbox (Bindlib.box_apply ty e)
(** Infers the most permissive type from an expression *)
let rec typecheck_expr_bottom_up
(ctx : Ast.decl_ctx)
(ctx : A.decl_ctx)
(env : 'm Ast.expr env)
(e : 'm Ast.marked_expr) : (A.dcalc, mark) A.marked_gexpr Bindlib.box =
(* Cli.debug_format "Looking for type of %a" (Print.format_expr ~debug:true
ctx) e; *)
let pos_e = Ast.pos e in
let mark (e : (A.dcalc, mark) A.gexpr) uf =
(e : 'm Ast.expr) : (A.dcalc, mark) A.gexpr Bindlib.box =
(* Cli.debug_format "Looking for type of %a" (Expr.format ~debug:true ctx)
e; *)
let pos_e = A.Expr.pos e in
let mark (e : (A.dcalc, mark) A.naked_gexpr) uf =
Marked.mark { uf; pos = pos_e } e
in
let unionfind_make ?(pos = e) t = UnionFind.make (add_pos pos t) in
let mark_with_uf e1 ?pos ty = mark e1 (unionfind_make ?pos ty) in
match Marked.unmark e with
| A.EVar v -> begin
match Var.Map.find_opt v env with
match A.Var.Map.find_opt v env with
| Some t ->
let+ v' = Bindlib.box_var (Var.translate v) in
let+ v' = Bindlib.box_var (A.Var.translate v) in
mark v' t
| None ->
Errors.raise_spanned_error (Ast.pos e)
Errors.raise_spanned_error (A.Expr.pos e)
"Variable %s not found in the current context." (Bindlib.name_of v)
end
| A.ELit (LBool _) as e1 -> Bindlib.box @@ mark_with_uf e1 (TLit TBool)
@ -320,14 +329,21 @@ let rec typecheck_expr_bottom_up
| A.ELit LUnit as e1 -> Bindlib.box @@ mark_with_uf e1 (TLit TUnit)
| A.ELit LEmptyError as e1 ->
Bindlib.box @@ mark_with_uf e1 (TAny (Any.fresh ()))
| A.ETuple (es, s) ->
| A.ETuple (es, None) ->
let+ es = bmap (typecheck_expr_bottom_up ctx env) es in
mark_with_uf (ETuple (es, s)) (TTuple (List.map ty es, s))
mark_with_uf (ETuple (es, None)) (TTuple (List.map ty es))
| A.ETuple (es, Some s_name) ->
let tys =
List.map
(fun (_, ty) -> ast_to_typ ty)
(A.StructMap.find s_name ctx.A.ctx_structs)
in
let+ es = bmap2 (typecheck_expr_top_down ctx env) tys es in
mark_with_uf (ETuple (es, Some s_name)) (TStruct s_name)
| A.ETupleAccess (e1, n, s, typs) -> begin
let utyps = List.map ast_to_typ typs in
let+ e1 =
typecheck_expr_top_down ctx env (unionfind_make (TTuple (utyps, s))) e1
in
let tuple_ty = match s with None -> TTuple utyps | Some s -> TStruct s in
let+ e1 = typecheck_expr_top_down ctx env (unionfind_make tuple_ty) e1 in
match List.nth_opt utyps n with
| Some t' -> mark (ETupleAccess (e1, n, s, typs)) t'
| None ->
@ -342,18 +358,18 @@ let rec typecheck_expr_bottom_up
match List.nth_opt ts' n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error (Ast.pos e)
Errors.raise_spanned_error (A.Expr.pos e)
"Expression should have a sum type with at least %d cases but only \
has %d"
n (List.length ts')
in
let+ e1' = typecheck_expr_top_down ctx env ts_n e1 in
mark_with_uf (A.EInj (e1', n, e_name, ts)) (TEnum (ts', e_name))
mark_with_uf (A.EInj (e1', n, e_name, ts)) (TEnum e_name)
| A.EMatch (e1, es, e_name) ->
let enum_cases =
List.map (fun e' -> unionfind_make ~pos:e' (TAny (Any.fresh ()))) es
in
let t_e1 = UnionFind.make (add_pos e1 (TEnum (enum_cases, e_name))) in
let t_e1 = UnionFind.make (add_pos e1 (TEnum e_name)) in
let t_ret = unionfind_make ~pos:e (TAny (Any.fresh ())) in
let+ e1' = typecheck_expr_top_down ctx env t_e1 e1
and+ es' =
@ -367,16 +383,16 @@ let rec typecheck_expr_bottom_up
mark (EMatch (e1', es', e_name)) t_ret
| A.EAbs (binder, taus) ->
if Bindlib.mbinder_arity binder <> List.length taus then
Errors.raise_spanned_error (Ast.pos e)
Errors.raise_spanned_error (A.Expr.pos e)
"function has %d variables but was supplied %d types"
(Bindlib.mbinder_arity binder)
(List.length taus)
else
let xs, body = Bindlib.unmbind binder in
let xs' = Array.map Var.translate xs in
let xs' = Array.map A.Var.translate xs in
let xstaus = List.mapi (fun i tau -> xs.(i), ast_to_typ tau) taus in
let env =
List.fold_left (fun env (x, tau) -> Var.Map.add x tau env) env xstaus
List.fold_left (fun env (x, tau) -> A.Var.Map.add x tau env) env xstaus
in
let body' = typecheck_expr_bottom_up ctx env body in
let t_func =
@ -445,15 +461,15 @@ let rec typecheck_expr_bottom_up
(** Checks whether the expression can be typed with the provided type *)
and typecheck_expr_top_down
(ctx : Ast.decl_ctx)
(ctx : A.decl_ctx)
(env : 'm Ast.expr env)
(tau : typ Marked.pos UnionFind.elem)
(e : 'm Ast.marked_expr) : (A.dcalc, mark) A.marked_gexpr Bindlib.box =
(* Cli.debug_format "Propagating type %a for expr %a" (format_typ ctx) tau
(Print.format_expr ctx) e; *)
let pos_e = Ast.pos e in
(tau : unionfind_typ)
(e : 'm Ast.expr) : (A.dcalc, mark) A.gexpr Bindlib.box =
(* Cli.debug_format "Propagating type %a for naked_expr %a" (format_typ ctx)
tau (Expr.format ctx) e; *)
let pos_e = A.Expr.pos e in
let mark e = Marked.mark { uf = tau; pos = pos_e } e in
let unify_and_mark (e' : (A.dcalc, mark) A.gexpr) tau' =
let unify_and_mark (e' : (A.dcalc, mark) A.naked_gexpr) tau' =
(* This try...with was added because of
[tests/test_bool/bad/bad_assert.catala_en] but we shouldn't need it.
TODO: debug why it is needed here. *)
@ -464,9 +480,9 @@ and typecheck_expr_top_down
let unionfind_make ?(pos = e) t = UnionFind.make (add_pos pos t) in
match Marked.unmark e with
| A.EVar v -> begin
match Var.Map.find_opt v env with
match A.Var.Map.find_opt v env with
| Some tau' ->
let+ v' = Bindlib.box_var (Var.translate v) in
let+ v' = Bindlib.box_var (A.Var.translate v) in
unify_and_mark v' tau'
| None ->
Errors.raise_spanned_error pos_e
@ -488,20 +504,29 @@ and typecheck_expr_top_down
Bindlib.box @@ unify_and_mark e1 (unionfind_make (TLit TUnit))
| A.ELit LEmptyError as e1 ->
Bindlib.box @@ unify_and_mark e1 (unionfind_make (TAny (Any.fresh ())))
| A.ETuple (es, s) ->
| A.ETuple (es, None) ->
let+ es' = bmap (typecheck_expr_bottom_up ctx env) es in
unify_and_mark
(A.ETuple (es', s))
(unionfind_make (TTuple (List.map ty es', s)))
(A.ETuple (es', None))
(unionfind_make (TTuple (List.map ty es')))
| A.ETuple (es, Some s_name) ->
let tys =
List.map
(fun (_, ty) -> ast_to_typ ty)
(A.StructMap.find s_name ctx.A.ctx_structs)
in
let+ es' = bmap2 (typecheck_expr_top_down ctx env) tys es in
unify_and_mark
(A.ETuple (es', Some s_name))
(unionfind_make (TStruct s_name))
| A.ETupleAccess (e1, n, s, typs) -> begin
let typs' = List.map ast_to_typ typs in
let+ e1' =
typecheck_expr_top_down ctx env (unionfind_make (TTuple (typs', s))) e1
in
let tuple_ty = match s with None -> TTuple typs' | Some s -> TStruct s in
let+ e1' = typecheck_expr_top_down ctx env (unionfind_make tuple_ty) e1 in
match List.nth_opt typs' n with
| Some t1n -> unify_and_mark (A.ETupleAccess (e1', n, s, typs)) t1n
| None ->
Errors.raise_spanned_error (Ast.pos e1)
Errors.raise_spanned_error (A.Expr.pos e1)
"Expression should have a tuple type with at least %d elements but \
only has %d"
n (List.length typs)
@ -512,23 +537,19 @@ and typecheck_expr_top_down
match List.nth_opt ts' n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error (Ast.pos e)
Errors.raise_spanned_error (A.Expr.pos e)
"Expression should have a sum type with at least %d cases but only \
has %d"
n (List.length ts)
in
let+ e1' = typecheck_expr_top_down ctx env ts_n e1 in
unify_and_mark
(A.EInj (e1', n, e_name, ts))
(unionfind_make (TEnum (ts', e_name)))
unify_and_mark (A.EInj (e1', n, e_name, ts)) (unionfind_make (TEnum e_name))
| A.EMatch (e1, es, e_name) ->
let enum_cases =
List.map (fun e' -> unionfind_make ~pos:e' (TAny (Any.fresh ()))) es
in
let e1' =
typecheck_expr_top_down ctx env
(unionfind_make ~pos:e1 (TEnum (enum_cases, e_name)))
e1
typecheck_expr_top_down ctx env (unionfind_make ~pos:e1 (TEnum e_name)) e1
in
let t_ret = unionfind_make ~pos:e (TAny (Any.fresh ())) in
let+ e1'
@ -543,19 +564,19 @@ and typecheck_expr_top_down
unify_and_mark (EMatch (e1', es', e_name)) t_ret
| A.EAbs (binder, t_args) ->
if Bindlib.mbinder_arity binder <> List.length t_args then
Errors.raise_spanned_error (Ast.pos e)
Errors.raise_spanned_error (A.Expr.pos e)
"function has %d variables but was supplied %d types"
(Bindlib.mbinder_arity binder)
(List.length t_args)
else
let xs, body = Bindlib.unmbind binder in
let xs' = Array.map Var.translate xs in
let xs' = Array.map A.Var.translate xs in
let xstaus =
List.map2 (fun x t_arg -> x, ast_to_typ t_arg) (Array.to_list xs) t_args
in
let env =
List.fold_left
(fun env (x, t_arg) -> Var.Map.add x t_arg env)
(fun env (x, t_arg) -> A.Var.Map.add x t_arg env)
env xstaus
in
let body' = typecheck_expr_bottom_up ctx env body in
@ -627,25 +648,22 @@ let wrap ctx f e =
let get_ty_mark { uf; pos } = A.Typed { ty = typ_to_ast uf; pos }
(* Infer the type of an expression *)
let infer_types (ctx : Ast.decl_ctx) (e : 'm Ast.marked_expr) :
Ast.typed Ast.marked_expr Bindlib.box =
Astgen_utils.map_gexpr_marks ~f:get_ty_mark
let infer_types (ctx : A.decl_ctx) (e : 'm Ast.expr) :
A.typed Ast.expr Bindlib.box =
A.Expr.map_marks ~f:get_ty_mark
@@ Bindlib.unbox
@@ wrap ctx (typecheck_expr_bottom_up ctx Var.Map.empty) e
@@ wrap ctx (typecheck_expr_bottom_up ctx A.Var.Map.empty) e
let infer_type (type m) ctx (e : m Ast.marked_expr) =
let infer_type (type m) ctx (e : m Ast.expr) =
match Marked.get_mark e with
| A.Typed { ty; _ } -> ty
| A.Untyped _ -> Ast.ty (Bindlib.unbox (infer_types ctx e))
| A.Untyped _ -> A.Expr.ty (Bindlib.unbox (infer_types ctx e))
(** Typechecks an expression given an expected type *)
let check_type
(ctx : Ast.decl_ctx)
(e : 'm Ast.marked_expr)
(tau : A.typ Marked.pos) =
let check_type (ctx : A.decl_ctx) (e : 'm Ast.expr) (tau : A.typ) =
(* todo: consider using the already inferred type if ['m] = [typed] *)
ignore
@@ wrap ctx (typecheck_expr_top_down ctx Var.Map.empty (ast_to_typ tau)) e
@@ wrap ctx (typecheck_expr_top_down ctx A.Var.Map.empty (ast_to_typ tau)) e
let infer_types_program prg =
let ctx = prg.A.decl_ctx in
@ -664,10 +682,7 @@ let infer_types_program prg =
} ->
let scope_pos = Marked.get_mark (A.ScopeName.get_info scope_name) in
let struct_ty struct_name =
let struc = A.StructMap.find struct_name ctx.A.ctx_structs in
ast_to_typ
(Marked.mark scope_pos
(A.TTuple (List.map snd struc, Some struct_name)))
UnionFind.make (Marked.mark scope_pos (TStruct struct_name))
in
let ty_in = struct_ty s_in in
let ty_out = struct_ty s_out in
@ -680,7 +695,7 @@ let infer_types_program prg =
Bindlib.box_apply
(fun e1 ->
wrap ctx (unify ctx e (ty e1)) ty_out;
let e1 = Astgen_utils.map_gexpr_marks ~f:get_ty_mark e1 in
let e1 = A.Expr.map_marks ~f:get_ty_mark e1 in
A.Result (Bindlib.unbox e1))
e'
| A.ScopeLet
@ -694,13 +709,13 @@ let infer_types_program prg =
let ty_e = ast_to_typ scope_let_typ in
let e = wrap ctx (typecheck_expr_bottom_up ctx env) e0 in
let var, next = Bindlib.unbind scope_let_next in
let env = Var.Map.add var ty_e env in
let env = A.Var.Map.add var ty_e env in
let next = process_scope_body_expr env next in
let scope_let_next = Bindlib.bind_var (Var.translate var) next in
let scope_let_next = Bindlib.bind_var (A.Var.translate var) next in
Bindlib.box_apply2
(fun e scope_let_next ->
wrap ctx (unify ctx e0 (ty e)) ty_e;
let e = Astgen_utils.map_gexpr_marks ~f:get_ty_mark e in
let e = A.Expr.map_marks ~f:get_ty_mark e in
A.ScopeLet
{
scope_let_kind;
@ -713,15 +728,15 @@ let infer_types_program prg =
in
let scope_body_expr =
let var, e = Bindlib.unbind body in
let env = Var.Map.add var ty_in env in
let env = A.Var.Map.add var ty_in env in
let e' = process_scope_body_expr env e in
Bindlib.bind_var (Var.translate var) e'
Bindlib.bind_var (A.Var.translate var) e'
in
let scope_next =
let scope_var, next = Bindlib.unbind scope_next in
let env = Var.Map.add scope_var ty_scope env in
let env = A.Var.Map.add scope_var ty_scope env in
let next' = process_scopes env next in
Bindlib.bind_var (Var.translate scope_var) next'
Bindlib.bind_var (A.Var.translate scope_var) next'
in
Bindlib.box_apply2
(fun scope_body_expr scope_next ->
@ -738,6 +753,6 @@ let infer_types_program prg =
})
scope_body_expr scope_next
in
let scopes = wrap ctx (process_scopes Var.Map.empty) prg.scopes in
let scopes = wrap ctx (process_scopes A.Var.Map.empty) prg.scopes in
Bindlib.box_apply (fun scopes -> { A.decl_ctx = ctx; scopes }) scopes
|> Bindlib.unbox

15
compiler/dcalc/typing.mli
View File

@ -17,18 +17,15 @@
(** Typing for the default calculus. Because of the error terms, we perform type
inference using the classical W algorithm with union-find unification. *)
val infer_types :
Ast.decl_ctx ->
Ast.untyped Ast.marked_expr ->
Ast.typed Ast.marked_expr Bindlib.box
open Shared_ast
val infer_types : decl_ctx -> untyped Ast.expr -> typed Ast.expr Bindlib.box
(** Infers types everywhere on the given expression, and adds (or replaces) type
annotations on each node *)
val infer_type : Ast.decl_ctx -> 'm Ast.marked_expr -> Ast.typ Utils.Marked.pos
val infer_type : decl_ctx -> 'm Ast.expr -> typ
(** Gets the outer type of the given expression, using either the existing
annotations or inference *)
val check_type :
Ast.decl_ctx -> 'm Ast.marked_expr -> Ast.typ Utils.Marked.pos -> unit
val infer_types_program : Ast.untyped Ast.program -> Ast.typed Ast.program
val check_type : decl_ctx -> 'm Ast.expr -> typ -> unit
val infer_types_program : untyped Ast.program -> typed Ast.program

281
compiler/desugared/ast.ml
View File

@ -17,6 +17,7 @@
(** Abstract syntax tree of the desugared representation *)
open Utils
open Shared_ast
(** {1 Names, Maps and Keys} *)
@ -34,21 +35,12 @@ module LabelName : Uid.Id with type info = Uid.MarkedString.info =
module LabelMap : Map.S with type key = LabelName.t = Map.Make (LabelName)
module LabelSet : Set.S with type elt = LabelName.t = Set.Make (LabelName)
module StateName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar)
module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar)
(** Inside a scope, a definition can refer either to a scope def, or a subscope
def *)
module ScopeDef = struct
type t =
| Var of ScopeVar.t * StateName.t option
| SubScopeVar of Scopelang.Ast.SubScopeName.t * ScopeVar.t
| SubScopeVar of SubScopeName.t * ScopeVar.t
(** In this case, the [ScopeVar.t] lives inside the context of the
subscope's original declaration *)
@ -64,15 +56,14 @@ module ScopeDef = struct
let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp
| SubScopeVar (x', x), SubScopeVar (y', y) ->
let cmp = Scopelang.Ast.SubScopeName.compare x' y' in
let cmp = SubScopeName.compare x' y' in
if cmp = 0 then ScopeVar.compare x y else cmp
let get_position x =
match x with
| Var (x, None) -> Marked.get_mark (ScopeVar.get_info x)
| Var (_, Some sx) -> Marked.get_mark (StateName.get_info sx)
| SubScopeVar (x, _) ->
Marked.get_mark (Scopelang.Ast.SubScopeName.get_info x)
| SubScopeVar (x, _) -> Marked.get_mark (SubScopeName.get_info x)
let format_t fmt x =
match x with
@ -80,15 +71,13 @@ module ScopeDef = struct
| Var (v, Some sv) ->
Format.fprintf fmt "%a.%a" ScopeVar.format_t v StateName.format_t sv
| SubScopeVar (s, v) ->
Format.fprintf fmt "%a.%a" Scopelang.Ast.SubScopeName.format_t s
ScopeVar.format_t v
Format.fprintf fmt "%a.%a" SubScopeName.format_t s ScopeVar.format_t v
let hash x =
match x with
| Var (v, None) -> ScopeVar.hash v
| Var (v, Some sv) -> Int.logxor (ScopeVar.hash v) (StateName.hash sv)
| SubScopeVar (w, v) ->
Int.logxor (Scopelang.Ast.SubScopeName.hash w) (ScopeVar.hash v)
| SubScopeVar (w, v) -> Int.logxor (SubScopeName.hash w) (ScopeVar.hash v)
end
module ScopeDefMap : Map.S with type key = ScopeDef.t = Map.Make (ScopeDef)
@ -96,179 +85,22 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t = Set.Make (ScopeDef)
(** {1 AST} *)
type location =
| ScopeVar of ScopeVar.t Marked.pos * StateName.t option
| SubScopeVar of
Scopelang.Ast.ScopeName.t
* Scopelang.Ast.SubScopeName.t Marked.pos
* ScopeVar.t Marked.pos
type location = desugared glocation
module LocationSet : Set.S with type elt = location Marked.pos =
Set.Make (struct
type t = location Marked.pos
let compare x y =
match Marked.unmark x, Marked.unmark y with
| ScopeVar (vx, None), ScopeVar (vy, None)
| ScopeVar (vx, Some _), ScopeVar (vy, None)
| ScopeVar (vx, None), ScopeVar (vy, Some _) ->
ScopeVar.compare (Marked.unmark vx) (Marked.unmark vy)
| ScopeVar ((x, _), Some sx), ScopeVar ((y, _), Some sy) ->
let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp
| ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)),
SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) ->
let c = Scopelang.Ast.SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| ScopeVar _, SubScopeVar _ -> -1
| SubScopeVar _, ScopeVar _ -> 1
let compare = Expr.compare_location
end)
type marked_expr = expr Marked.pos
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
type expr = (desugared, untyped mark) gexpr
and expr =
| ELocation of location
| EVar of expr Bindlib.var
| EStruct of
Scopelang.Ast.StructName.t * marked_expr Scopelang.Ast.StructFieldMap.t
| EStructAccess of
marked_expr * Scopelang.Ast.StructFieldName.t * Scopelang.Ast.StructName.t
| EEnumInj of
marked_expr * Scopelang.Ast.EnumConstructor.t * Scopelang.Ast.EnumName.t
| EMatch of
marked_expr
* Scopelang.Ast.EnumName.t
* marked_expr Scopelang.Ast.EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of
(expr, marked_expr) Bindlib.mbinder * Scopelang.Ast.typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module Expr = struct
module ExprMap = Map.Make (struct
type t = expr
(** Syntactic comparison, up to locations and alpha-renaming *)
let rec compare e1 e2 =
let rec list_compare cmp l1 l2 =
(* List.compare is available from OCaml 4.12 on *)
match l1, l2 with
| [], [] -> 0
| [], _ :: _ -> -1
| _ :: _, [] -> 1
| a1 :: l1, a2 :: l2 ->
let c = cmp a1 a2 in
if c <> 0 then c else list_compare cmp l1 l2
in
match e1, e2 with
| ELocation _, ELocation _ -> 0
| EVar v1, EVar v2 -> Bindlib.compare_vars v1 v2
| EStruct (name1, field_map1), EStruct (name2, field_map2) -> (
match Scopelang.Ast.StructName.compare name1 name2 with
| 0 ->
Scopelang.Ast.StructFieldMap.compare (Marked.compare compare) field_map1
field_map2
| n -> n)
| ( EStructAccess ((e1, _), field_name1, struct_name1),
EStructAccess ((e2, _), field_name2, struct_name2) ) -> (
match compare e1 e2 with
| 0 -> (
match Scopelang.Ast.StructFieldName.compare field_name1 field_name2 with
| 0 -> Scopelang.Ast.StructName.compare struct_name1 struct_name2
| n -> n)
| n -> n)
| EEnumInj ((e1, _), cstr1, name1), EEnumInj ((e2, _), cstr2, name2) -> (
match compare e1 e2 with
| 0 -> (
match Scopelang.Ast.EnumName.compare name1 name2 with
| 0 -> Scopelang.Ast.EnumConstructor.compare cstr1 cstr2
| n -> n)
| n -> n)
| EMatch ((e1, _), name1, emap1), EMatch ((e2, _), name2, emap2) -> (
match compare e1 e2 with
| 0 -> (
match Scopelang.Ast.EnumName.compare name1 name2 with
| 0 ->
Scopelang.Ast.EnumConstructorMap.compare (Marked.compare compare)
emap1 emap2
| n -> n)
| n -> n)
| ELit l1, ELit l2 -> Stdlib.compare l1 l2
| EAbs (binder1, typs1), EAbs (binder2, typs2) -> (
match
list_compare (Marked.compare Scopelang.Ast.Typ.compare) typs1 typs2
with
| 0 ->
let _, (e1, _), (e2, _) = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
| n -> n)
| EApp ((f1, _), args1), EApp ((f2, _), args2) -> (
match compare f1 f2 with
| 0 -> list_compare (fun (x1, _) (x2, _) -> compare x1 x2) args1 args2
| n -> n)
| EOp op1, EOp op2 -> Stdlib.compare op1 op2
| ( EDefault (exs1, (just1, _), (cons1, _)),
EDefault (exs2, (just2, _), (cons2, _)) ) -> (
match compare just1 just2 with
| 0 -> (
match compare cons1 cons2 with
| 0 -> list_compare (Marked.compare compare) exs1 exs2
| n -> n)
| n -> n)
| ( EIfThenElse ((i1, _), (t1, _), (e1, _)),
EIfThenElse ((i2, _), (t2, _), (e2, _)) ) -> (
match compare i1 i2 with
| 0 -> ( match compare t1 t2 with 0 -> compare e1 e2 | n -> n)
| n -> n)
| EArray a1, EArray a2 ->
list_compare (fun (e1, _) (e2, _) -> compare e1 e2) a1 a2
| ErrorOnEmpty (e1, _), ErrorOnEmpty (e2, _) -> compare e1 e2
| ELocation _, _ -> -1
| _, ELocation _ -> 1
| EVar _, _ -> -1
| _, EVar _ -> 1
| EStruct _, _ -> -1
| _, EStruct _ -> 1
| EStructAccess _, _ -> -1
| _, EStructAccess _ -> 1
| EEnumInj _, _ -> -1
| _, EEnumInj _ -> 1
| EMatch _, _ -> -1
| _, EMatch _ -> 1
| ELit _, _ -> -1
| _, ELit _ -> 1
| EAbs _, _ -> -1
| _, EAbs _ -> 1
| EApp _, _ -> -1
| _, EApp _ -> 1
| EOp _, _ -> -1
| _, EOp _ -> 1
| EDefault _, _ -> -1
| _, EDefault _ -> 1
| EIfThenElse _, _ -> -1
| _, EIfThenElse _ -> 1
| EArray _, _ -> -1
| _, EArray _ -> 1
end
module ExprMap = Map.Make (Expr)
module Var = struct
type t = expr Bindlib.var
let make (s : string) : t =
Bindlib.new_var (fun (x : expr Bindlib.var) : expr -> EVar x) s
let compare x y = Bindlib.compare_vars x y
end
type vars = expr Bindlib.mvar
let compare = Expr.compare
end)
type exception_situation =
| BaseCase
@ -279,9 +111,9 @@ type label_situation = ExplicitlyLabeled of LabelName.t Marked.pos | Unlabeled
type rule = {
rule_id : RuleName.t;
rule_just : expr Marked.pos Bindlib.box;
rule_cons : expr Marked.pos Bindlib.box;
rule_parameter : (Var.t * Scopelang.Ast.typ Marked.pos) option;
rule_just : expr Bindlib.box;
rule_cons : expr Bindlib.box;
rule_parameter : (expr Var.t * typ) option;
rule_exception : exception_situation;
rule_label : label_situation;
}
@ -294,26 +126,26 @@ module Rule = struct
let compare r1 r2 =
match r1.rule_parameter, r2.rule_parameter with
| None, None -> (
let j1, _ = Bindlib.unbox r1.rule_just in
let j2, _ = Bindlib.unbox r2.rule_just in
let j1 = Bindlib.unbox r1.rule_just in
let j2 = Bindlib.unbox r2.rule_just in
match Expr.compare j1 j2 with
| 0 ->
let c1, _ = Bindlib.unbox r1.rule_cons in
let c2, _ = Bindlib.unbox r2.rule_cons in
let c1 = Bindlib.unbox r1.rule_cons in
let c2 = Bindlib.unbox r2.rule_cons in
Expr.compare c1 c2
| n -> n)
| Some (v1, (t1, _)), Some (v2, (t2, _)) -> (
match Scopelang.Ast.Typ.compare t1 t2 with
| Some (v1, t1), Some (v2, t2) -> (
match Shared_ast.Expr.compare_typ t1 t2 with
| 0 -> (
let open Bindlib in
let b1 = unbox (bind_var v1 r1.rule_just) in
let b2 = unbox (bind_var v2 r2.rule_just) in
let _, (j1, _), (j2, _) = unbind2 b1 b2 in
let _, j1, j2 = unbind2 b1 b2 in
match Expr.compare j1 j2 with
| 0 ->
let b1 = unbox (bind_var v1 r1.rule_cons) in
let b2 = unbox (bind_var v2 r2.rule_cons) in
let _, (c1, _), (c2, _) = unbind2 b1 b2 in
let _, c1, c2 = unbind2 b1 b2 in
Expr.compare c1 c2
| n -> n)
| n -> n)
@ -321,12 +153,10 @@ module Rule = struct
| Some _, None -> 1
end
let empty_rule
(pos : Pos.t)
(have_parameter : Scopelang.Ast.typ Marked.pos option) : rule =
let empty_rule (pos : Pos.t) (have_parameter : typ option) : rule =
{
rule_just = Bindlib.box (ELit (Dcalc.Ast.LBool false), pos);
rule_cons = Bindlib.box (ELit Dcalc.Ast.LEmptyError, pos);
rule_just = Bindlib.box (ELit (LBool false), Untyped { pos });
rule_cons = Bindlib.box (ELit LEmptyError, Untyped { pos });
rule_parameter =
(match have_parameter with
| Some typ -> Some (Var.make "dummy", typ)
@ -336,12 +166,10 @@ let empty_rule
rule_label = Unlabeled;
}
let always_false_rule
(pos : Pos.t)
(have_parameter : Scopelang.Ast.typ Marked.pos option) : rule =
let always_false_rule (pos : Pos.t) (have_parameter : typ option) : rule =
{
rule_just = Bindlib.box (ELit (Dcalc.Ast.LBool true), pos);
rule_cons = Bindlib.box (ELit (Dcalc.Ast.LBool false), pos);
rule_just = Bindlib.box (ELit (LBool true), Untyped { pos });
rule_cons = Bindlib.box (ELit (LBool false), Untyped { pos });
rule_parameter =
(match have_parameter with
| Some typ -> Some (Var.make "dummy", typ)
@ -351,7 +179,7 @@ let always_false_rule
rule_label = Unlabeled;
}
type assertion = expr Marked.pos Bindlib.box
type assertion = expr Bindlib.box
type variation_typ = Increasing | Decreasing
type reference_typ = Decree | Law
@ -361,7 +189,7 @@ type meta_assertion =
type scope_def = {
scope_def_rules : rule RuleMap.t;
scope_def_typ : Scopelang.Ast.typ Marked.pos;
scope_def_typ : typ;
scope_def_is_condition : bool;
scope_def_io : Scopelang.Ast.io;
}
@ -370,8 +198,8 @@ type var_or_states = WholeVar | States of StateName.t list
type scope = {
scope_vars : var_or_states ScopeVarMap.t;
scope_sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
scope_uid : Scopelang.Ast.ScopeName.t;
scope_sub_scopes : ScopeName.t Scopelang.Ast.SubScopeMap.t;
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
@ -379,25 +207,24 @@ type scope = {
type program = {
program_scopes : scope Scopelang.Ast.ScopeMap.t;
program_enums : Scopelang.Ast.enum_ctx;
program_structs : Scopelang.Ast.struct_ctx;
program_ctx : decl_ctx;
}
let rec locations_used (e : expr Marked.pos) : LocationSet.t =
let rec locations_used (e : expr) : LocationSet.t =
match Marked.unmark e with
| ELocation l -> LocationSet.singleton (l, Marked.get_mark e)
| ELocation l -> LocationSet.singleton (l, Expr.pos e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
locations_used body
| EStruct (_, es) ->
Scopelang.Ast.StructFieldMap.fold
StructFieldMap.fold
(fun _ e' acc -> LocationSet.union acc (locations_used e'))
es LocationSet.empty
| EStructAccess (e1, _, _) -> locations_used e1
| EEnumInj (e1, _, _) -> locations_used e1
| EMatch (e1, _, es) ->
Scopelang.Ast.EnumConstructorMap.fold
| EMatchS (e1, _, es) ->
EnumConstructorMap.fold
(fun _ e' acc -> LocationSet.union acc (locations_used e'))
es (locations_used e1)
| EApp (e1, args) ->
@ -425,7 +252,7 @@ let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
(fun (loc, loc_pos) acc ->
ScopeDefMap.add
(match loc with
| ScopeVar (v, st) -> ScopeDef.Var (Marked.unmark v, st)
| DesugaredScopeVar (v, st) -> ScopeDef.Var (Marked.unmark v, st)
| SubScopeVar (_, sub_index, sub_var) ->
ScopeDef.SubScopeVar (Marked.unmark sub_index, Marked.unmark sub_var))
loc_pos acc)
@ -440,31 +267,3 @@ let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
in
add_locs acc locs)
def ScopeDefMap.empty
let make_var ((x, pos) : Var.t Marked.pos) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun v -> v, pos) (Bindlib.box_var x)
let make_abs
(xs : vars)
(e : expr Marked.pos Bindlib.box)
(taus : Scopelang.Ast.typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun b -> EAbs (b, taus), pos) (Bindlib.bind_mvar xs e)
let make_app
(e : expr Marked.pos Bindlib.box)
(u : expr Marked.pos Bindlib.box list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply2 (fun e u -> EApp (e, u), pos) e (Bindlib.box_list u)
let make_let_in
(x : Var.t)
(tau : Scopelang.Ast.typ Marked.pos)
(e1 : expr Marked.pos Bindlib.box)
(e2 : expr Marked.pos Bindlib.box) : expr Marked.pos Bindlib.box =
Bindlib.box_apply2
(fun e u -> EApp (e, u), Marked.get_mark (Bindlib.unbox e2))
(make_abs (Array.of_list [x]) e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(Bindlib.box_list [e1])
module VarMap = Map.Make (Var)

106
compiler/desugared/ast.mli
View File

@ -17,6 +17,7 @@
(** Abstract syntax tree of the desugared representation *)
open Utils
open Shared_ast
(** {1 Names, Maps and Keys} *)
@ -27,17 +28,13 @@ module RuleSet : Set.S with type elt = RuleName.t
module LabelName : Uid.Id with type info = Uid.MarkedString.info
module LabelMap : Map.S with type key = LabelName.t
module LabelSet : Set.S with type elt = LabelName.t
module StateName : Uid.Id with type info = Uid.MarkedString.info
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info
module ScopeVarSet : Set.S with type elt = ScopeVar.t
module ScopeVarMap : Map.S with type key = ScopeVar.t
(** Inside a scope, a definition can refer either to a scope def, or a subscope
def *)
module ScopeDef : sig
type t =
| Var of ScopeVar.t * StateName.t option
| SubScopeVar of Scopelang.Ast.SubScopeName.t * ScopeVar.t
| SubScopeVar of SubScopeName.t * ScopeVar.t
val compare : t -> t -> int
val get_position : t -> Pos.t
@ -50,80 +47,16 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t
(** {1 AST} *)
(**{2 Expressions}*)
type location =
| ScopeVar of ScopeVar.t Marked.pos * StateName.t option
| SubScopeVar of
Scopelang.Ast.ScopeName.t
* Scopelang.Ast.SubScopeName.t Marked.pos
* ScopeVar.t Marked.pos
(** {2 Expressions} *)
type expr = (desugared, untyped mark) gexpr
(** See {!type:Shared_ast.naked_gexpr} for the complete definition *)
type location = desugared glocation
module LocationSet : Set.S with type elt = location Marked.pos
type marked_expr = expr Marked.pos
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
and expr =
| ELocation of location
| EVar of expr Bindlib.var
| EStruct of
Scopelang.Ast.StructName.t * marked_expr Scopelang.Ast.StructFieldMap.t
| EStructAccess of
marked_expr * Scopelang.Ast.StructFieldName.t * Scopelang.Ast.StructName.t
| EEnumInj of
marked_expr * Scopelang.Ast.EnumConstructor.t * Scopelang.Ast.EnumName.t
| EMatch of
marked_expr
* Scopelang.Ast.EnumName.t
* marked_expr Scopelang.Ast.EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of
(expr, marked_expr) Bindlib.mbinder * Scopelang.Ast.typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module ExprMap : Map.S with type key = expr
(** {2 Variable helpers} *)
module Var : sig
type t = expr Bindlib.var
val make : string -> t
val compare : t -> t -> int
end
module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Marked.pos -> expr Marked.pos Bindlib.box
val make_abs :
vars ->
expr Marked.pos Bindlib.box ->
Scopelang.Ast.typ Marked.pos list ->
Pos.t ->
expr Marked.pos Bindlib.box
val make_app :
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
Pos.t ->
expr Marked.pos Bindlib.box
val make_let_in :
Var.t ->
Scopelang.Ast.typ Marked.pos ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box
(** {2 Rules and scopes}*)
type exception_situation =
@ -135,19 +68,19 @@ type label_situation = ExplicitlyLabeled of LabelName.t Marked.pos | Unlabeled
type rule = {
rule_id : RuleName.t;
rule_just : expr Marked.pos Bindlib.box;
rule_cons : expr Marked.pos Bindlib.box;
rule_parameter : (Var.t * Scopelang.Ast.typ Marked.pos) option;
rule_just : expr Bindlib.box;
rule_cons : expr Bindlib.box;
rule_parameter : (expr Var.t * typ) option;
rule_exception : exception_situation;
rule_label : label_situation;
}
module Rule : Set.OrderedType with type t = rule
val empty_rule : Pos.t -> Scopelang.Ast.typ Marked.pos option -> rule
val always_false_rule : Pos.t -> Scopelang.Ast.typ Marked.pos option -> rule
val empty_rule : Pos.t -> typ option -> rule
val always_false_rule : Pos.t -> typ option -> rule
type assertion = expr Marked.pos Bindlib.box
type assertion = expr Bindlib.box
type variation_typ = Increasing | Decreasing
type reference_typ = Decree | Law
@ -157,7 +90,7 @@ type meta_assertion =
type scope_def = {
scope_def_rules : rule RuleMap.t;
scope_def_typ : Scopelang.Ast.typ Marked.pos;
scope_def_typ : typ;
scope_def_is_condition : bool;
scope_def_io : Scopelang.Ast.io;
}
@ -166,8 +99,8 @@ type var_or_states = WholeVar | States of StateName.t list
type scope = {
scope_vars : var_or_states ScopeVarMap.t;
scope_sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
scope_uid : Scopelang.Ast.ScopeName.t;
scope_sub_scopes : ScopeName.t Scopelang.Ast.SubScopeMap.t;
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
@ -175,11 +108,10 @@ type scope = {
type program = {
program_scopes : scope Scopelang.Ast.ScopeMap.t;
program_enums : Scopelang.Ast.enum_ctx;
program_structs : Scopelang.Ast.struct_ctx;
program_ctx : decl_ctx;
}
(** {1 Helpers} *)
val locations_used : expr Marked.pos -> LocationSet.t
val locations_used : expr -> LocationSet.t
val free_variables : rule RuleMap.t -> Pos.t ScopeDefMap.t

56
compiler/desugared/dependency.ml
View File

@ -18,6 +18,7 @@
OCamlgraph} *)
open Utils
open Shared_ast
(** {1 Scope variables dependency graph} *)
@ -32,34 +33,30 @@ open Utils
Indeed, during interpretation, subscopes are executed atomically. *)
module Vertex = struct
type t =
| Var of Ast.ScopeVar.t * Ast.StateName.t option
| SubScope of Scopelang.Ast.SubScopeName.t
type t = Var of ScopeVar.t * StateName.t option | SubScope of SubScopeName.t
let hash x =
match x with
| Var (x, None) -> Ast.ScopeVar.hash x
| Var (x, Some sx) ->
Int.logxor (Ast.ScopeVar.hash x) (Ast.StateName.hash sx)
| SubScope x -> Scopelang.Ast.SubScopeName.hash x
| Var (x, None) -> ScopeVar.hash x
| Var (x, Some sx) -> Int.logxor (ScopeVar.hash x) (StateName.hash sx)
| SubScope x -> SubScopeName.hash x
let compare = compare
let equal x y =
match x, y with
| Var (x, None), Var (y, None) -> Ast.ScopeVar.compare x y = 0
| Var (x, None), Var (y, None) -> ScopeVar.compare x y = 0
| Var (x, Some sx), Var (y, Some sy) ->
Ast.ScopeVar.compare x y = 0 && Ast.StateName.compare sx sy = 0
| SubScope x, SubScope y -> Scopelang.Ast.SubScopeName.compare x y = 0
ScopeVar.compare x y = 0 && StateName.compare sx sy = 0
| SubScope x, SubScope y -> SubScopeName.compare x y = 0
| _ -> false
let format_t (fmt : Format.formatter) (x : t) : unit =
match x with
| Var (v, None) -> Ast.ScopeVar.format_t fmt v
| Var (v, None) -> ScopeVar.format_t fmt v
| Var (v, Some sv) ->
Format.fprintf fmt "%a.%a" Ast.ScopeVar.format_t v Ast.StateName.format_t
sv
| SubScope v -> Scopelang.Ast.SubScopeName.format_t fmt v
Format.fprintf fmt "%a.%a" ScopeVar.format_t v StateName.format_t sv
| SubScope v -> SubScopeName.format_t fmt v
end
(** On the edges, the label is the position of the expression responsible for
@ -103,15 +100,14 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
let var_str, var_info =
match v with
| Vertex.Var (v, None) ->
( Format.asprintf "%a" Ast.ScopeVar.format_t v,
Ast.ScopeVar.get_info v )
Format.asprintf "%a" ScopeVar.format_t v, ScopeVar.get_info v
| Vertex.Var (v, Some sv) ->
( Format.asprintf "%a.%a" Ast.ScopeVar.format_t v
Ast.StateName.format_t sv,
Ast.StateName.get_info sv )
( Format.asprintf "%a.%a" ScopeVar.format_t v
StateName.format_t sv,
StateName.get_info sv )
| Vertex.SubScope v ->
( Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v,
Scopelang.Ast.SubScopeName.get_info v )
( Format.asprintf "%a" SubScopeName.format_t v,
SubScopeName.get_info v )
in
let succs = ScopeDependencies.succ_e g v in
let _, edge_pos, succ =
@ -120,12 +116,12 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
let succ_str =
match succ with
| Vertex.Var (v, None) ->
Format.asprintf "%a" Ast.ScopeVar.format_t v
Format.asprintf "%a" ScopeVar.format_t v
| Vertex.Var (v, Some sv) ->
Format.asprintf "%a.%a" Ast.ScopeVar.format_t v
Ast.StateName.format_t sv
Format.asprintf "%a.%a" ScopeVar.format_t v StateName.format_t
sv
| Vertex.SubScope v ->
Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v
Format.asprintf "%a" SubScopeName.format_t v
in
[
( Some ("Cycle variable " ^ var_str ^ ", declared:"),
@ -140,15 +136,15 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
in
Errors.raise_multispanned_error spans
"Cyclic dependency detected between variables of scope %a!"
Scopelang.Ast.ScopeName.format_t scope.scope_uid
ScopeName.format_t scope.scope_uid
(** Builds the dependency graph of a particular scope *)
let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
let g = ScopeDependencies.empty in
(* Add all the vertices to the graph *)
let g =
Ast.ScopeVarMap.fold
(fun (v : Ast.ScopeVar.t) var_or_state g ->
ScopeVarMap.fold
(fun (v : ScopeVar.t) var_or_state g ->
match var_or_state with
| Ast.WholeVar -> ScopeDependencies.add_vertex g (Vertex.Var (v, None))
| Ast.States states ->
@ -160,7 +156,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
in
let g =
Scopelang.Ast.SubScopeMap.fold
(fun (v : Scopelang.Ast.SubScopeName.t) _ g ->
(fun (v : SubScopeName.t) _ g ->
ScopeDependencies.add_vertex g (Vertex.SubScope v))
scope.scope_sub_scopes g
in
@ -208,7 +204,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
Errors.raise_spanned_error fv_def_pos
"The subscope %a is used when defining one of its inputs, \
but recursion is forbidden in Catala"
Scopelang.Ast.SubScopeName.format_t defined
SubScopeName.format_t defined
else
let edge =
ScopeDependencies.E.create (Vertex.SubScope used) fv_def_pos

4
compiler/desugared/dependency.mli
View File

@ -34,8 +34,8 @@ open Utils
module Vertex : sig
type t =
| Var of Ast.ScopeVar.t * Ast.StateName.t option
| SubScope of Scopelang.Ast.SubScopeName.t
| Var of Shared_ast.ScopeVar.t * Shared_ast.StateName.t option
| SubScope of Shared_ast.SubScopeName.t
val format_t : Format.formatter -> t -> unit

2
compiler/desugared/desugared.mld
View File

@ -23,7 +23,7 @@ computation order. All the graph computations are done using the
The other important piece of work performed by
{!module: Desugared.Desugared_to_scope} is the construction of the default trees
(see {!Dcalc.Ast.EDefault}) from the list of prioritized rules.
(see {!Shared_ast.EDefault}) from the list of prioritized rules.
Related modules:

239
compiler/desugared/desugared_to_scope.ml
View File

@ -17,130 +17,123 @@
(** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
open Utils
open Shared_ast
(** {1 Expression translation}*)
type target_scope_vars =
| WholeVar of Scopelang.Ast.ScopeVar.t
| States of (Ast.StateName.t * Scopelang.Ast.ScopeVar.t) list
| WholeVar of ScopeVar.t
| States of (StateName.t * ScopeVar.t) list
type ctx = {
scope_var_mapping : target_scope_vars Ast.ScopeVarMap.t;
var_mapping : Scopelang.Ast.Var.t Ast.VarMap.t;
scope_var_mapping : target_scope_vars ScopeVarMap.t;
var_mapping : (Ast.expr, Scopelang.Ast.expr Var.t) Var.Map.t;
}
let tag_with_log_entry
(e : Scopelang.Ast.expr Marked.pos)
(l : Dcalc.Ast.log_entry)
(markings : Utils.Uid.MarkedString.info list) :
Scopelang.Ast.expr Marked.pos =
( Scopelang.Ast.EApp
( ( Scopelang.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))),
Marked.get_mark e ),
[e] ),
(e : Scopelang.Ast.expr)
(l : log_entry)
(markings : Utils.Uid.MarkedString.info list) : Scopelang.Ast.expr =
( EApp ((EOp (Unop (Log (l, markings))), Marked.get_mark e), [e]),
Marked.get_mark e )
let rec translate_expr (ctx : ctx) (e : Ast.expr Marked.pos) :
Scopelang.Ast.expr Marked.pos Bindlib.box =
let rec translate_expr (ctx : ctx) (e : Ast.expr) :
Scopelang.Ast.expr Bindlib.box =
let m = Marked.get_mark e in
match Marked.unmark e with
| Ast.ELocation (SubScopeVar (s_name, ss_name, s_var)) ->
| ELocation (SubScopeVar (s_name, ss_name, s_var)) ->
(* When referring to a subscope variable in an expression, we are referring
to the output, hence we take the last state. *)
let new_s_var =
match
Ast.ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
with
match ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States states ->
Marked.same_mark_as (snd (List.hd (List.rev states))) s_var
in
Bindlib.box (ELocation (SubScopeVar (s_name, ss_name, new_s_var)), m)
| ELocation (DesugaredScopeVar (s_var, None)) ->
Bindlib.box
(Scopelang.Ast.ELocation (SubScopeVar (s_name, ss_name, new_s_var)), m)
| Ast.ELocation (ScopeVar (s_var, None)) ->
Bindlib.box
( Scopelang.Ast.ELocation
(ScopeVar
( ELocation
(ScopelangScopeVar
(match
Ast.ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States _ -> failwith "should not happen")),
m )
| Ast.ELocation (ScopeVar (s_var, Some state)) ->
| ELocation (DesugaredScopeVar (s_var, Some state)) ->
Bindlib.box
( Scopelang.Ast.ELocation
(ScopeVar
( ELocation
(ScopelangScopeVar
(match
Ast.ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar _ -> failwith "should not happen"
| States states ->
Marked.same_mark_as (List.assoc state states) s_var)),
m )
| Ast.EVar v ->
| EVar v ->
Bindlib.box_apply
(fun v -> Marked.same_mark_as v e)
(Bindlib.box_var (Ast.VarMap.find v ctx.var_mapping))
(Bindlib.box_var (Var.Map.find v ctx.var_mapping))
| EStruct (s_name, fields) ->
Bindlib.box_apply
(fun new_fields -> Scopelang.Ast.EStruct (s_name, new_fields), m)
(fun new_fields -> EStruct (s_name, new_fields), m)
(Scopelang.Ast.StructFieldMapLift.lift_box
(Scopelang.Ast.StructFieldMap.map (translate_expr ctx) fields))
(StructFieldMap.map (translate_expr ctx) fields))
| EStructAccess (e1, s_name, f_name) ->
Bindlib.box_apply
(fun new_e1 -> Scopelang.Ast.EStructAccess (new_e1, s_name, f_name), m)
(fun new_e1 -> EStructAccess (new_e1, s_name, f_name), m)
(translate_expr ctx e1)
| EEnumInj (e1, cons, e_name) ->
Bindlib.box_apply
(fun new_e1 -> Scopelang.Ast.EEnumInj (new_e1, cons, e_name), m)
(fun new_e1 -> EEnumInj (new_e1, cons, e_name), m)
(translate_expr ctx e1)
| EMatch (e1, e_name, arms) ->
| EMatchS (e1, e_name, arms) ->
Bindlib.box_apply2
(fun new_e1 new_arms ->
Scopelang.Ast.EMatch (new_e1, e_name, new_arms), m)
(fun new_e1 new_arms -> EMatchS (new_e1, e_name, new_arms), m)
(translate_expr ctx e1)
(Scopelang.Ast.EnumConstructorMapLift.lift_box
(Scopelang.Ast.EnumConstructorMap.map (translate_expr ctx) arms))
| ELit l -> Bindlib.box (Scopelang.Ast.ELit l, m)
(EnumConstructorMap.map (translate_expr ctx) arms))
| ELit
(( LBool _ | LEmptyError | LInt _ | LRat _ | LMoney _ | LUnit | LDate _
| LDuration _ ) as l) ->
Bindlib.box (ELit l, m)
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
let new_vars =
Array.map (fun var -> Scopelang.Ast.Var.make (Bindlib.name_of var)) vars
in
let new_vars = Array.map (fun var -> Var.make (Bindlib.name_of var)) vars in
let ctx =
List.fold_left2
(fun ctx var new_var ->
{ ctx with var_mapping = Ast.VarMap.add var new_var ctx.var_mapping })
{ ctx with var_mapping = Var.Map.add var new_var ctx.var_mapping })
ctx (Array.to_list vars) (Array.to_list new_vars)
in
Bindlib.box_apply
(fun new_binder -> Scopelang.Ast.EAbs (new_binder, typs), m)
(fun new_binder -> EAbs (new_binder, typs), m)
(Bindlib.bind_mvar new_vars (translate_expr ctx body))
| EApp (e1, args) ->
Bindlib.box_apply2
(fun new_e1 new_args -> Scopelang.Ast.EApp (new_e1, new_args), m)
(fun new_e1 new_args -> EApp (new_e1, new_args), m)
(translate_expr ctx e1)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| EOp op -> Bindlib.box (Scopelang.Ast.EOp op, m)
| EOp op -> Bindlib.box (EOp op, m)
| EDefault (excepts, just, cons) ->
Bindlib.box_apply3
(fun new_excepts new_just new_cons ->
Scopelang.Ast.make_default ~pos:m new_excepts new_just new_cons)
Expr.make_default new_excepts new_just new_cons m)
(Bindlib.box_list (List.map (translate_expr ctx) excepts))
(translate_expr ctx just) (translate_expr ctx cons)
| EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun new_e1 new_e2 new_e3 ->
Scopelang.Ast.EIfThenElse (new_e1, new_e2, new_e3), m)
(fun new_e1 new_e2 new_e3 -> EIfThenElse (new_e1, new_e2, new_e3), m)
(translate_expr ctx e1) (translate_expr ctx e2) (translate_expr ctx e3)
| EArray args ->
Bindlib.box_apply
(fun new_args -> Scopelang.Ast.EArray new_args, m)
(fun new_args -> EArray new_args, m)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| ErrorOnEmpty e1 ->
Bindlib.box_apply
(fun new_e1 -> Scopelang.Ast.ErrorOnEmpty new_e1, m)
(fun new_e1 -> ErrorOnEmpty new_e1, m)
(translate_expr ctx e1)
(** {1 Rule tree construction} *)
@ -185,24 +178,24 @@ let def_map_to_tree (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t) :
in
List.map build_tree base_cases
(** From the {!type: rule_tree}, builds an {!constructor: Dcalc.Ast.EDefault}
(** From the {!type: rule_tree}, builds an {!constructor: Dcalc.EDefault}
expression in the scope language. The [~toplevel] parameter is used to know
when to place the toplevel binding in the case of functions. *)
let rec rule_tree_to_expr
~(toplevel : bool)
(ctx : ctx)
(def_pos : Pos.t)
(is_func : Ast.Var.t option)
(tree : rule_tree) : Scopelang.Ast.expr Marked.pos Bindlib.box =
(is_func : Ast.expr Var.t option)
(tree : rule_tree) : Scopelang.Ast.expr Bindlib.box =
let emark = Untyped { pos = def_pos } in
let exceptions, base_rules =
match tree with Leaf r -> [], r | Node (exceptions, r) -> exceptions, r
in
(* because each rule has its own variable parameter and we want to convert the
whole rule tree into a function, we need to perform some alpha-renaming of
all the expressions *)
let substitute_parameter
(e : Ast.expr Marked.pos Bindlib.box)
(rule : Ast.rule) : Ast.expr Marked.pos Bindlib.box =
let substitute_parameter (e : Ast.expr Bindlib.box) (rule : Ast.rule) :
Ast.expr Bindlib.box =
match is_func, rule.Ast.rule_parameter with
| Some new_param, Some (old_param, _) ->
let binder = Bindlib.bind_var old_param e in
@ -218,14 +211,12 @@ let rec rule_tree_to_expr
match is_func with
| None -> ctx
| Some new_param -> (
match Ast.VarMap.find_opt new_param ctx.var_mapping with
match Var.Map.find_opt new_param ctx.var_mapping with
| None ->
let new_param_scope =
Scopelang.Ast.Var.make (Bindlib.name_of new_param)
in
let new_param_scope = Var.make (Bindlib.name_of new_param) in
{
ctx with
var_mapping = Ast.VarMap.add new_param new_param_scope ctx.var_mapping;
var_mapping = Var.Map.add new_param new_param_scope ctx.var_mapping;
}
| Some _ ->
(* We only create a mapping if none exists because [rule_tree_to_expr]
@ -244,8 +235,8 @@ let rec rule_tree_to_expr
(fun rule -> substitute_parameter rule.Ast.rule_cons rule)
base_rules
in
let translate_and_unbox_list (list : Ast.expr Marked.pos Bindlib.box list) :
Scopelang.Ast.expr Marked.pos Bindlib.box list =
let translate_and_unbox_list (list : Ast.expr Bindlib.box list) :
Scopelang.Ast.expr Bindlib.box list =
List.map
(fun e ->
(* There are two levels of boxing here, the outermost is introduced by
@ -257,17 +248,17 @@ let rec rule_tree_to_expr
let default_containing_base_cases =
Bindlib.box_apply2
(fun base_just_list base_cons_list ->
Scopelang.Ast.make_default
Expr.make_default
(List.map2
(fun base_just base_cons ->
Scopelang.Ast.make_default ~pos:def_pos []
Expr.make_default []
(* Here we insert the logging command that records when a
decision is taken for the value of a variable. *)
(tag_with_log_entry base_just Dcalc.Ast.PosRecordIfTrueBool [])
base_cons)
(tag_with_log_entry base_just PosRecordIfTrueBool [])
base_cons emark)
base_just_list base_cons_list)
(Scopelang.Ast.ELit (Dcalc.Ast.LBool false), def_pos)
(Scopelang.Ast.ELit Dcalc.Ast.LEmptyError, def_pos))
(ELit (LBool false), emark)
(ELit LEmptyError, emark) emark)
(Bindlib.box_list (translate_and_unbox_list base_just_list))
(Bindlib.box_list (translate_and_unbox_list base_cons_list))
in
@ -280,9 +271,8 @@ let rec rule_tree_to_expr
let default =
Bindlib.box_apply2
(fun exceptions default_containing_base_cases ->
Scopelang.Ast.make_default exceptions
(Scopelang.Ast.ELit (Dcalc.Ast.LBool true), def_pos)
default_containing_base_cases)
Expr.make_default exceptions (ELit (LBool true), emark)
default_containing_base_cases emark)
exceptions default_containing_base_cases
in
match is_func, (List.hd base_rules).Ast.rule_parameter with
@ -293,33 +283,30 @@ let rec rule_tree_to_expr
that the result returned by the function is not empty *)
let default =
Bindlib.box_apply
(fun (default : Scopelang.Ast.expr * Pos.t) ->
Scopelang.Ast.ErrorOnEmpty default, def_pos)
(fun (default : Scopelang.Ast.expr) -> ErrorOnEmpty default, emark)
default
in
Scopelang.Ast.make_abs
(Array.of_list [Ast.VarMap.find new_param ctx.var_mapping])
default [typ] def_pos
Expr.make_abs
[| Var.Map.find new_param ctx.var_mapping |]
default [typ] emark
else default
| _ -> (* should not happen *) assert false
(** {1 AST translation} *)
(** Translates a definition inside a scope, the resulting expression should be
an {!constructor: Dcalc.Ast.EDefault} *)
an {!constructor: Dcalc.EDefault} *)
let translate_def
(ctx : ctx)
(def_info : Ast.ScopeDef.t)
(def : Ast.rule Ast.RuleMap.t)
(typ : Scopelang.Ast.typ Marked.pos)
(typ : typ)
(io : Scopelang.Ast.io)
~(is_cond : bool)
~(is_subscope_var : bool) : Scopelang.Ast.expr Marked.pos =
~(is_subscope_var : bool) : Scopelang.Ast.expr =
(* Here, we have to transform this list of rules into a default tree. *)
let is_def_func =
match Marked.unmark typ with
| Scopelang.Ast.TArrow (_, _) -> true
| _ -> false
match Marked.unmark typ with TArrow (_, _) -> true | _ -> false
in
let is_rule_func _ (r : Ast.rule) : bool =
Option.is_some r.Ast.rule_parameter
@ -328,27 +315,27 @@ let translate_def
let all_rules_not_func =
Ast.RuleMap.for_all (fun n r -> not (is_rule_func n r)) def
in
let is_def_func_param_typ : Scopelang.Ast.typ Marked.pos option =
let is_def_func_param_typ : typ option =
if is_def_func && all_rules_func then
match Marked.unmark typ with
| Scopelang.Ast.TArrow (t_param, _) -> Some t_param
| TArrow (t_param, _) -> Some t_param
| _ ->
Errors.raise_spanned_error (Marked.get_mark typ)
"The definitions of %a are function but its type, %a, is not a \
function type"
Ast.ScopeDef.format_t def_info Scopelang.Print.format_typ typ
"The definitions of %a are function but it doesn't have a function \
type"
Ast.ScopeDef.format_t def_info
else if (not is_def_func) && all_rules_not_func then None
else
let spans =
List.map
(fun (_, r) ->
( Some "This definition is a function:",
Marked.get_mark (Bindlib.unbox r.Ast.rule_cons) ))
Expr.pos (Bindlib.unbox r.Ast.rule_cons) ))
(Ast.RuleMap.bindings (Ast.RuleMap.filter is_rule_func def))
@ List.map
(fun (_, r) ->
( Some "This definition is not a function:",
Marked.get_mark (Bindlib.unbox r.Ast.rule_cons) ))
Expr.pos (Bindlib.unbox r.Ast.rule_cons) ))
(Ast.RuleMap.bindings
(Ast.RuleMap.filter (fun n r -> not (is_rule_func n r)) def))
in
@ -398,12 +385,12 @@ let translate_def
defined as an OnlyInput to a subscope, since the [false] default value
will not be provided by the calee scope, it has to be placed in the
caller. *)
then ELit LEmptyError, Ast.ScopeDef.get_position def_info
then ELit LEmptyError, Untyped { pos = Ast.ScopeDef.get_position def_info }
else
Bindlib.unbox
(rule_tree_to_expr ~toplevel:true ctx
(Ast.ScopeDef.get_position def_info)
(Option.map (fun _ -> Ast.Var.make "param") is_def_func_param_typ)
(Option.map (fun _ -> Var.make "param") is_def_func_param_typ)
(match top_list, top_value with
| [], None ->
(* In this case, there are no rules to define the expression and no
@ -450,7 +437,7 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
redefined. *)
Errors.raise_multispanned_error
(( Some "Incriminated variable:",
Marked.get_mark (Ast.ScopeVar.get_info var) )
Marked.get_mark (ScopeVar.get_info var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
@ -469,21 +456,17 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
~is_subscope_var:false
in
let scope_var =
match
Ast.ScopeVarMap.find var ctx.scope_var_mapping, state
with
match ScopeVarMap.find var ctx.scope_var_mapping, state with
| WholeVar v, None -> v
| States states, Some state -> List.assoc state states
| _ -> failwith "should not happen"
in
[
Scopelang.Ast.Definition
( ( Scopelang.Ast.ScopeVar
( ( ScopelangScopeVar
( scope_var,
Marked.get_mark
(Scopelang.Ast.ScopeVar.get_info scope_var) ),
Marked.get_mark
(Scopelang.Ast.ScopeVar.get_info scope_var) ),
Marked.get_mark (ScopeVar.get_info scope_var) ),
Marked.get_mark (ScopeVar.get_info scope_var) ),
var_typ,
scope_def.Ast.scope_def_io,
expr_def );
@ -534,8 +517,8 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
(( Some "Incriminated subscope:",
Ast.ScopeDef.get_position def_key )
:: ( Some "Incriminated variable:",
Marked.get_mark
(Ast.ScopeVar.get_info sub_scope_var) )
Marked.get_mark (ScopeVar.get_info sub_scope_var)
)
:: List.map
(fun (rule, _) ->
( Some
@ -552,8 +535,7 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
( Some "Incriminated subscope:",
Ast.ScopeDef.get_position def_key );
( Some "Incriminated variable:",
Marked.get_mark
(Ast.ScopeVar.get_info sub_scope_var) );
Marked.get_mark (ScopeVar.get_info sub_scope_var) );
]
"This subscope variable is a mandatory input but no \
definition was provided."
@ -570,14 +552,14 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
scope.scope_sub_scopes
in
let var_pos =
Marked.get_mark (Ast.ScopeVar.get_info sub_scope_var)
Marked.get_mark (ScopeVar.get_info sub_scope_var)
in
Scopelang.Ast.Definition
( ( Scopelang.Ast.SubScopeVar
( ( SubScopeVar
( subscop_real_name,
(sub_scope_index, var_pos),
match
Ast.ScopeVarMap.find sub_scope_var
ScopeVarMap.find sub_scope_var
ctx.scope_var_mapping
with
| WholeVar v -> v, var_pos
@ -614,7 +596,7 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
(Bindlib.unbox (Bindlib.box_list scope.Ast.scope_assertions))
in
let scope_sig =
Ast.ScopeVarMap.fold
ScopeVarMap.fold
(fun var (states : Ast.var_or_states) acc ->
match states with
| WholeVar ->
@ -622,8 +604,8 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
Ast.ScopeDefMap.find (Ast.ScopeDef.Var (var, None)) scope.scope_defs
in
let typ = scope_def.scope_def_typ in
Scopelang.Ast.ScopeVarMap.add
(match Ast.ScopeVarMap.find var ctx.scope_var_mapping with
ScopeVarMap.add
(match ScopeVarMap.find var ctx.scope_var_mapping with
| WholeVar v -> v
| States _ -> failwith "should not happen")
(typ, scope_def.scope_def_io)
@ -633,20 +615,20 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
interesting. We need to create as many Scopelang.Var entries in the
scope signature as there are states. *)
List.fold_left
(fun acc (state : Ast.StateName.t) ->
(fun acc (state : StateName.t) ->
let scope_def =
Ast.ScopeDefMap.find
(Ast.ScopeDef.Var (var, Some state))
scope.scope_defs
in
Scopelang.Ast.ScopeVarMap.add
(match Ast.ScopeVarMap.find var ctx.scope_var_mapping with
ScopeVarMap.add
(match ScopeVarMap.find var ctx.scope_var_mapping with
| WholeVar _ -> failwith "should not happen"
| States states' -> List.assoc state states')
(scope_def.scope_def_typ, scope_def.scope_def_io)
acc)
acc states)
scope.scope_vars Scopelang.Ast.ScopeVarMap.empty
scope.scope_vars ScopeVarMap.empty
in
{
Scopelang.Ast.scope_decl_name = scope.scope_uid;
@ -663,34 +645,31 @@ let translate_program (pgrm : Ast.program) : Scopelang.Ast.program =
let ctx =
Scopelang.Ast.ScopeMap.fold
(fun _scope scope_decl ctx ->
Ast.ScopeVarMap.fold
ScopeVarMap.fold
(fun scope_var (states : Ast.var_or_states) ctx ->
match states with
| Ast.WholeVar ->
{
ctx with
scope_var_mapping =
Ast.ScopeVarMap.add scope_var
(WholeVar
(Scopelang.Ast.ScopeVar.fresh
(Ast.ScopeVar.get_info scope_var)))
ScopeVarMap.add scope_var
(WholeVar (ScopeVar.fresh (ScopeVar.get_info scope_var)))
ctx.scope_var_mapping;
}
| States states ->
{
ctx with
scope_var_mapping =
Ast.ScopeVarMap.add scope_var
ScopeVarMap.add scope_var
(States
(List.map
(fun state ->
( state,
Scopelang.Ast.ScopeVar.fresh
ScopeVar.fresh
(let state_name, state_pos =
Ast.StateName.get_info state
StateName.get_info state
in
( Marked.unmark
(Ast.ScopeVar.get_info scope_var)
( Marked.unmark (ScopeVar.get_info scope_var)
^ "_"
^ state_name,
state_pos )) ))
@ -699,14 +678,10 @@ let translate_program (pgrm : Ast.program) : Scopelang.Ast.program =
})
scope_decl.Ast.scope_vars ctx)
pgrm.Ast.program_scopes
{
scope_var_mapping = Ast.ScopeVarMap.empty;
var_mapping = Ast.VarMap.empty;
}
{ scope_var_mapping = ScopeVarMap.empty; var_mapping = Var.Map.empty }
in
{
Scopelang.Ast.program_scopes =
Scopelang.Ast.ScopeMap.map (translate_scope ctx) pgrm.program_scopes;
Scopelang.Ast.program_structs = pgrm.program_structs;
Scopelang.Ast.program_enums = pgrm.program_enums;
Scopelang.Ast.program_ctx = pgrm.program_ctx;
}

41
compiler/driver.ml
View File

@ -170,12 +170,12 @@ let driver source_file (options : Cli.options) : int =
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scopelang.Print.format_scope ~debug:options.debug)
(Scopelang.Print.scope prgm.program_ctx ~debug:options.debug)
( scope_uid,
Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes )
else
Format.fprintf fmt "%a\n"
(Scopelang.Print.format_program ~debug:options.debug)
(Scopelang.Print.program ~debug:options.debug)
prgm
| ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc | `Dcalc
| `Proof | `Plugin _ ) as backend -> (
@ -197,13 +197,13 @@ let driver source_file (options : Cli.options) : int =
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
(Shared_ast.Scope.format ~debug:options.debug prgm.decl_ctx)
( scope_uid,
Option.get
(Dcalc.Ast.fold_left_scope_defs ~init:None
(Shared_ast.Scope.fold_left ~init:None
~f:(fun acc scope_def _ ->
if
Dcalc.Ast.ScopeName.compare scope_def.scope_name
Shared_ast.ScopeName.compare scope_def.scope_name
scope_uid
= 0
then Some scope_def.scope_body
@ -211,20 +211,17 @@ let driver source_file (options : Cli.options) : int =
prgm.scopes) )
else
let prgrm_dcalc_expr =
Bindlib.unbox
(Dcalc.Ast.build_whole_program_expr ~box_expr:Dcalc.Ast.box_expr
~make_abs:Dcalc.Ast.make_abs
~make_let_in:Dcalc.Ast.make_let_in prgm scope_uid)
Bindlib.unbox (Shared_ast.Program.to_expr prgm scope_uid)
in
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
(Shared_ast.Expr.format prgm.decl_ctx)
prgrm_dcalc_expr
| ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc
| `Proof | `Plugin _ ) as backend -> (
Cli.debug_print "Typechecking...";
let prgm = Dcalc.Typing.infer_types_program prgm in
(* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a"
(Dcalc.Print.format_typ prgm.decl_ctx) typ); *)
(Print.typ prgm.decl_ctx) typ); *)
match backend with
| `Typecheck ->
(* That's it! *)
@ -241,10 +238,7 @@ let driver source_file (options : Cli.options) : int =
| `Interpret ->
Cli.debug_print "Starting interpretation...";
let prgrm_dcalc_expr =
Bindlib.unbox
(Dcalc.Ast.build_whole_program_expr ~box_expr:Dcalc.Ast.box_expr
~make_abs:Dcalc.Ast.make_abs
~make_let_in:Dcalc.Ast.make_let_in prgm scope_uid)
Bindlib.unbox (Shared_ast.Program.to_expr prgm scope_uid)
in
let results =
Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr
@ -270,7 +264,7 @@ let driver source_file (options : Cli.options) : int =
List.iter
(fun ((var, _), result) ->
Cli.result_format "@[<hov 2>%s@ =@ %a@]" var
(Dcalc.Print.format_expr ~debug:options.debug prgm.decl_ctx)
(Shared_ast.Expr.format ~debug:options.debug prgm.decl_ctx)
result)
results
| (`OCaml | `Python | `Lcalc | `Scalc | `Plugin _) as backend -> (
@ -285,7 +279,7 @@ let driver source_file (options : Cli.options) : int =
Cli.debug_print "Optimizing lambda calculus...";
Lcalc.Optimizations.optimize_program prgm
end
else Lcalc.Ast.untype_program prgm
else Shared_ast.Program.untype prgm
in
let prgm =
if options.closure_conversion then (
@ -302,13 +296,13 @@ let driver source_file (options : Cli.options) : int =
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Lcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
(Shared_ast.Scope.format ~debug:options.debug prgm.decl_ctx)
( scope_uid,
Option.get
(Dcalc.Ast.fold_left_scope_defs ~init:None
(Shared_ast.Scope.fold_left ~init:None
~f:(fun acc scope_def _ ->
if
Dcalc.Ast.ScopeName.compare scope_def.scope_name
Shared_ast.ScopeName.compare scope_def.scope_name
scope_uid
= 0
then Some scope_def.scope_body
@ -316,13 +310,10 @@ let driver source_file (options : Cli.options) : int =
prgm.scopes) )
else
let prgrm_lcalc_expr =
Bindlib.unbox
(Dcalc.Ast.build_whole_program_expr
~box_expr:Lcalc.Ast.box_expr ~make_abs:Lcalc.Ast.make_abs
~make_let_in:Lcalc.Ast.make_let_in prgm scope_uid)
Bindlib.unbox (Shared_ast.Program.to_expr prgm scope_uid)
in
Format.fprintf fmt "%a\n"
(Lcalc.Print.format_expr prgm.decl_ctx)
(Shared_ast.Expr.format prgm.decl_ctx)
prgrm_lcalc_expr
| (`OCaml | `Python | `Scalc | `Plugin _) as backend -> (
match backend with

159
compiler/lcalc/ast.ml
View File

@ -15,160 +15,49 @@
the License. *)
open Utils
include Astgen
module D = Dcalc.Ast
include Shared_ast
type lit = lcalc glit
type 'm expr = (lcalc, 'm mark) gexpr
and 'm marked_expr = (lcalc, 'm mark) marked_gexpr
type 'm naked_expr = (lcalc, 'm mark) naked_gexpr
and 'm expr = (lcalc, 'm mark) gexpr
type 'm program = ('m expr, 'm) Dcalc.Ast.program_generic
type 'm var = 'm expr Var.t
type 'm vars = 'm expr Var.vars
type 'm program = 'm expr Shared_ast.program
(* <copy-paste from dcalc/ast.ml> *)
let option_enum : EnumName.t = EnumName.fresh ("eoption", Pos.no_pos)
let none_constr : EnumConstructor.t = EnumConstructor.fresh ("ENone", Pos.no_pos)
let some_constr : EnumConstructor.t = EnumConstructor.fresh ("ESome", Pos.no_pos)
let evar v mark = Bindlib.box_apply (Marked.mark mark) (Bindlib.box_var v)
let etuple args s mark =
Bindlib.box_apply (fun args -> ETuple (args, s), mark) (Bindlib.box_list args)
let etupleaccess e1 i s typs mark =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), mark) e1
let einj e1 i e_name typs mark =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), mark) e1
let ematch arg arms e_name mark =
Bindlib.box_apply2
(fun arg arms -> EMatch (arg, arms, e_name), mark)
arg (Bindlib.box_list arms)
let earray args mark =
Bindlib.box_apply (fun args -> EArray args, mark) (Bindlib.box_list args)
let elit l mark = Bindlib.box (ELit l, mark)
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) binder
let eapp e1 args mark =
Bindlib.box_apply2
(fun e1 args -> EApp (e1, args), mark)
e1 (Bindlib.box_list args)
let eassert e1 mark = Bindlib.box_apply (fun e1 -> EAssert e1, mark) e1
let eop op mark = Bindlib.box (EOp op, mark)
let eifthenelse e1 e2 e3 pos =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), pos) e1 e2 e3
(* </copy-paste> *)
let eraise e1 pos = Bindlib.box (ERaise e1, pos)
let ecatch e1 exn e2 pos =
Bindlib.box_apply2 (fun e1 e2 -> ECatch (e1, exn, e2), pos) e1 e2
let map_expr ctx ~f e = Astgen_utils.map_gexpr ctx ~f e
let rec map_expr_top_down ~f e =
map_expr () ~f:(fun () -> map_expr_top_down ~f) (f e)
let map_expr_marks ~f e =
map_expr_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
let untype_expr e =
map_expr_marks ~f:(fun m -> Untyped { pos = D.mark_pos m }) e
let untype_program prg =
{
prg with
D.scopes =
Bindlib.unbox
(D.map_exprs_in_scopes
~f:(fun e -> untype_expr e)
~varf:Var.translate prg.D.scopes);
}
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let box_expr (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let rec id_t () e = map_expr () ~f:id_t e in
id_t () e
let make_var (x, mark) =
Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
let make_abs xs e taus mark =
Bindlib.box_apply (fun b -> EAbs (b, taus), mark) (Bindlib.bind_mvar xs e)
let make_app e u mark =
Bindlib.box_apply2 (fun e u -> EApp (e, u), mark) e (Bindlib.box_list u)
let make_let_in x tau e1 e2 pos =
let m_e1 = Marked.get_mark (Bindlib.unbox e1) in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
D.map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> TArrow (m1.ty, m2.ty), m1.pos)
m_e1 m_e2
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let make_multiple_let_in xs taus e1s e2 pos =
(* let m_e1s = List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s in *)
let m_e1s =
D.fold_marks List.hd
(fun tys ->
D.TTuple (List.map (fun t -> t.D.ty) tys, None), (List.hd tys).D.pos)
(List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s)
in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
D.map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (D.TArrow (m1.ty, m2.ty)))
m_e1s m_e2
in
make_app (make_abs xs e2 taus m_abs) e1s m_e2
let ( let+ ) x f = Bindlib.box_apply f x
let ( and+ ) x y = Bindlib.box_pair x y
let option_enum : D.EnumName.t = D.EnumName.fresh ("eoption", Pos.no_pos)
let none_constr : D.EnumConstructor.t =
D.EnumConstructor.fresh ("ENone", Pos.no_pos)
let some_constr : D.EnumConstructor.t =
D.EnumConstructor.fresh ("ESome", Pos.no_pos)
let option_enum_config : (D.EnumConstructor.t * D.typ Marked.pos) list =
[none_constr, (D.TLit D.TUnit, Pos.no_pos); some_constr, (D.TAny, Pos.no_pos)]
let option_enum_config : (EnumConstructor.t * typ) list =
[none_constr, (TLit TUnit, Pos.no_pos); some_constr, (TAny, Pos.no_pos)]
(* FIXME: proper typing in all the constructors below *)
let make_none m =
let mark = Marked.mark m in
let tunit = D.TLit D.TUnit, D.mark_pos m in
let tunit = TLit TUnit, Expr.mark_pos m in
Bindlib.box
@@ mark
@@ EInj
( Marked.mark
(D.map_mark (fun pos -> pos) (fun _ -> tunit) m)
(Expr.map_mark (fun pos -> pos) (fun _ -> tunit) m)
(ELit LUnit),
0,
option_enum,
[D.TLit D.TUnit, Pos.no_pos; D.TAny, Pos.no_pos] )
[TLit TUnit, Pos.no_pos; TAny, Pos.no_pos] )
let make_some e =
let m = Marked.get_mark @@ Bindlib.unbox e in
let mark = Marked.mark m in
let+ e in
Bindlib.box_apply
(fun e ->
mark
@@ EInj
(e, 1, option_enum, [D.TLit D.TUnit, D.mark_pos m; D.TAny, D.mark_pos m])
( e,
1,
option_enum,
[TLit TUnit, Expr.mark_pos m; TAny, Expr.mark_pos m] ))
e
(** [make_matchopt_with_abs_arms arg e_none e_some] build an expression
[match arg with |None -> e_none | Some -> e_some] and requires e_some and
@ -176,8 +65,10 @@ let make_some e =
let make_matchopt_with_abs_arms arg e_none e_some =
let m = Marked.get_mark @@ Bindlib.unbox arg in
let mark = Marked.mark m in
let+ arg and+ e_none and+ e_some in
mark @@ EMatch (arg, [e_none; e_some], option_enum)
Bindlib.box_apply3
(fun arg e_none e_some ->
mark @@ EMatch (arg, [e_none; e_some], option_enum))
arg e_none e_some
(** [make_matchopt pos v tau arg e_none e_some] builds an expression
[match arg with | None () -> e_none | Some v -> e_some]. It binds v to
@ -187,8 +78,8 @@ let make_matchopt m v tau arg e_none e_some =
let x = Var.make "_" in
make_matchopt_with_abs_arms arg
(make_abs (Array.of_list [x]) e_none [D.TLit D.TUnit, D.mark_pos m] m)
(make_abs (Array.of_list [v]) e_some [tau] m)
(Expr.make_abs [| x |] e_none [TLit TUnit, Expr.mark_pos m] m)
(Expr.make_abs [| v |] e_some [tau] m)
let handle_default = Var.make "handle_default"
let handle_default_opt = Var.make "handle_default_opt"

179
compiler/lcalc/ast.mli
View File

@ -14,8 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
include module type of Astgen
open Shared_ast
(** Abstract syntax tree for the lambda calculus *)
@ -23,172 +22,38 @@ include module type of Astgen
type lit = lcalc glit
type 'm expr = (lcalc, 'm mark) gexpr
and 'm marked_expr = (lcalc, 'm mark) marked_gexpr
type 'm naked_expr = (lcalc, 'm mark) naked_gexpr
and 'm expr = (lcalc, 'm mark) gexpr
type 'm program = ('m expr, 'm) Dcalc.Ast.program_generic
(** {1 Variable helpers} *)
type 'm var = 'm expr Var.t
type 'm vars = 'm expr Var.vars
(** {2 Program traversal} *)
val map_expr :
'a ->
f:('a -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box) ->
('m1 expr, 'm2 mark) Marked.t ->
'm2 marked_expr Bindlib.box
(** See [Dcalc.Ast.map_expr] *)
val map_expr_top_down :
f:('m1 marked_expr -> ('m1 expr, 'm2 mark) Marked.t) ->
'm1 marked_expr ->
'm2 marked_expr Bindlib.box
(** See [Dcalc.Ast.map_expr_top_down] *)
val map_expr_marks :
f:('m1 mark -> 'm2 mark) -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box
(** See [Dcalc.Ast.map_expr_marks] *)
val untype_expr : 'm marked_expr -> Dcalc.Ast.untyped marked_expr Bindlib.box
val untype_program : 'm program -> Dcalc.Ast.untyped program
(** {1 Boxed constructors} *)
val evar : 'm expr Bindlib.var -> 'm mark -> 'm marked_expr Bindlib.box
val etuple :
'm marked_expr Bindlib.box list ->
Dcalc.Ast.StructName.t option ->
'm mark ->
'm marked_expr Bindlib.box
val etupleaccess :
'm marked_expr Bindlib.box ->
int ->
Dcalc.Ast.StructName.t option ->
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val einj :
'm marked_expr Bindlib.box ->
int ->
Dcalc.Ast.EnumName.t ->
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val ematch :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
Dcalc.Ast.EnumName.t ->
'm mark ->
'm marked_expr Bindlib.box
val earray :
'm marked_expr Bindlib.box list -> 'm mark -> 'm marked_expr Bindlib.box
val elit : lit -> 'm mark -> 'm marked_expr Bindlib.box
val eabs :
('m expr, 'm marked_expr) Bindlib.mbinder Bindlib.box ->
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val eapp :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val eassert :
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
val eop : Dcalc.Ast.operator -> 'm mark -> 'm marked_expr Bindlib.box
val eifthenelse :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val ecatch :
'm marked_expr Bindlib.box ->
except ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eraise : except -> 'm mark -> 'm marked_expr Bindlib.box
type 'm program = 'm expr Shared_ast.program
(** {1 Language terms construction}*)
val make_var : ('m var, 'm) Dcalc.Ast.marked -> 'm marked_expr Bindlib.box
val make_abs :
'm vars ->
'm marked_expr Bindlib.box ->
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val make_app :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val make_let_in :
'm var ->
Dcalc.Ast.typ Marked.pos ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
Pos.t ->
'm marked_expr Bindlib.box
val make_multiple_let_in :
'm vars ->
Dcalc.Ast.typ Marked.pos list ->
'm marked_expr Bindlib.box list ->
'm marked_expr Bindlib.box ->
Pos.t ->
'm marked_expr Bindlib.box
val option_enum : Dcalc.Ast.EnumName.t
val none_constr : Dcalc.Ast.EnumConstructor.t
val some_constr : Dcalc.Ast.EnumConstructor.t
val option_enum_config :
(Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Marked.pos) list
val make_none : 'm mark -> 'm marked_expr Bindlib.box
val make_some : 'm marked_expr Bindlib.box -> 'm marked_expr Bindlib.box
val option_enum : EnumName.t
val none_constr : EnumConstructor.t
val some_constr : EnumConstructor.t
val option_enum_config : (EnumConstructor.t * typ) list
val make_none : 'm mark -> 'm expr Bindlib.box
val make_some : 'm expr Bindlib.box -> 'm expr Bindlib.box
val make_matchopt_with_abs_arms :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box
'm expr Bindlib.box ->
'm expr Bindlib.box ->
'm expr Bindlib.box ->
'm expr Bindlib.box
val make_matchopt :
'm mark ->
'm var ->
Dcalc.Ast.typ Marked.pos ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box
'm expr Var.t ->
typ ->
'm expr Bindlib.box ->
'm expr Bindlib.box ->
'm expr Bindlib.box ->
'm expr Bindlib.box
(** [e' = make_matchopt'' pos v e e_none e_some] Builds the term corresponding
to [match e with | None -> fun () -> e_none |Some -> fun v -> e_some]. *)
val box_expr : 'm marked_expr -> 'm marked_expr Bindlib.box
(** {1 Special symbols} *)
val handle_default : untyped var
val handle_default_opt : untyped var
val handle_default : untyped expr Var.t
val handle_default_opt : untyped expr Var.t

90
compiler/lcalc/closure_conversion.ml
View File

@ -14,8 +14,9 @@
License for the specific language governing permissions and limitations under
the License. *)
open Ast
open Utils
open Shared_ast
open Ast
module D = Dcalc.Ast
(** TODO: This version is not yet debugged and ought to be specialized when
@ -26,28 +27,23 @@ type 'm ctx = { name_context : string; globally_bound_vars : 'm expr Var.Set.t }
(** Returns the expression with closed closures and the set of free variables
inside this new expression. Implementation guided by
http://gallium.inria.fr/~fpottier/mpri/cours04.pdf#page=9. *)
let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
m marked_expr Bindlib.box =
let module MVarSet = Set.Make (struct
type t = m var
let compare = Bindlib.compare_vars
end) in
let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) :
m expr Bindlib.box =
let rec aux e =
match Marked.unmark e with
| EVar v ->
( Bindlib.box_apply
(fun new_v -> new_v, Marked.get_mark e)
(Bindlib.box_var v),
if Var.Set.mem v ctx.globally_bound_vars then MVarSet.empty
else MVarSet.singleton v )
if Var.Set.mem v ctx.globally_bound_vars then Var.Set.empty
else Var.Set.singleton v )
| ETuple (args, s) ->
let new_args, free_vars =
List.fold_left
(fun (new_args, free_vars) arg ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union new_free_vars free_vars)
([], MVarSet.empty) args
new_arg :: new_args, Var.Set.union new_free_vars free_vars)
([], Var.Set.empty) args
in
( Bindlib.box_apply
(fun new_args -> ETuple (List.rev new_args, s), Marked.get_mark e)
@ -82,7 +78,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
EAbs (new_binder, typs), Marked.get_mark arm)
new_binder
:: new_arms,
MVarSet.union free_vars new_free_vars )
Var.Set.union free_vars new_free_vars )
| _ -> failwith "should not happen")
arms ([], free_vars)
in
@ -97,14 +93,14 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], MVarSet.empty)
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], Var.Set.empty)
in
( Bindlib.box_apply
(fun new_args -> EArray new_args, Marked.get_mark e)
(Bindlib.box_list new_args),
free_vars )
| ELit l -> Bindlib.box (ELit l, Marked.get_mark e), MVarSet.empty
| ELit l -> Bindlib.box (ELit l, Marked.get_mark e), Var.Set.empty
| EApp ((EAbs (binder, typs_abs), e1_pos), args) ->
(* let-binding, we should not close these *)
let vars, body = Bindlib.unmbind binder in
@ -114,7 +110,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], free_vars)
in
( Bindlib.box_apply2
@ -127,23 +123,23 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
| EAbs (binder, typs) ->
(* λ x.t *)
let binder_mark = Marked.get_mark e in
let binder_pos = D.mark_pos binder_mark in
let binder_pos = Expr.mark_pos binder_mark in
(* Converting the closure. *)
let vars, body = Bindlib.unmbind binder in
(* t *)
let new_body, body_vars = aux body in
(* [[t]] *)
let extra_vars =
MVarSet.diff body_vars (MVarSet.of_list (Array.to_list vars))
Var.Set.diff body_vars (Var.Set.of_list (Array.to_list vars))
in
let extra_vars_list = MVarSet.elements extra_vars in
let extra_vars_list = Var.Set.elements extra_vars in
(* x1, ..., xn *)
let code_var = Var.make ctx.name_context in
(* code *)
let inner_c_var = Var.make "env" in
let any_ty = Dcalc.Ast.TAny, binder_pos in
let any_ty = TAny, binder_pos in
let new_closure_body =
make_multiple_let_in
Expr.make_multiple_let_in
(Array.of_list extra_vars_list)
(List.map (fun _ -> any_ty) extra_vars_list)
(List.mapi
@ -158,17 +154,18 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
binder_mark ))
(Bindlib.box_var inner_c_var))
extra_vars_list)
new_body (D.mark_pos binder_mark)
new_body
(Expr.mark_pos binder_mark)
in
let new_closure =
make_abs
Expr.make_abs
(Array.concat [Array.make 1 inner_c_var; vars])
new_closure_body
((Dcalc.Ast.TAny, binder_pos) :: typs)
((TAny, binder_pos) :: typs)
(Marked.get_mark e)
in
( make_let_in code_var
(Dcalc.Ast.TAny, D.pos e)
( Expr.make_let_in code_var
(TAny, Expr.pos e)
new_closure
(Bindlib.box_apply2
(fun code_var extra_vars ->
@ -184,7 +181,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
(List.map
(fun extra_var -> Bindlib.box_var extra_var)
extra_vars_list)))
(D.pos e),
(Expr.pos e),
extra_vars )
| EApp ((EOp op, pos_op), args) ->
(* This corresponds to an operator call, which we don't want to
@ -193,8 +190,8 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], MVarSet.empty)
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], Var.Set.empty)
in
( Bindlib.box_apply
(fun new_e2 -> EApp ((EOp op, pos_op), new_e2), Marked.get_mark e)
@ -206,8 +203,8 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], MVarSet.empty)
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], Var.Set.empty)
in
( Bindlib.box_apply2
(fun new_v new_e2 -> EApp ((new_v, v_pos), new_e2), Marked.get_mark e)
@ -222,12 +219,12 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], free_vars)
in
let call_expr =
make_let_in code_var
(Dcalc.Ast.TAny, D.pos e)
Expr.make_let_in code_var
(TAny, Expr.pos e)
(Bindlib.box_apply
(fun env_var ->
( ETupleAccess
@ -242,9 +239,9 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
Marked.get_mark e ))
(Bindlib.box_var code_var) (Bindlib.box_var env_var)
(Bindlib.box_list new_args))
(D.pos e)
(Expr.pos e)
in
( make_let_in env_var (Dcalc.Ast.TAny, D.pos e) new_e1 call_expr (D.pos e),
( Expr.make_let_in env_var (TAny, Expr.pos e) new_e1 call_expr (Expr.pos e),
free_vars )
| EAssert e1 ->
let new_e1, free_vars = aux e1 in
@ -252,7 +249,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
(fun new_e1 -> EAssert new_e1, Marked.get_mark e)
new_e1,
free_vars )
| EOp op -> Bindlib.box (EOp op, Marked.get_mark e), MVarSet.empty
| EOp op -> Bindlib.box (EOp op, Marked.get_mark e), Var.Set.empty
| EIfThenElse (e1, e2, e3) ->
let new_e1, free_vars1 = aux e1 in
let new_e2, free_vars2 = aux e2 in
@ -261,9 +258,9 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
(fun new_e1 new_e2 new_e3 ->
EIfThenElse (new_e1, new_e2, new_e3), Marked.get_mark e)
new_e1 new_e2 new_e3,
MVarSet.union (MVarSet.union free_vars1 free_vars2) free_vars3 )
Var.Set.union (Var.Set.union free_vars1 free_vars2) free_vars3 )
| ERaise except ->
Bindlib.box (ERaise except, Marked.get_mark e), MVarSet.empty
Bindlib.box (ERaise except, Marked.get_mark e), Var.Set.empty
| ECatch (e1, except, e2) ->
let new_e1, free_vars1 = aux e1 in
let new_e2, free_vars2 = aux e2 in
@ -271,14 +268,14 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m marked_expr) :
(fun new_e1 new_e2 ->
ECatch (new_e1, except, new_e2), Marked.get_mark e)
new_e1 new_e2,
MVarSet.union free_vars1 free_vars2 )
Var.Set.union free_vars1 free_vars2 )
in
let e', _vars = aux e in
e'
let closure_conversion (p : 'm program) : 'm program Bindlib.box =
let new_scopes, _ =
D.fold_left_scope_defs
Scope.fold_left
~f:(fun (acc_new_scopes, global_vars) scope scope_var ->
(* [acc_new_scopes] represents what has been translated in the past, it
needs a continuation to attach the rest of the translated scopes. *)
@ -288,13 +285,12 @@ let closure_conversion (p : 'm program) : 'm program Bindlib.box =
let global_vars = Var.Set.add scope_var global_vars in
let ctx =
{
name_context =
Marked.unmark (Dcalc.Ast.ScopeName.get_info scope.scope_name);
name_context = Marked.unmark (ScopeName.get_info scope.scope_name);
globally_bound_vars = global_vars;
}
in
let new_scope_lets =
D.map_exprs_in_scope_lets
Scope.map_exprs_in_lets
~f:(closure_conversion_expr ctx)
~varf:(fun v -> v)
scope_body_expr
@ -306,7 +302,7 @@ let closure_conversion (p : 'm program) : 'm program Bindlib.box =
acc_new_scopes
(Bindlib.box_apply2
(fun new_scope_body_expr next ->
D.ScopeDef
ScopeDef
{
scope with
scope_body =
@ -327,4 +323,4 @@ let closure_conversion (p : 'm program) : 'm program Bindlib.box =
in
Bindlib.box_apply
(fun new_scopes -> { p with scopes = new_scopes })
(new_scopes (Bindlib.box D.Nil))
(new_scopes (Bindlib.box Nil))

125
compiler/lcalc/compile_with_exceptions.ml
View File

@ -15,6 +15,7 @@
the License. *)
open Utils
open Shared_ast
module D = Dcalc.Ast
module A = Ast
@ -22,38 +23,27 @@ type 'm ctx = ('m D.expr, 'm A.expr Var.t) Var.Map.t
(** This environment contains a mapping between the variables in Dcalc and their
correspondance in Lcalc. *)
let translate_lit (l : D.lit) : 'm A.expr =
match l with
| D.LBool l -> A.ELit (A.LBool l)
| D.LInt i -> A.ELit (A.LInt i)
| D.LRat r -> A.ELit (A.LRat r)
| D.LMoney m -> A.ELit (A.LMoney m)
| D.LUnit -> A.ELit A.LUnit
| D.LDate d -> A.ELit (A.LDate d)
| D.LDuration d -> A.ELit (A.LDuration d)
| D.LEmptyError -> A.ERaise A.EmptyError
let thunk_expr (e : 'm A.marked_expr Bindlib.box) (mark : 'm A.mark) :
'm A.marked_expr Bindlib.box =
let thunk_expr (e : 'm A.expr Bindlib.box) (mark : 'm mark) :
'm A.expr Bindlib.box =
let dummy_var = Var.make "_" in
A.make_abs [| dummy_var |] e [D.TAny, D.mark_pos mark] mark
Expr.make_abs [| dummy_var |] e [TAny, Expr.mark_pos mark] mark
let rec translate_default
(ctx : 'm ctx)
(exceptions : 'm D.marked_expr list)
(just : 'm D.marked_expr)
(cons : 'm D.marked_expr)
(mark_default : 'm D.mark) : 'm A.marked_expr Bindlib.box =
(exceptions : 'm D.expr list)
(just : 'm D.expr)
(cons : 'm D.expr)
(mark_default : 'm mark) : 'm A.expr Bindlib.box =
let exceptions =
List.map
(fun except -> thunk_expr (translate_expr ctx except) mark_default)
exceptions
in
let exceptions =
A.make_app
(A.make_var (Var.translate A.handle_default, mark_default))
Expr.make_app
(Expr.make_var (Var.translate A.handle_default, mark_default))
[
A.earray exceptions mark_default;
Expr.earray exceptions mark_default;
thunk_expr (translate_expr ctx just) mark_default;
thunk_expr (translate_expr ctx cons) mark_default;
]
@ -61,37 +51,40 @@ let rec translate_default
in
exceptions
and translate_expr (ctx : 'm ctx) (e : 'm D.marked_expr) :
'm A.marked_expr Bindlib.box =
and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr Bindlib.box =
match Marked.unmark e with
| D.EVar v -> A.make_var (Var.Map.find v ctx, Marked.get_mark e)
| D.ETuple (args, s) ->
A.etuple (List.map (translate_expr ctx) args) s (Marked.get_mark e)
| D.ETupleAccess (e1, i, s, ts) ->
A.etupleaccess (translate_expr ctx e1) i s ts (Marked.get_mark e)
| D.EInj (e1, i, en, ts) ->
A.einj (translate_expr ctx e1) i en ts (Marked.get_mark e)
| D.EMatch (e1, cases, en) ->
A.ematch (translate_expr ctx e1)
| EVar v -> Expr.make_var (Var.Map.find v ctx, Marked.get_mark e)
| ETuple (args, s) ->
Expr.etuple (List.map (translate_expr ctx) args) s (Marked.get_mark e)
| ETupleAccess (e1, i, s, ts) ->
Expr.etupleaccess (translate_expr ctx e1) i s ts (Marked.get_mark e)
| EInj (e1, i, en, ts) ->
Expr.einj (translate_expr ctx e1) i en ts (Marked.get_mark e)
| EMatch (e1, cases, en) ->
Expr.ematch (translate_expr ctx e1)
(List.map (translate_expr ctx) cases)
en (Marked.get_mark e)
| D.EArray es ->
A.earray (List.map (translate_expr ctx) es) (Marked.get_mark e)
| D.ELit l -> Bindlib.box (Marked.same_mark_as (translate_lit l) e)
| D.EOp op -> A.eop op (Marked.get_mark e)
| D.EIfThenElse (e1, e2, e3) ->
A.eifthenelse (translate_expr ctx e1) (translate_expr ctx e2)
| EArray es ->
Expr.earray (List.map (translate_expr ctx) es) (Marked.get_mark e)
| ELit
((LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
l) ->
Bindlib.box (Marked.same_mark_as (ELit l) e)
| ELit LEmptyError -> Bindlib.box (Marked.same_mark_as (ERaise EmptyError) e)
| EOp op -> Expr.eop op (Marked.get_mark e)
| EIfThenElse (e1, e2, e3) ->
Expr.eifthenelse (translate_expr ctx e1) (translate_expr ctx e2)
(translate_expr ctx e3) (Marked.get_mark e)
| D.EAssert e1 -> A.eassert (translate_expr ctx e1) (Marked.get_mark e)
| D.ErrorOnEmpty arg ->
A.ecatch (translate_expr ctx arg) A.EmptyError
(Bindlib.box (Marked.same_mark_as (A.ERaise A.NoValueProvided) e))
| EAssert e1 -> Expr.eassert (translate_expr ctx e1) (Marked.get_mark e)
| ErrorOnEmpty arg ->
Expr.ecatch (translate_expr ctx arg) EmptyError
(Bindlib.box (Marked.same_mark_as (ERaise NoValueProvided) e))
(Marked.get_mark e)
| D.EApp (e1, args) ->
A.eapp (translate_expr ctx e1)
| EApp (e1, args) ->
Expr.eapp (translate_expr ctx e1)
(List.map (translate_expr ctx) args)
(Marked.get_mark e)
| D.EAbs (binder, ts) ->
| EAbs (binder, ts) ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
Array.fold_right
@ -104,24 +97,24 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.marked_expr) :
let new_body = translate_expr ctx body in
let new_binder = Bindlib.bind_mvar lc_vars new_body in
Bindlib.box_apply
(fun new_binder -> Marked.same_mark_as (A.EAbs (new_binder, ts)) e)
(fun new_binder -> Marked.same_mark_as (EAbs (new_binder, ts)) e)
new_binder
| D.EDefault ([exn], just, cons) when !Cli.optimize_flag ->
A.ecatch (translate_expr ctx exn) A.EmptyError
(A.eifthenelse (translate_expr ctx just) (translate_expr ctx cons)
(Bindlib.box (Marked.same_mark_as (A.ERaise A.EmptyError) e))
| EDefault ([exn], just, cons) when !Cli.optimize_flag ->
Expr.ecatch (translate_expr ctx exn) EmptyError
(Expr.eifthenelse (translate_expr ctx just) (translate_expr ctx cons)
(Bindlib.box (Marked.same_mark_as (ERaise EmptyError) e))
(Marked.get_mark e))
(Marked.get_mark e)
| D.EDefault (exceptions, just, cons) ->
| EDefault (exceptions, just, cons) ->
translate_default ctx exceptions just cons (Marked.get_mark e)
let rec translate_scope_lets
(decl_ctx : D.decl_ctx)
(decl_ctx : decl_ctx)
(ctx : 'm ctx)
(scope_lets : ('m D.expr, 'm) D.scope_body_expr) :
('m A.expr, 'm) D.scope_body_expr Bindlib.box =
(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 -> D.Result e) (translate_expr ctx e)
| Result e -> Bindlib.box_apply (fun e -> Result e) (translate_expr ctx e)
| ScopeLet scope_let ->
let old_scope_let_var, scope_let_next =
Bindlib.unbind scope_let.scope_let_next
@ -133,26 +126,26 @@ let rec translate_scope_lets
let new_scope_next = Bindlib.bind_var new_scope_let_var new_scope_next in
Bindlib.box_apply2
(fun new_scope_next new_scope_let_expr ->
D.ScopeLet
ScopeLet
{
scope_let_typ = scope_let.D.scope_let_typ;
scope_let_kind = scope_let.D.scope_let_kind;
scope_let_pos = scope_let.D.scope_let_pos;
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 new_scope_let_expr
let rec translate_scopes
(decl_ctx : D.decl_ctx)
(decl_ctx : decl_ctx)
(ctx : 'm ctx)
(scopes : ('m D.expr, 'm) D.scopes) : ('m A.expr, 'm) D.scopes Bindlib.box =
(scopes : 'm D.expr scopes) : 'm A.expr scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box D.Nil
| Nil -> Bindlib.box Nil
| ScopeDef scope_def ->
let old_scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let new_scope_var =
Var.make (Marked.unmark (D.ScopeName.get_info scope_def.scope_name))
Var.make (Marked.unmark (ScopeName.get_info scope_def.scope_name))
in
let old_scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
@ -165,11 +158,11 @@ let rec translate_scopes
let new_scope_body_expr =
Bindlib.bind_var new_scope_input_var new_scope_body_expr
in
let new_scope : ('m A.expr, 'm) D.scope_body Bindlib.box =
let new_scope : 'm A.expr scope_body Bindlib.box =
Bindlib.box_apply
(fun new_scope_body_expr ->
{
D.scope_body_input_struct =
scope_body_input_struct =
scope_def.scope_body.scope_body_input_struct;
scope_body_output_struct =
scope_def.scope_body.scope_body_output_struct;
@ -184,7 +177,7 @@ let rec translate_scopes
in
Bindlib.box_apply2
(fun new_scope scope_next ->
D.ScopeDef
ScopeDef
{
scope_name = scope_def.scope_name;
scope_body = new_scope;

288
compiler/lcalc/compile_without_exceptions.ml
View File

@ -40,12 +40,15 @@ module A = Ast
hoisted and later handled by the [translate_expr] function. Every other
cases is found in the translate_and_hoist function. *)
type 'm hoists = ('m A.expr, 'm D.marked_expr) Var.Map.t
(** Hoists definition. It represent bindings between [A.Var.t] and [D.expr]. *)
open Shared_ast
type 'm hoists = ('m A.expr, 'm D.expr) Var.Map.t
(** Hoists definition. It represent bindings between [A.Var.t] and
[D.naked_expr]. *)
type 'm info = {
expr : 'm A.marked_expr Bindlib.box;
var : 'm A.expr Bindlib.var;
naked_expr : 'm A.expr Bindlib.box;
var : 'm A.expr Var.t;
is_pure : bool;
}
(** Information about each encontered Dcalc variable is stored inside a context
@ -55,18 +58,19 @@ type 'm info = {
matched (false) or if it never can be EmptyError (true). *)
let pp_info (fmt : Format.formatter) (info : 'm info) =
Format.fprintf fmt "{var: %a; is_pure: %b}" Print.format_var info.var
info.is_pure
Format.fprintf fmt "{var: %a; is_pure: %b}" Print.var info.var info.is_pure
type 'm ctx = {
decl_ctx : D.decl_ctx;
decl_ctx : decl_ctx;
vars : ('m D.expr, 'm info) Var.Map.t;
(** information context about variables in the current scope *)
}
let _pp_ctx (fmt : Format.formatter) (ctx : 'm ctx) =
let pp_binding (fmt : Format.formatter) ((v, info) : 'm D.var * 'm info) =
Format.fprintf fmt "%a: %a" Dcalc.Print.format_var v pp_info info
let pp_binding
(fmt : Format.formatter)
((v, info) : 'm D.expr Var.t * 'm info) =
Format.fprintf fmt "%a: %a" Print.var v pp_info info
in
let pp_bindings =
@ -79,32 +83,36 @@ let _pp_ctx (fmt : Format.formatter) (ctx : 'm ctx) =
(** [find ~info n ctx] is a warpper to ocaml's Map.find that handle errors in a
slightly better way. *)
let find ?(info : string = "none") (n : 'm D.var) (ctx : 'm ctx) : 'm info =
let find ?(info : string = "none") (n : 'm D.expr Var.t) (ctx : 'm ctx) :
'm info =
(* let _ = Format.asprintf "Searching for variable %a inside context %a"
Dcalc.Print.format_var n pp_ctx ctx |> Cli.debug_print in *)
Print.var n pp_ctx ctx |> Cli.debug_print in *)
try Var.Map.find n ctx.vars
with Not_found ->
Errors.raise_spanned_error Pos.no_pos
"Internal Error: Variable %a was not found in the current environment. \
Additional informations : %s."
Dcalc.Print.format_var n info
Print.var n info
(** [add_var pos var is_pure ctx] add to the context [ctx] the Dcalc variable
var, creating a unique corresponding variable in Lcalc, with the
corresponding expression, and the boolean is_pure. It is usefull for
debuging purposes as it printing each of the Dcalc/Lcalc variable pairs. *)
let add_var (mark : 'm D.mark) (var : 'm D.var) (is_pure : bool) (ctx : 'm ctx)
: 'm ctx =
let add_var
(mark : 'm mark)
(var : 'm D.expr Var.t)
(is_pure : bool)
(ctx : 'm ctx) : 'm ctx =
let new_var = Var.make (Bindlib.name_of var) in
let expr = A.make_var (new_var, mark) in
let naked_expr = Expr.make_var (new_var, mark) in
(* Cli.debug_print @@ Format.asprintf "D.%a |-> A.%a" Dcalc.Print.format_var
var Print.format_var new_var; *)
(* Cli.debug_print @@ Format.asprintf "D.%a |-> A.%a" Print.var var Print.var
new_var; *)
{
ctx with
vars =
Var.Map.update var
(fun _ -> Some { expr; var = new_var; is_pure })
(fun _ -> Some { naked_expr; var = new_var; is_pure })
ctx.vars;
}
@ -113,37 +121,23 @@ let add_var (mark : 'm D.mark) (var : 'm D.var) (is_pure : bool) (ctx : 'm ctx)
Since positions where there is thunked expressions is exactly where we will
put option expressions. Hence, the transformation simply reduce [unit -> 'a]
into ['a option] recursivly. There is no polymorphism inside catala. *)
let rec translate_typ (tau : D.typ Marked.pos) : D.typ Marked.pos =
let rec translate_typ (tau : typ) : typ =
(Fun.flip Marked.same_mark_as)
tau
begin
match Marked.unmark tau with
| D.TLit l -> D.TLit l
| D.TTuple (ts, s) -> D.TTuple (List.map translate_typ ts, s)
| D.TEnum (ts, en) -> D.TEnum (List.map translate_typ ts, en)
| D.TAny -> D.TAny
| D.TArray ts -> D.TArray (translate_typ ts)
| TLit l -> TLit l
| TTuple ts -> TTuple (List.map translate_typ ts)
| TStruct s -> TStruct s
| TEnum en -> TEnum en
| TOption t -> TOption t
| TAny -> TAny
| TArray ts -> TArray (translate_typ ts)
(* catala is not polymorphic *)
| D.TArrow ((D.TLit D.TUnit, pos_unit), t2) ->
D.TEnum ([D.TLit D.TUnit, pos_unit; translate_typ t2], A.option_enum)
(* D.TAny *)
| D.TArrow (t1, t2) -> D.TArrow (translate_typ t1, translate_typ t2)
| TArrow ((TLit TUnit, _), t2) -> TOption (translate_typ t2)
| TArrow (t1, t2) -> TArrow (translate_typ t1, translate_typ t2)
end
let translate_lit (l : D.lit) (pos : Pos.t) : A.lit =
match l with
| D.LBool l -> A.LBool l
| D.LInt i -> A.LInt i
| D.LRat r -> A.LRat r
| D.LMoney m -> A.LMoney m
| D.LUnit -> A.LUnit
| D.LDate d -> A.LDate d
| D.LDuration d -> A.LDuration d
| D.LEmptyError ->
Errors.raise_spanned_error pos
"Internal Error: An empty error was found in a place that shouldn't be \
possible."
(** [c = disjoint_union_maps cs] Compute the disjoint union of multiple maps.
Raises an internal error if there is two identicals keys in differnts parts. *)
let disjoint_union_maps (pos : Pos.t) (cs : ('e, 'a) Var.Map.t list) :
@ -162,14 +156,14 @@ let disjoint_union_maps (pos : Pos.t) (cs : ('e, 'a) Var.Map.t list) :
the equivalence between the execution of e and the execution of e' are
equivalent in an environement where each variable v, where (v, e_v) is in
hoists, has the non-empty value in e_v. *)
let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
'm A.marked_expr Bindlib.box * 'm hoists =
let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
'm A.expr Bindlib.box * 'm hoists =
let pos = Marked.get_mark e in
match Marked.unmark e with
(* empty-producing/using terms. We hoist those. (D.EVar in some cases,
EApp(D.EVar _, [ELit LUnit]), EDefault _, ELit LEmptyDefault) I'm unsure
about assert. *)
| D.EVar v ->
| EVar v ->
(* todo: for now, every unpure (such that [is_pure] is [false] in the
current context) is thunked, hence matched in the next case. This
assumption can change in the future, and this case is here for this
@ -177,26 +171,24 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
if not (find ~info:"search for a variable" v ctx).is_pure then
let v' = Var.make (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
created a variable %a to replace it" Dcalc.Print.format_var v
Print.format_var v'; *)
A.make_var (v', pos), Var.Map.singleton v' e
else (find ~info:"should never happend" v ctx).expr, Var.Map.empty
| D.EApp ((D.EVar v, p), [(D.ELit D.LUnit, _)]) ->
created a variable %a to replace it" Print.var v Print.var v'; *)
Expr.make_var (v', pos), Var.Map.singleton v' e
else (find ~info:"should never happend" v ctx).naked_expr, Var.Map.empty
| EApp ((EVar v, p), [(ELit LUnit, _)]) ->
if not (find ~info:"search for a variable" v ctx).is_pure then
let v' = Var.make (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
created a variable %a to replace it" Dcalc.Print.format_var v
Print.format_var v'; *)
A.make_var (v', pos), Var.Map.singleton v' (D.EVar v, p)
created a variable %a to replace it" Print.var v Print.var v'; *)
Expr.make_var (v', pos), Var.Map.singleton v' (EVar v, p)
else
Errors.raise_spanned_error (D.pos e)
Errors.raise_spanned_error (Expr.pos e)
"Internal error: an pure variable was found in an unpure environment."
| D.EDefault (_exceptions, _just, _cons) ->
| EDefault (_exceptions, _just, _cons) ->
let v' = Var.make "default_term" in
A.make_var (v', pos), Var.Map.singleton v' e
| D.ELit D.LEmptyError ->
Expr.make_var (v', pos), Var.Map.singleton v' e
| ELit LEmptyError ->
let v' = Var.make "empty_litteral" in
A.make_var (v', pos), Var.Map.singleton v' e
Expr.make_var (v', pos), Var.Map.singleton v' e
(* This one is a very special case. It transform an unpure expression
environement to a pure expression. *)
| ErrorOnEmpty arg ->
@ -207,30 +199,33 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
let arg' = translate_expr ctx arg in
( A.make_matchopt_with_abs_arms arg'
(A.make_abs [| silent_var |]
(Bindlib.box (A.ERaise A.NoValueProvided, pos))
[D.TAny, D.pos e]
(Expr.make_abs [| silent_var |]
(Bindlib.box (ERaise NoValueProvided, pos))
[TAny, Expr.pos e]
pos)
(A.make_abs [| x |] (A.make_var (x, pos)) [D.TAny, D.pos e] pos),
(Expr.make_abs [| x |] (Expr.make_var (x, pos)) [TAny, Expr.pos e] pos),
Var.Map.empty )
(* pure terms *)
| D.ELit l -> A.elit (translate_lit l (D.pos e)) pos, Var.Map.empty
| D.EIfThenElse (e1, e2, e3) ->
| ELit
((LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
l) ->
Expr.elit l pos, Var.Map.empty
| EIfThenElse (e1, e2, e3) ->
let e1', h1 = translate_and_hoist ctx e1 in
let e2', h2 = translate_and_hoist ctx e2 in
let e3', h3 = translate_and_hoist ctx e3 in
let e' = A.eifthenelse e1' e2' e3' pos in
let e' = Expr.eifthenelse e1' e2' e3' pos in
(*(* equivalent code : *) let e' = let+ e1' = e1' and+ e2' = e2' and+ e3' =
e3' in (A.EIfThenElse (e1', e2', e3'), pos) in *)
e', disjoint_union_maps (D.pos e) [h1; h2; h3]
| D.EAssert e1 ->
e', disjoint_union_maps (Expr.pos e) [h1; h2; h3]
| EAssert e1 ->
(* same behavior as in the ICFP paper: if e1 is empty, then no error is
raised. *)
let e1', h1 = translate_and_hoist ctx e1 in
A.eassert e1' pos, h1
| D.EAbs (binder, ts) ->
Expr.eassert e1' pos, h1
| EAbs (binder, ts) ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
ArrayLabels.fold_right vars ~init:(ctx, []) ~f:(fun var (ctx, lc_vars) ->
@ -252,7 +247,7 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
let new_binder = Bindlib.bind_mvar lc_vars new_body in
( Bindlib.box_apply
(fun new_binder -> A.EAbs (new_binder, List.map translate_typ ts), pos)
(fun new_binder -> EAbs (new_binder, List.map translate_typ ts), pos)
new_binder,
hoists )
| EApp (e1, args) ->
@ -261,23 +256,23 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
args |> List.map (translate_and_hoist ctx) |> List.split
in
let hoists = disjoint_union_maps (D.pos e) (h1 :: h_args) in
let e' = A.eapp e1' args' pos in
let hoists = disjoint_union_maps (Expr.pos e) (h1 :: h_args) in
let e' = Expr.eapp e1' args' pos in
e', hoists
| ETuple (args, s) ->
let args', h_args =
args |> List.map (translate_and_hoist ctx) |> List.split
in
let hoists = disjoint_union_maps (D.pos e) h_args in
A.etuple args' s pos, hoists
let hoists = disjoint_union_maps (Expr.pos e) h_args in
Expr.etuple args' s pos, hoists
| ETupleAccess (e1, i, s, ts) ->
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = A.etupleaccess e1' i s ts pos in
let e1' = Expr.etupleaccess e1' i s ts pos in
e1', hoists
| EInj (e1, i, en, ts) ->
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = A.einj e1' i en ts pos in
let e1' = Expr.einj e1' i en ts pos in
e1', hoists
| EMatch (e1, cases, en) ->
let e1', h1 = translate_and_hoist ctx e1 in
@ -285,17 +280,17 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
cases |> List.map (translate_and_hoist ctx) |> List.split
in
let hoists = disjoint_union_maps (D.pos e) (h1 :: h_cases) in
let e' = A.ematch e1' cases' en pos in
let hoists = disjoint_union_maps (Expr.pos e) (h1 :: h_cases) in
let e' = Expr.ematch e1' cases' en pos in
e', hoists
| EArray es ->
let es', hoists = es |> List.map (translate_and_hoist ctx) |> List.split in
A.earray es' pos, disjoint_union_maps (D.pos e) hoists
| EOp op -> Bindlib.box (A.EOp op, pos), Var.Map.empty
Expr.earray es' pos, disjoint_union_maps (Expr.pos e) hoists
| EOp op -> Bindlib.box (EOp op, pos), Var.Map.empty
and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.marked_expr)
: 'm A.marked_expr Bindlib.box =
and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.expr) :
'm A.expr Bindlib.box =
let e', hoists = translate_and_hoist ctx e in
let hoists = Var.Map.bindings hoists in
@ -303,34 +298,33 @@ and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.marked_expr)
(* build the hoists *)
(* Cli.debug_print @@ Format.asprintf "hoist for the expression: [%a]"
(Format.pp_print_list Print.format_var) (List.map fst hoists); *)
(Format.pp_print_list Print.var) (List.map fst hoists); *)
ListLabels.fold_left hoists
~init:(if append_esome then A.make_some e' else e')
~f:(fun acc (v, (hoist, mark_hoist)) ->
(* Cli.debug_print @@ Format.asprintf "hoist using A.%a" Print.format_var
v; *)
let c' : 'm A.marked_expr Bindlib.box =
(* Cli.debug_print @@ Format.asprintf "hoist using A.%a" Print.var v; *)
let c' : 'm A.expr Bindlib.box =
match hoist with
(* Here we have to handle only the cases appearing in hoists, as defined
the [translate_and_hoist] function. *)
| D.EVar v -> (find ~info:"should never happend" v ctx).expr
| D.EDefault (excep, just, cons) ->
| EVar v -> (find ~info:"should never happend" v ctx).naked_expr
| EDefault (excep, just, cons) ->
let excep' = List.map (translate_expr ctx) excep in
let just' = translate_expr ctx just in
let cons' = translate_expr ctx cons in
(* calls handle_option. *)
A.make_app
(A.make_var (Var.translate A.handle_default_opt, mark_hoist))
Expr.make_app
(Expr.make_var (Var.translate A.handle_default_opt, mark_hoist))
[
Bindlib.box_apply
(fun excep' -> A.EArray excep', mark_hoist)
(fun excep' -> EArray excep', mark_hoist)
(Bindlib.box_list excep');
just';
cons';
]
mark_hoist
| D.ELit D.LEmptyError -> A.make_none mark_hoist
| D.EAssert arg ->
| ELit LEmptyError -> A.make_none mark_hoist
| EAssert arg ->
let arg' = translate_expr ctx arg in
(* [ match arg with | None -> raise NoValueProvided | Some v -> assert
@ -339,62 +333,59 @@ and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.marked_expr)
let x = Var.make "assertion_argument" in
A.make_matchopt_with_abs_arms arg'
(A.make_abs [| silent_var |]
(Bindlib.box (A.ERaise A.NoValueProvided, mark_hoist))
[D.TAny, D.mark_pos mark_hoist]
(Expr.make_abs [| silent_var |]
(Bindlib.box (ERaise NoValueProvided, mark_hoist))
[TAny, Expr.mark_pos mark_hoist]
mark_hoist)
(A.make_abs [| x |]
(Expr.make_abs [| x |]
(Bindlib.box_apply
(fun arg -> A.EAssert arg, mark_hoist)
(A.make_var (x, mark_hoist)))
[D.TAny, D.mark_pos mark_hoist]
(fun arg -> EAssert arg, mark_hoist)
(Expr.make_var (x, mark_hoist)))
[TAny, Expr.mark_pos mark_hoist]
mark_hoist)
| _ ->
Errors.raise_spanned_error (D.mark_pos mark_hoist)
Errors.raise_spanned_error (Expr.mark_pos mark_hoist)
"Internal Error: An term was found in a position where it should \
not be"
in
(* [ match {{ c' }} with | None -> None | Some {{ v }} -> {{ acc }} end
] *)
(* Cli.debug_print @@ Format.asprintf "build matchopt using %a"
Print.format_var v; *)
(* Cli.debug_print @@ Format.asprintf "build matchopt using %a" Print.var
v; *)
A.make_matchopt mark_hoist v
(D.TAny, D.mark_pos mark_hoist)
(TAny, Expr.mark_pos mark_hoist)
c' (A.make_none mark_hoist) acc)
let rec translate_scope_let
(ctx : 'm ctx)
(lets : ('m D.expr, 'm) D.scope_body_expr) :
('m A.expr, 'm) D.scope_body_expr Bindlib.box =
let rec translate_scope_let (ctx : 'm ctx) (lets : 'm D.expr scope_body_expr) :
'm A.expr scope_body_expr Bindlib.box =
match lets with
| Result e ->
Bindlib.box_apply
(fun e -> D.Result e)
(fun e -> Result e)
(translate_expr ~append_esome:false ctx e)
| ScopeLet
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = typ;
scope_let_expr = D.EAbs (binder, _), emark;
scope_let_expr = EAbs (binder, _), emark;
scope_let_next = next;
scope_let_pos = pos;
} ->
(* special case : the subscope variable is thunked (context i/o). We remove
this thunking. *)
let _, expr = Bindlib.unmbind binder in
let _, naked_expr = Bindlib.unmbind binder in
let var_is_pure = true in
let var, next = Bindlib.unbind next in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var
var; *)
let vmark = D.map_mark (fun _ -> pos) (fun _ -> typ) emark in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Print.var var; *)
let vmark = Expr.map_mark (fun _ -> pos) (fun _ -> typ) emark in
let ctx' = add_var vmark var var_is_pure ctx in
let new_var = (find ~info:"variable that was just created" var ctx').var in
let new_next = translate_scope_let ctx' next in
Bindlib.box_apply2
(fun new_expr new_next ->
D.ScopeLet
ScopeLet
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = translate_typ typ;
@ -402,27 +393,26 @@ let rec translate_scope_let
scope_let_next = new_next;
scope_let_pos = pos;
})
(translate_expr ctx ~append_esome:false expr)
(translate_expr ctx ~append_esome:false naked_expr)
(Bindlib.bind_var new_var new_next)
| ScopeLet
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = typ;
scope_let_expr = (D.ErrorOnEmpty _, emark) as expr;
scope_let_expr = (ErrorOnEmpty _, emark) as naked_expr;
scope_let_next = next;
scope_let_pos = pos;
} ->
(* special case: regular input to the subscope *)
let var_is_pure = true in
let var, next = Bindlib.unbind next in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var
var; *)
let vmark = D.map_mark (fun _ -> pos) (fun _ -> typ) emark in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Print.var var; *)
let vmark = Expr.map_mark (fun _ -> pos) (fun _ -> typ) emark in
let ctx' = add_var vmark var var_is_pure ctx in
let new_var = (find ~info:"variable that was just created" var ctx').var in
Bindlib.box_apply2
(fun new_expr new_next ->
D.ScopeLet
ScopeLet
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = translate_typ typ;
@ -430,26 +420,25 @@ let rec translate_scope_let
scope_let_next = new_next;
scope_let_pos = pos;
})
(translate_expr ctx ~append_esome:false expr)
(translate_expr ctx ~append_esome:false naked_expr)
(Bindlib.bind_var new_var (translate_scope_let ctx' next))
| ScopeLet
{
scope_let_kind = SubScopeVarDefinition;
scope_let_pos = pos;
scope_let_expr = expr;
scope_let_expr = naked_expr;
_;
} ->
Errors.raise_spanned_error pos
"Internal Error: found an SubScopeVarDefinition that does not satisfy \
the invariants when translating Dcalc to Lcalc without exceptions: \
@[<hov 2>%a@]"
(Dcalc.Print.format_expr ctx.decl_ctx)
expr
(Expr.format ctx.decl_ctx) naked_expr
| ScopeLet
{
scope_let_kind = kind;
scope_let_typ = typ;
scope_let_expr = expr;
scope_let_expr = naked_expr;
scope_let_next = next;
scope_let_pos = pos;
} ->
@ -461,23 +450,22 @@ let rec translate_scope_let
thunked, then the variable is context. If it's not thunked, it's a
regular input. *)
match Marked.unmark typ with
| D.TArrow ((D.TLit D.TUnit, _), _) -> false
| TArrow ((TLit TUnit, _), _) -> false
| _ -> true)
| ScopeVarDefinition | SubScopeVarDefinition | CallingSubScope
| DestructuringSubScopeResults | Assertion ->
true
in
let var, next = Bindlib.unbind next in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var
var; *)
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Print.var var; *)
let vmark =
D.map_mark (fun _ -> pos) (fun _ -> typ) (Marked.get_mark expr)
Expr.map_mark (fun _ -> pos) (fun _ -> typ) (Marked.get_mark naked_expr)
in
let ctx' = add_var vmark var var_is_pure ctx in
let new_var = (find ~info:"variable that was just created" var ctx').var in
Bindlib.box_apply2
(fun new_expr new_next ->
D.ScopeLet
ScopeLet
{
scope_let_kind = kind;
scope_let_typ = translate_typ typ;
@ -485,14 +473,13 @@ let rec translate_scope_let
scope_let_next = new_next;
scope_let_pos = pos;
})
(translate_expr ctx ~append_esome:false expr)
(translate_expr ctx ~append_esome:false naked_expr)
(Bindlib.bind_var new_var (translate_scope_let ctx' next))
let translate_scope_body
(scope_pos : Pos.t)
(ctx : 'm ctx)
(body : ('m D.expr, 'm) D.scope_body) :
('m A.expr, 'm) D.scope_body Bindlib.box =
(body : 'm D.expr scope_body) : 'm A.expr scope_body Bindlib.box =
match body with
| {
scope_body_expr = result;
@ -505,23 +492,23 @@ let translate_scope_body
match lets with
| Result e | ScopeLet { scope_let_expr = e; _ } -> Marked.get_mark e
in
D.map_mark (fun _ -> scope_pos) (fun ty -> ty) m
Expr.map_mark (fun _ -> scope_pos) (fun ty -> ty) m
in
let ctx' = add_var vmark v true ctx in
let v' = (find ~info:"variable that was just created" v ctx').var in
Bindlib.box_apply
(fun new_expr ->
{
D.scope_body_expr = new_expr;
scope_body_expr = new_expr;
scope_body_input_struct = input_struct;
scope_body_output_struct = output_struct;
})
(Bindlib.bind_var v' (translate_scope_let ctx' lets))
let rec translate_scopes (ctx : 'm ctx) (scopes : ('m D.expr, 'm) D.scopes) :
('m A.expr, 'm) D.scopes Bindlib.box =
let rec translate_scopes (ctx : 'm ctx) (scopes : 'm D.expr scopes) :
'm A.expr scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box D.Nil
| Nil -> Bindlib.box Nil
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, next = Bindlib.unbind scope_next in
let vmark =
@ -534,21 +521,21 @@ let rec translate_scopes (ctx : 'm ctx) (scopes : ('m D.expr, 'm) D.scopes) :
(find ~info:"variable that was just created" scope_var new_ctx).var
in
let scope_pos = Marked.get_mark (D.ScopeName.get_info scope_name) in
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
let new_body = translate_scope_body scope_pos ctx scope_body in
let tail = translate_scopes new_ctx next in
Bindlib.box_apply2
(fun body tail ->
D.ScopeDef { scope_name; scope_body = body; scope_next = tail })
ScopeDef { scope_name; scope_body = body; scope_next = tail })
new_body
(Bindlib.bind_var new_scope_name tail)
let translate_program (prgm : 'm D.program) : 'm A.program =
let inputs_structs =
D.fold_left_scope_defs prgm.scopes ~init:[] ~f:(fun acc scope_def _ ->
scope_def.D.scope_body.scope_body_input_struct :: acc)
Scope.fold_left prgm.scopes ~init:[] ~f:(fun acc scope_def _ ->
scope_def.scope_body.scope_body_input_struct :: acc)
in
(* Cli.debug_print @@ Format.asprintf "List of structs to modify: [%a]"
@ -556,24 +543,23 @@ let translate_program (prgm : 'm D.program) : 'm A.program =
let decl_ctx =
{
prgm.decl_ctx with
D.ctx_enums =
ctx_enums =
prgm.decl_ctx.ctx_enums
|> D.EnumMap.add A.option_enum A.option_enum_config;
|> EnumMap.add A.option_enum A.option_enum_config;
}
in
let decl_ctx =
{
decl_ctx with
D.ctx_structs =
ctx_structs =
prgm.decl_ctx.ctx_structs
|> D.StructMap.mapi (fun n l ->
|> StructMap.mapi (fun n l ->
if List.mem n inputs_structs then
ListLabels.map l ~f:(fun (n, tau) ->
(* Cli.debug_print @@ Format.asprintf "Input type: %a"
(Dcalc.Print.format_typ decl_ctx) tau; Cli.debug_print
@@ Format.asprintf "Output type: %a"
(Dcalc.Print.format_typ decl_ctx) (translate_typ
tau); *)
(Print.typ decl_ctx) tau; Cli.debug_print @@
Format.asprintf "Output type: %a" (Print.typ decl_ctx)
(translate_typ tau); *)
n, translate_typ tau)
else l);
}

33
compiler/lcalc/optimizations.ml
View File

@ -14,6 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Shared_ast
open Ast
module D = Dcalc.Ast
@ -21,9 +22,9 @@ let ( let+ ) x f = Bindlib.box_apply f x
let ( and+ ) x y = Bindlib.box_pair x y
let visitor_map
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(ctx : 'a)
(e : 'm marked_expr) : 'm marked_expr Bindlib.box =
(e : 'm expr) : 'm expr Bindlib.box =
(* calls [t ctx] on every direct childs of [e], then rebuild an abstract
syntax tree modified. Used in other transformations. *)
let default_mark e' = Marked.same_mark_as e' e in
@ -67,11 +68,11 @@ let visitor_map
default_mark @@ ECatch (e1, exn, e2)
| ERaise _ | ELit _ | EOp _ -> Bindlib.box e
let rec iota_expr (_ : unit) (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let rec iota_expr (_ : unit) (e : 'm expr) : 'm expr Bindlib.box =
let default_mark e' = Marked.mark (Marked.get_mark e) e' in
match Marked.unmark e with
| EMatch ((EInj (e1, i, n', _ts), _), cases, n)
when Dcalc.Ast.EnumName.compare n n' = 0 ->
| EMatch ((EInj (e1, i, n', _ts), _), cases, n) when EnumName.compare n n' = 0
->
let+ e1 = visitor_map iota_expr () e1
and+ case = visitor_map iota_expr () (List.nth cases i) in
default_mark @@ EApp (case, [e1])
@ -80,13 +81,13 @@ let rec iota_expr (_ : unit) (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
|> List.mapi (fun i (case, _pos) ->
match case with
| EInj (_ei, i', n', _ts') ->
i = i' && (* n = n' *) Dcalc.Ast.EnumName.compare n n' = 0
i = i' && (* n = n' *) EnumName.compare n n' = 0
| _ -> false)
|> List.for_all Fun.id ->
visitor_map iota_expr () e'
| _ -> visitor_map iota_expr () e
let rec beta_expr (_ : unit) (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let rec beta_expr (_ : unit) (e : 'm expr) : 'm expr Bindlib.box =
let default_mark e' = Marked.same_mark_as e' e in
match Marked.unmark e with
| EApp (e1, args) -> (
@ -94,16 +95,15 @@ let rec beta_expr (_ : unit) (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
and+ args = List.map (beta_expr ()) args |> Bindlib.box_list in
match Marked.unmark e1 with
| EAbs (binder, _ts) ->
let (_ : (_, _) Bindlib.mbinder) = binder in
Bindlib.msubst binder (List.map fst args |> Array.of_list)
| _ -> default_mark @@ EApp (e1, args))
| _ -> visitor_map beta_expr () e
let iota_optimizations (p : 'm program) : 'm program =
let new_scopes =
Dcalc.Ast.map_exprs_in_scopes ~f:(iota_expr ()) ~varf:(fun v -> v) p.scopes
Scope.map_exprs ~f:(iota_expr ()) ~varf:(fun v -> v) p.scopes
in
{ p with D.scopes = Bindlib.unbox new_scopes }
{ p with scopes = Bindlib.unbox new_scopes }
(* TODO: beta optimizations apply inlining of the program. We left the inclusion
of beta-optimization as future work since its produce code that is harder to
@ -111,12 +111,11 @@ let iota_optimizations (p : 'm program) : 'm program =
program. *)
let _beta_optimizations (p : 'm program) : 'm program =
let new_scopes =
Dcalc.Ast.map_exprs_in_scopes ~f:(beta_expr ()) ~varf:(fun v -> v) p.scopes
Scope.map_exprs ~f:(beta_expr ()) ~varf:(fun v -> v) p.scopes
in
{ p with scopes = Bindlib.unbox new_scopes }
let rec peephole_expr (_ : unit) (e : 'm marked_expr) :
'm marked_expr Bindlib.box =
let rec peephole_expr (_ : unit) (e : 'm expr) : 'm expr Bindlib.box =
let default_mark e' = Marked.mark (Marked.get_mark e) e' in
match Marked.unmark e with
@ -145,11 +144,9 @@ let rec peephole_expr (_ : unit) (e : 'm marked_expr) :
let peephole_optimizations (p : 'm program) : 'm program =
let new_scopes =
Dcalc.Ast.map_exprs_in_scopes ~f:(peephole_expr ())
~varf:(fun v -> v)
p.scopes
Scope.map_exprs ~f:(peephole_expr ()) ~varf:(fun v -> v) p.scopes
in
{ p with scopes = Bindlib.unbox new_scopes }
let optimize_program (p : 'm program) : Dcalc.Ast.untyped program =
p |> iota_optimizations |> peephole_optimizations |> untype_program
let optimize_program (p : 'm program) : untyped program =
p |> iota_optimizations |> peephole_optimizations |> Program.untype

2
compiler/lcalc/optimizations.mli
View File

@ -16,6 +16,6 @@
open Ast
val optimize_program : 'm program -> Dcalc.Ast.untyped program
val optimize_program : 'm program -> Shared_ast.untyped program
(** Warning/todo: no effort was yet made to ensure correct propagation of type
annotations in the typed case *)

200
compiler/lcalc/print.ml
View File

@ -1,200 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
(** {b Note:} (EmileRolley) seems to be factorizable with
Dcalc.Print.format_lit. *)
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
match Marked.unmark l with
| LBool b -> Dcalc.Print.format_lit_style fmt (string_of_bool b)
| LInt i -> Dcalc.Print.format_lit_style fmt (Runtime.integer_to_string i)
| LUnit -> Dcalc.Print.format_lit_style fmt "()"
| LRat i ->
Dcalc.Print.format_lit_style fmt
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
| LMoney e -> (
match !Utils.Cli.locale_lang with
| En ->
Dcalc.Print.format_lit_style fmt
(Format.asprintf "$%s" (Runtime.money_to_string e))
| Fr ->
Dcalc.Print.format_lit_style fmt
(Format.asprintf "%s €" (Runtime.money_to_string e))
| Pl ->
Dcalc.Print.format_lit_style fmt
(Format.asprintf "%s PLN" (Runtime.money_to_string e)))
| LDate d -> Dcalc.Print.format_lit_style fmt (Runtime.date_to_string d)
| LDuration d ->
Dcalc.Print.format_lit_style fmt (Runtime.duration_to_string d)
let format_exception (fmt : Format.formatter) (exn : except) : unit =
Dcalc.Print.format_operator fmt
(match exn with
| EmptyError -> "EmptyError"
| ConflictError -> "ConflictError"
| Crash -> "Crash"
| NoValueProvided -> "NoValueProvided")
let format_keyword (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.red]) s
let format_punctuation (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.cyan]) s
let needs_parens (e : 'm marked_expr) : bool =
match Marked.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let format_var (fmt : Format.formatter) (v : 'm Ast.var) : unit =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let rec format_expr
?(debug : bool = false)
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(e : 'm marked_expr) : unit =
let format_expr = format_expr ctx ~debug in
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e
format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation ")"
| ETuple (es, Some s) ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" Dcalc.Ast.StructName.format_t s
format_punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a %a" format_punctuation "\""
Dcalc.Ast.StructFieldName.format_t struct_field format_punctuation
"\"" format_punctuation ":" format_expr e))
(List.combine es
(List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
format_punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation "]"
| ETupleAccess (e1, n, s, _ts) -> (
match s with
| None ->
Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n
| Some s ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_punctuation "."
format_punctuation "\"" Dcalc.Ast.StructFieldName.format_t
(fst (List.nth (Dcalc.Ast.StructMap.find s ctx.ctx_structs) n))
format_punctuation "\"")
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_enum_constructor
(fst (List.nth (Dcalc.Ast.EnumMap.find en ctx.ctx_enums) n))
format_expr e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]" format_keyword "match"
format_expr e format_keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (e, c) ->
Format.fprintf fmt "@[<hov 2>%a %a%a@ %a@]" format_punctuation "|"
Dcalc.Print.format_enum_constructor c format_punctuation ":"
format_expr e))
(List.combine es
(List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l ->
Format.fprintf fmt "%a" format_lit (Marked.mark (Dcalc.Ast.pos e) l)
| EApp ((EAbs (binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt ((x, tau), arg) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n"
format_keyword "let" format_var x format_punctuation ":"
(Dcalc.Print.format_typ ctx)
(Marked.unmark tau) format_punctuation "=" format_expr arg
format_keyword "in"))
(List.combine (List.combine (Array.to_list xs) taus) args)
format_expr body
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" format_punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x
format_punctuation ":"
(Dcalc.Print.format_typ ctx)
(Marked.unmark tau) format_punctuation ")"))
(List.combine (Array.to_list xs) taus)
format_punctuation "→" format_expr body
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop op
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
Dcalc.Print.format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop op
format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if"
format_expr e1 format_keyword "then" format_expr e2 format_keyword "else"
format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop op
| ECatch (e1, exn, e2) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a ->@ %a@]" format_keyword "try"
format_with_parens e1 format_keyword "with" format_exception exn
format_with_parens e2
| ERaise exn ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_keyword "raise"
format_exception exn
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" format_keyword "assert"
format_punctuation "(" format_expr e' format_punctuation ")"
let format_scope ?(debug = false) ctx fmt (n, s) =
Format.fprintf fmt "@[<hov 2>%a %a =@ %a@]" format_keyword "let"
Dcalc.Ast.ScopeName.format_t n (format_expr ctx ~debug)
(Bindlib.unbox
(Dcalc.Ast.build_whole_scope_expr ~make_abs:Ast.make_abs
~make_let_in:Ast.make_let_in ~box_expr:Ast.box_expr ctx s
(Dcalc.Ast.map_mark
(fun _ -> Marked.get_mark (Dcalc.Ast.ScopeName.get_info n))
(fun ty -> ty)
(Dcalc.Ast.get_scope_body_mark s))))

218
compiler/lcalc/to_ocaml.ml
View File

@ -15,37 +15,36 @@
the License. *)
open Utils
open Shared_ast
open Ast
open String_common
module D = Dcalc.Ast
let find_struct (s : D.StructName.t) (ctx : D.decl_ctx) :
(D.StructFieldName.t * D.typ Marked.pos) list =
try D.StructMap.find s ctx.D.ctx_structs
let find_struct (s : StructName.t) (ctx : decl_ctx) :
(StructFieldName.t * typ) list =
try StructMap.find s ctx.ctx_structs
with Not_found ->
let s_name, pos = D.StructName.get_info s in
let s_name, pos = StructName.get_info s in
Errors.raise_spanned_error pos
"Internal Error: Structure %s was not found in the current environment."
s_name
let find_enum (en : D.EnumName.t) (ctx : D.decl_ctx) :
(D.EnumConstructor.t * D.typ Marked.pos) list =
try D.EnumMap.find en ctx.D.ctx_enums
let find_enum (en : EnumName.t) (ctx : decl_ctx) :
(EnumConstructor.t * typ) list =
try EnumMap.find en ctx.ctx_enums
with Not_found ->
let en_name, pos = D.EnumName.get_info en in
let en_name, pos = EnumName.get_info en in
Errors.raise_spanned_error pos
"Internal Error: Enumeration %s was not found in the current environment."
en_name
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
match Marked.unmark l with
| LBool b -> Dcalc.Print.format_lit fmt (Dcalc.Ast.LBool b)
| LBool b -> Print.lit fmt (LBool b)
| LInt i ->
Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i)
| LUnit -> Dcalc.Print.format_lit fmt Dcalc.Ast.LUnit
| LRat i ->
Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit
(Dcalc.Ast.LRat i)
| LUnit -> Print.lit fmt LUnit
| LRat i -> Format.fprintf fmt "decimal_of_string \"%a\"" Print.lit (LRat i)
| LMoney e ->
Format.fprintf fmt "money_of_cents_string@ \"%s\""
(Runtime.integer_to_string (Runtime.money_to_cents e))
@ -58,7 +57,7 @@ let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days
let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> "!"
@ -67,8 +66,7 @@ let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Marked.pos) :
unit =
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
match Marked.unmark op with
| Add k -> Format.fprintf fmt "+%a" format_op_kind k
| Sub k -> Format.fprintf fmt "-%a" format_op_kind k
@ -86,8 +84,7 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Marked.pos) :
| Map -> Format.fprintf fmt "Array.map"
| Filter -> Format.fprintf fmt "array_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Marked.pos) :
unit =
let format_ternop (fmt : Format.formatter) (op : ternop Marked.pos) : unit =
match Marked.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
@ -109,8 +106,7 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Marked.pos) : unit
=
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
match Marked.unmark op with
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
| Not -> Format.fprintf fmt "%s" "not"
@ -145,9 +141,8 @@ let avoid_keywords (s : string) : string =
s ^ "_user"
| _ -> s
let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
unit =
Format.asprintf "%a" Dcalc.Ast.StructName.format_t v
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
Format.asprintf "%a" StructName.format_t v
|> to_ascii
|> to_snake_case
|> avoid_keywords
@ -155,10 +150,10 @@ let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
let format_to_module_name
(fmt : Format.formatter)
(name : [< `Ename of D.EnumName.t | `Sname of D.StructName.t ]) =
(name : [< `Ename of EnumName.t | `Sname of StructName.t ]) =
(match name with
| `Ename v -> Format.asprintf "%a" D.EnumName.format_t v
| `Sname v -> Format.asprintf "%a" D.StructName.format_t v)
| `Ename v -> Format.asprintf "%a" EnumName.format_t v
| `Sname v -> Format.asprintf "%a" StructName.format_t v)
|> to_ascii
|> to_snake_case
|> avoid_keywords
@ -169,81 +164,67 @@ let format_to_module_name
let format_struct_field_name
(fmt : Format.formatter)
((sname_opt, v) :
Dcalc.Ast.StructName.t option * Dcalc.Ast.StructFieldName.t) : unit =
((sname_opt, v) : StructName.t option * StructFieldName.t) : unit =
(match sname_opt with
| Some sname ->
Format.fprintf fmt "%a.%s" format_to_module_name (`Sname sname)
| None -> Format.fprintf fmt "%s")
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))
(to_ascii (Format.asprintf "%a" StructFieldName.format_t v)))
let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit
=
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_snake_case
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
(to_snake_case (to_ascii (Format.asprintf "%a" EnumName.format_t v))))
let format_enum_cons_name
(fmt : Format.formatter)
(v : Dcalc.Ast.EnumConstructor.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Marked.pos) :
let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
let rec typ_embedding_name (fmt : Format.formatter) (ty : typ) : unit =
match Marked.unmark ty with
| D.TLit D.TUnit -> Format.fprintf fmt "embed_unit"
| D.TLit D.TBool -> Format.fprintf fmt "embed_bool"
| D.TLit D.TInt -> Format.fprintf fmt "embed_integer"
| D.TLit D.TRat -> Format.fprintf fmt "embed_decimal"
| D.TLit D.TMoney -> Format.fprintf fmt "embed_money"
| D.TLit D.TDate -> Format.fprintf fmt "embed_date"
| D.TLit D.TDuration -> Format.fprintf fmt "embed_duration"
| D.TTuple (_, Some s_name) ->
Format.fprintf fmt "embed_%a" format_struct_name s_name
| D.TEnum (_, e_name) -> Format.fprintf fmt "embed_%a" format_enum_name e_name
| D.TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
| TLit TUnit -> Format.fprintf fmt "embed_unit"
| TLit TBool -> Format.fprintf fmt "embed_bool"
| TLit TInt -> Format.fprintf fmt "embed_integer"
| TLit TRat -> Format.fprintf fmt "embed_decimal"
| TLit TMoney -> Format.fprintf fmt "embed_money"
| TLit TDate -> Format.fprintf fmt "embed_date"
| TLit TDuration -> Format.fprintf fmt "embed_duration"
| TStruct s_name -> Format.fprintf fmt "embed_%a" format_struct_name s_name
| TEnum e_name -> Format.fprintf fmt "embed_%a" format_enum_name e_name
| TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
| _ -> Format.fprintf fmt "unembeddable"
let typ_needs_parens (e : Dcalc.Ast.typ Marked.pos) : bool =
let typ_needs_parens (e : typ) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
unit =
let format_typ_with_parens
(fmt : Format.formatter)
(t : Dcalc.Ast.typ Marked.pos) =
let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
let format_typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
| TLit l -> Format.fprintf fmt "%a" Dcalc.Print.format_tlit l
| TTuple (ts, None) ->
| TLit l -> Format.fprintf fmt "%a" Print.tlit l
| TTuple ts ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
format_typ_with_parens)
ts
| TTuple (_, Some s) ->
Format.fprintf fmt "%a.t" format_to_module_name (`Sname s)
| TEnum ([t], e) when D.EnumName.compare e Ast.option_enum = 0 ->
| TStruct s -> Format.fprintf fmt "%a.t" format_to_module_name (`Sname s)
| TOption t ->
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
format_enum_name e
| TEnum (_, e) when D.EnumName.compare e Ast.option_enum = 0 ->
Errors.raise_spanned_error (Marked.get_mark typ)
"Internal Error: found an typing parameter for an eoption type of the \
wrong length."
| TEnum (_ts, e) -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
format_enum_name Ast.option_enum
| TEnum e -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a ->@ %a@]" format_typ_with_parens t1
format_typ_with_parens t2
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "_"
let format_var (fmt : Format.formatter) (v : 'm var) : unit =
let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit =
let lowercase_name = to_snake_case (to_ascii (Bindlib.name_of v)) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
@ -260,7 +241,7 @@ let format_var (fmt : Format.formatter) (v : 'm var) : unit =
Cli.debug_print "lowercase_name: %s " lowercase_name;
Format.fprintf fmt "%s_" lowercase_name)
let needs_parens (e : 'm marked_expr) : bool =
let needs_parens (e : 'm expr) : bool =
match Marked.unmark e with
| EApp ((EAbs (_, _), _), _)
| ELit (LBool _ | LUnit)
@ -289,12 +270,10 @@ let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
let rec format_expr
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(e : 'm marked_expr) : unit =
let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
unit =
let format_expr = format_expr ctx in
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
let format_with_parens (fmt : Format.formatter) (e : 'm expr) =
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
else Format.fprintf fmt "%a" format_expr e
in
@ -360,7 +339,7 @@ let rec format_expr
(* should not happen *))
e))
(List.combine es (List.map fst (find_enum e_name ctx)))
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (D.pos e) l)
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (Expr.pos e) l)
| EApp ((EAbs (binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
@ -381,36 +360,33 @@ let rec format_expr
(fun fmt (x, tau) ->
Format.fprintf fmt "@[<hov 2>(%a:@ %a)@]" format_var x format_typ tau))
xs_tau format_expr body
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos)
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
format_binop (op, Pos.no_pos) format_with_parens arg2
| EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [f]), _), [arg])
| EApp ((EApp ((EOp (Unop (Log (BeginCall, info))), _), [f]), _), [arg])
when !Cli.trace_flag ->
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
format_with_parens f format_with_parens arg
| EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [arg1])
when !Cli.trace_flag ->
| EApp ((EOp (Unop (Log (VarDef tau, info))), _), [arg1]) when !Cli.trace_flag
->
Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list
info typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), m), [arg1])
| EApp ((EOp (Unop (Log (PosRecordIfTrueBool, _))), m), [arg1])
when !Cli.trace_flag ->
let pos = D.mark_pos m in
let pos = Expr.mark_pos m in
Format.fprintf fmt
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a)"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) format_with_parens arg1
| EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [arg1])
when !Cli.trace_flag ->
| EApp ((EOp (Unop (Log (EndCall, info))), _), [arg1]) when !Cli.trace_flag ->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
format_with_parens arg1
| EApp ((EOp (Unop (D.Log _)), _), [arg1]) ->
| EApp ((EOp (Unop (Log _)), _), [arg1]) ->
Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos)
@ -422,13 +398,13 @@ let rec format_expr
"@[<hov 2>%a@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a@]"
format_var x
(Pos.get_file (D.mark_pos pos))
(Pos.get_start_line (D.mark_pos pos))
(Pos.get_start_column (D.mark_pos pos))
(Pos.get_end_line (D.mark_pos pos))
(Pos.get_end_column (D.mark_pos pos))
(Pos.get_file (Expr.mark_pos pos))
(Pos.get_start_line (Expr.mark_pos pos))
(Pos.get_start_column (Expr.mark_pos pos))
(Pos.get_end_line (Expr.mark_pos pos))
(Pos.get_end_column (Expr.mark_pos pos))
format_string_list
(Pos.get_law_info (D.mark_pos pos))
(Pos.get_law_info (Expr.mark_pos pos))
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
@ -452,25 +428,26 @@ let rec format_expr
2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ end_line=%d; \
end_column=%d;@ law_headings=%a}@])@]"
format_with_parens e'
(Pos.get_file (D.pos e'))
(Pos.get_start_line (D.pos e'))
(Pos.get_start_column (D.pos e'))
(Pos.get_end_line (D.pos e'))
(Pos.get_end_column (D.pos e'))
(Pos.get_file (Expr.pos e'))
(Pos.get_start_line (Expr.pos e'))
(Pos.get_start_column (Expr.pos e'))
(Pos.get_end_line (Expr.pos e'))
(Pos.get_end_column (Expr.pos e'))
format_string_list
(Pos.get_law_info (D.pos e'))
| ERaise exc -> Format.fprintf fmt "raise@ %a" format_exception (exc, D.pos e)
(Pos.get_law_info (Expr.pos e'))
| ERaise exc ->
Format.fprintf fmt "raise@ %a" format_exception (exc, Expr.pos e)
| ECatch (e1, exc, e2) ->
Format.fprintf fmt
"@,@[<hv>@[<hov 2>try@ %a@]@ with@]@ @[<hov 2>%a@ ->@ %a@]"
format_with_parens e1 format_exception
(exc, D.pos e)
(exc, Expr.pos e)
format_with_parens e2
let format_struct_embedding
(fmt : Format.formatter)
((struct_name, struct_fields) :
D.StructName.t * (D.StructFieldName.t * D.typ Marked.pos) list) =
StructName.t * (StructFieldName.t * typ) list) =
if List.length struct_fields = 0 then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_struct_name struct_name format_to_module_name (`Sname struct_name)
@ -480,11 +457,11 @@ let format_struct_embedding
@[<hov 2>[%a]@])@]@\n\
@\n"
format_struct_name struct_name format_to_module_name (`Sname struct_name)
D.StructName.format_t struct_name
StructName.format_t struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" D.StructFieldName.format_t
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructFieldName.format_t
struct_field typ_embedding_name struct_field_type
format_struct_field_name
(Some struct_name, struct_field)))
@ -492,8 +469,7 @@ let format_struct_embedding
let format_enum_embedding
(fmt : Format.formatter)
((enum_name, enum_cases) :
D.EnumName.t * (D.EnumConstructor.t * D.typ Marked.pos) list) =
((enum_name, enum_cases) : EnumName.t * (EnumConstructor.t * typ) list) =
if List.length enum_cases = 0 then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_to_module_name (`Ename enum_name) format_enum_name enum_name
@ -503,19 +479,19 @@ let format_enum_embedding
=@]@ Enum([\"%a\"],@ @[<hov 2>match x with@ %a@])@]@\n\
@\n"
format_enum_name enum_name format_to_module_name (`Ename enum_name)
D.EnumName.format_t enum_name
EnumName.format_t enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]"
format_enum_cons_name enum_cons D.EnumConstructor.format_t
enum_cons typ_embedding_name enum_cons_type))
format_enum_cons_name enum_cons EnumConstructor.format_t enum_cons
typ_embedding_name enum_cons_type))
enum_cases
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
(fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
(ctx : decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
if List.length struct_fields = 0 then
Format.fprintf fmt
@ -559,8 +535,8 @@ let format_ctx
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(Dcalc.Ast.StructMap.bindings
(Dcalc.Ast.StructMap.filter
(StructMap.bindings
(StructMap.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in
@ -574,12 +550,12 @@ let format_ctx
(type_ordering @ scope_structs)
let rec format_scope_body_expr
(ctx : Dcalc.Ast.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(scope_lets : ('m Ast.expr, 'm) Dcalc.Ast.scope_body_expr) : unit =
(scope_lets : 'm Ast.expr scope_body_expr) : unit =
match scope_lets with
| Dcalc.Ast.Result e -> format_expr ctx fmt e
| Dcalc.Ast.ScopeLet scope_let ->
| Result e -> format_expr ctx fmt e
| ScopeLet scope_let ->
let scope_let_var, scope_let_next =
Bindlib.unbind scope_let.scope_let_next
in
@ -590,12 +566,12 @@ let rec format_scope_body_expr
scope_let_next
let rec format_scopes
(ctx : Dcalc.Ast.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(scopes : ('m Ast.expr, 'm) Dcalc.Ast.scopes) : unit =
(scopes : 'm Ast.expr scopes) : unit =
match scopes with
| Dcalc.Ast.Nil -> ()
| Dcalc.Ast.ScopeDef scope_def ->
| Nil -> ()
| ScopeDef scope_def ->
let scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in

37
compiler/lcalc/to_ocaml.mli
View File

@ -15,44 +15,29 @@
the License. *)
open Utils
open Shared_ast
open Ast
(** Formats a lambda calculus program into a valid OCaml program *)
val avoid_keywords : string -> string
val find_struct :
Dcalc.Ast.StructName.t ->
Dcalc.Ast.decl_ctx ->
(Dcalc.Ast.StructFieldName.t * Dcalc.Ast.typ Marked.pos) list
val find_enum :
Dcalc.Ast.EnumName.t ->
Dcalc.Ast.decl_ctx ->
(Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Marked.pos) list
val typ_needs_parens : Dcalc.Ast.typ Marked.pos -> bool
val needs_parens : 'm marked_expr -> bool
val format_enum_name : Format.formatter -> Dcalc.Ast.EnumName.t -> unit
val format_enum_cons_name :
Format.formatter -> Dcalc.Ast.EnumConstructor.t -> unit
val format_struct_name : Format.formatter -> Dcalc.Ast.StructName.t -> unit
val find_struct : StructName.t -> decl_ctx -> (StructFieldName.t * typ) list
val find_enum : EnumName.t -> decl_ctx -> (EnumConstructor.t * typ) list
val typ_needs_parens : typ -> bool
val needs_parens : 'm expr -> bool
val format_enum_name : Format.formatter -> EnumName.t -> unit
val format_enum_cons_name : Format.formatter -> EnumConstructor.t -> unit
val format_struct_name : Format.formatter -> StructName.t -> unit
val format_struct_field_name :
Format.formatter ->
Dcalc.Ast.StructName.t option * Dcalc.Ast.StructFieldName.t ->
unit
Format.formatter -> StructName.t option * StructFieldName.t -> unit
val format_to_module_name :
Format.formatter ->
[< `Ename of Dcalc.Ast.EnumName.t | `Sname of Dcalc.Ast.StructName.t ] ->
unit
Format.formatter -> [< `Ename of EnumName.t | `Sname of StructName.t ] -> unit
val format_lit : Format.formatter -> lit Marked.pos -> unit
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_var : Format.formatter -> 'm var -> unit
val format_var : Format.formatter -> 'm Var.t -> unit
val format_program :
Format.formatter ->

4
compiler/literate/html.ml
View File

@ -174,6 +174,10 @@ let rec law_structure_to_html
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<div class='law-text'>%s</div>" t
| A.CodeBlock (_, c, metadata) when not print_only_law ->
let start_line = Pos.get_start_line (Marked.get_mark c) - 1 in
let filename = Filename.basename (Pos.get_file (Marked.get_mark c)) in
let block_content = Marked.unmark c in
check_exceeding_lines start_line filename block_content;
Format.fprintf fmt
"<div class='code-wrapper%s'>\n<div class='filename'>%s</div>\n%s\n</div>"
(if metadata then " code-metadata" else "")

47
compiler/literate/latex.ml
View File

@ -26,6 +26,15 @@ module C = Cli
(** {1 Helpers} *)
let lines_of_code = ref 0
let update_lines_of_code c =
lines_of_code :=
!lines_of_code
+ Pos.get_end_line (Marked.get_mark c)
- Pos.get_start_line (Marked.get_mark c)
- 1
(** Espaces various LaTeX-sensitive characters *)
let pre_latexify (s : string) : string =
(* Then we send to pandoc, to ensure the markdown features used in the
@ -175,34 +184,6 @@ codes={\catcode`\$=3\catcode`\^=7}
(** {1 Weaving} *)
(** [check_exceeding_lines max_len start_line filename content] prints a warning
message for each lines of [content] exceeding [max_len] characters. *)
let check_exceeding_lines
?(max_len = 80)
(start_line : int)
(filename : string)
(content : string) =
content
|> String.split_on_char '\n'
|> List.iteri (fun i s ->
if
String.length (Ubase.from_utf8 s)
(* we remove diacritics to avoid false positives due to UFT8 encoding
not taken into account by String *) > max_len
then (
Cli.warning_print "The line %s in %s is exceeding %s characters:"
(Cli.with_style
ANSITerminal.[Bold; yellow]
"%d"
(start_line + i + 1))
(Cli.with_style ANSITerminal.[Bold; magenta] "%s" filename)
(Cli.with_style ANSITerminal.[Bold; red] "%d" max_len);
Cli.warning_print "%s%s" (String.sub s 0 max_len)
(Cli.with_style
ANSITerminal.[red]
"%s"
String.(sub s max_len (length s - max_len)))))
let rec law_structure_to_latex
(language : C.backend_lang)
(print_only_law : bool)
@ -241,6 +222,11 @@ let rec law_structure_to_latex
| A.LawInclude (A.CatalaFile _ | A.LegislativeText _) -> ()
| A.LawText t -> Format.fprintf fmt "%s" (pre_latexify t)
| A.CodeBlock (_, c, false) when not print_only_law ->
let start_line = Pos.get_start_line (Marked.get_mark c) - 1 in
let filename = Filename.basename (Pos.get_file (Marked.get_mark c)) in
let block_content = Marked.unmark c in
check_exceeding_lines start_line filename block_content;
update_lines_of_code c;
Format.fprintf fmt
"\\begin{minted}[label={\\hspace*{\\fill}\\texttt{%s}},firstnumber=%d]{%s}\n\
```catala\n\
@ -261,6 +247,7 @@ let rec law_structure_to_latex
let filename = Filename.basename (Pos.get_file (Marked.get_mark c)) in
let block_content = Marked.unmark c in
check_exceeding_lines start_line filename block_content;
update_lines_of_code c;
Format.fprintf fmt
"\\begin{tcolorbox}[colframe=OliveGreen, breakable, \
title=\\textcolor{black}{\\texttt{%s}},title after \
@ -286,4 +273,6 @@ let ast_to_latex
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language print_only_law)
fmt program.program_items
fmt program.program_items;
Cli.debug_print "Lines of Catala inside literate source code: %d"
!lines_of_code

25
compiler/literate/literate_common.ml
View File

@ -99,3 +99,28 @@ let run_pandoc (s : string) (backend : [ `Html | `Latex ]) : string =
Sys.remove tmp_file_in;
Sys.remove tmp_file_out;
tmp_file_as_string
let check_exceeding_lines
?(max_len = 80)
(start_line : int)
(filename : string)
(content : string) =
content
|> String.split_on_char '\n'
|> List.iteri (fun i s ->
let len_s =
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
in
if len_s > max_len then (
Cli.warning_print "The line %s in %s is exceeding %s characters:"
(Cli.with_style
ANSITerminal.[Bold; yellow]
"%d"
(start_line + i + 1))
(Cli.with_style ANSITerminal.[Bold; magenta] "%s" filename)
(Cli.with_style ANSITerminal.[Bold; red] "%d" max_len);
Cli.warning_print "%s%s" (String.sub s 0 max_len)
(Cli.with_style
ANSITerminal.[red]
"%s"
String.(sub s max_len (len_s - max_len)))))

4
compiler/literate/literate_common.mli
View File

@ -44,3 +44,7 @@ val get_language_extension : Cli.backend_lang -> string
val run_pandoc : string -> [ `Html | `Latex ] -> string
(** Runs the [pandoc] on a string to pretty-print markdown features into the
desired format. *)
val check_exceeding_lines : ?max_len:int -> int -> string -> string -> unit
(** [check_exceeding_lines ~max_len start_line filename content] prints a
warning message for each lines of [content] exceeding [max_len] characters. *)

2
compiler/plugin.ml
View File

@ -29,7 +29,7 @@ type 'ast gen = {
}
type t =
| Lcalc of Dcalc.Ast.untyped Lcalc.Ast.program gen
| Lcalc of Shared_ast.untyped Lcalc.Ast.program gen
| Scalc of Scalc.Ast.program gen
let name = function Lcalc { name; _ } | Scalc { name; _ } -> name

4
compiler/plugin.mli
View File

@ -31,7 +31,7 @@ type 'ast gen = {
}
type t =
| Lcalc of Dcalc.Ast.untyped Lcalc.Ast.program gen
| Lcalc of Shared_ast.untyped Lcalc.Ast.program gen
| Scalc of Scalc.Ast.program gen
val find : string -> t
@ -49,7 +49,7 @@ module PluginAPI : sig
val register_lcalc :
name:string ->
extension:string ->
Dcalc.Ast.untyped Lcalc.Ast.program plugin_apply_fun_typ ->
Shared_ast.untyped Lcalc.Ast.program plugin_apply_fun_typ ->
unit
val register_scalc :

121
compiler/plugins/api_web.ml
View File

@ -19,6 +19,7 @@
the associated [js_of_ocaml] wrapper. *)
open Utils
open Shared_ast
open String_common
open Lcalc
open Lcalc.Ast
@ -39,9 +40,9 @@ module To_jsoo = struct
let format_struct_field_name_camel_case
(fmt : Format.formatter)
(v : Dcalc.Ast.StructFieldName.t) : unit =
(v : StructFieldName.t) : unit =
let s =
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
Format.asprintf "%a" StructFieldName.format_t v
|> to_ascii
|> to_snake_case
|> avoid_keywords
@ -49,8 +50,8 @@ module To_jsoo = struct
in
Format.fprintf fmt "%s" s
let format_tlit (fmt : Format.formatter) (l : Dcalc.Ast.typ_lit) : unit =
Dcalc.Print.format_base_type fmt
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
Print.base_type fmt
(match l with
| TUnit -> "unit"
| TInt -> "int"
@ -59,28 +60,21 @@ module To_jsoo = struct
| TBool -> "bool Js.t"
| TDate -> "Js.js_string Js.t")
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
unit =
let format_typ_with_parens
(fmt : Format.formatter)
(t : Dcalc.Ast.typ Marked.pos) =
let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
let format_typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TTuple (_, Some s) -> Format.fprintf fmt "%a Js.t" format_struct_name s
| TTuple (_, None) ->
| TStruct s -> Format.fprintf fmt "%a Js.t" format_struct_name s
| TTuple _ ->
(* Tuples are encoded as an javascript polymorphic array. *)
Format.fprintf fmt "Js.Unsafe.any_js_array Js.t "
| TEnum ([t], e) when D.EnumName.compare e option_enum = 0 ->
| TOption t ->
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
format_enum_name e
| TEnum (_, e) when D.EnumName.compare e option_enum = 0 ->
Errors.raise_spanned_error (Marked.get_mark typ)
"Internal Error: found an typing parameter for an eoption type of the \
wrong length."
| TEnum (_, e) -> Format.fprintf fmt "%a Js.t" format_enum_name e
format_enum_name Lcalc.Ast.option_enum
| TEnum e -> Format.fprintf fmt "%a Js.t" format_enum_name e
| TArray t1 ->
Format.fprintf fmt "@[%a@ Js.js_array Js.t@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "Js.Unsafe.any Js.t"
@ -90,46 +84,38 @@ module To_jsoo = struct
let rec format_typ_to_jsoo fmt typ =
match Marked.unmark typ with
| Dcalc.Ast.TLit TBool -> Format.fprintf fmt "Js.bool"
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_to_int"
| Dcalc.Ast.TLit TRat ->
Format.fprintf fmt "Js.number_of_float %@%@ decimal_to_float"
| Dcalc.Ast.TLit TMoney ->
Format.fprintf fmt "Js.number_of_float %@%@ money_to_float"
| Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_to_jsoo"
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_to_jsoo"
| Dcalc.Ast.TEnum (_, ename) ->
Format.fprintf fmt "%a_to_jsoo" format_enum_name ename
| Dcalc.Ast.TTuple (_, Some sname) ->
Format.fprintf fmt "%a_to_jsoo" format_struct_name sname
| Dcalc.Ast.TArray t ->
| TLit TBool -> Format.fprintf fmt "Js.bool"
| TLit TInt -> Format.fprintf fmt "integer_to_int"
| TLit TRat -> Format.fprintf fmt "Js.number_of_float %@%@ decimal_to_float"
| TLit TMoney -> Format.fprintf fmt "Js.number_of_float %@%@ money_to_float"
| TLit TDuration -> Format.fprintf fmt "duration_to_jsoo"
| TLit TDate -> Format.fprintf fmt "date_to_jsoo"
| TEnum ename -> Format.fprintf fmt "%a_to_jsoo" format_enum_name ename
| TStruct sname -> Format.fprintf fmt "%a_to_jsoo" format_struct_name sname
| TArray t ->
Format.fprintf fmt "Js.array %@%@ Array.map (fun x -> %a x)"
format_typ_to_jsoo t
| Dcalc.Ast.TAny | Dcalc.Ast.TTuple (_, None) ->
Format.fprintf fmt "Js.Unsafe.inject"
| TAny | TTuple _ -> Format.fprintf fmt "Js.Unsafe.inject"
| _ -> Format.fprintf fmt ""
let rec format_typ_of_jsoo fmt typ =
match Marked.unmark typ with
| Dcalc.Ast.TLit TBool -> Format.fprintf fmt "Js.to_bool"
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_of_int"
| Dcalc.Ast.TLit TRat ->
Format.fprintf fmt "decimal_of_float %@%@ Js.float_of_number"
| Dcalc.Ast.TLit TMoney ->
| TLit TBool -> Format.fprintf fmt "Js.to_bool"
| TLit TInt -> Format.fprintf fmt "integer_of_int"
| TLit TRat -> Format.fprintf fmt "decimal_of_float %@%@ Js.float_of_number"
| TLit TMoney ->
Format.fprintf fmt
"money_of_decimal %@%@ decimal_of_float %@%@ Js.float_of_number"
| Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_of_jsoo"
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_of_jsoo"
| Dcalc.Ast.TEnum (_, ename) ->
Format.fprintf fmt "%a_of_jsoo" format_enum_name ename
| Dcalc.Ast.TTuple (_, Some sname) ->
Format.fprintf fmt "%a_of_jsoo" format_struct_name sname
| Dcalc.Ast.TArray t ->
| TLit TDuration -> Format.fprintf fmt "duration_of_jsoo"
| TLit TDate -> Format.fprintf fmt "date_of_jsoo"
| TEnum ename -> Format.fprintf fmt "%a_of_jsoo" format_enum_name ename
| TStruct sname -> Format.fprintf fmt "%a_of_jsoo" format_struct_name sname
| TArray t ->
Format.fprintf fmt "Array.map (fun x -> %a x) %@%@ Js.to_array"
format_typ_of_jsoo t
| _ -> Format.fprintf fmt ""
let format_var_camel_case (fmt : Format.formatter) (v : 'm var) : unit =
let format_var_camel_case (fmt : Format.formatter) (v : 'm Var.t) : unit =
let lowercase_name =
Bindlib.name_of v
|> to_ascii
@ -150,10 +136,10 @@ module To_jsoo = struct
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
(fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
let format_prop_or_meth fmt (struct_field_type : D.typ Marked.pos) =
(ctx : decl_ctx) : unit =
let format_prop_or_meth fmt (struct_field_type : typ) =
match Marked.unmark struct_field_type with
| Dcalc.Ast.TArrow _ -> Format.fprintf fmt "Js.meth"
| TArrow _ -> Format.fprintf fmt "Js.meth"
| _ -> Format.fprintf fmt "Js.readonly_prop"
in
let format_struct_decl fmt (struct_name, struct_fields) =
@ -167,7 +153,7 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
| Dcalc.Ast.TArrow (t1, t2) ->
| TArrow (t1, t2) ->
Format.fprintf fmt
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
fun input ->@ %a (%a.%a (%a input)))@]@]"
@ -188,7 +174,7 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
| Dcalc.Ast.TArrow _ ->
| TArrow _ ->
Format.fprintf fmt
"%a = failwith \"The function '%a' translation isn't yet \
supported...\""
@ -238,8 +224,7 @@ module To_jsoo = struct
in
let format_enum_decl
fmt
(enum_name, (enum_cons : (D.EnumConstructor.t * D.typ Marked.pos) list))
=
(enum_name, (enum_cons : (EnumConstructor.t * typ) list)) =
let fmt_enum_name fmt _ = format_enum_name fmt enum_name in
let fmt_module_enum_name fmt _ =
To_ocaml.format_to_module_name fmt (`Ename enum_name)
@ -250,7 +235,7 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cname, typ) ->
match Marked.unmark typ with
| Dcalc.Ast.TTuple (_, None) ->
| TTuple _ ->
Cli.error_print
"Tuples aren't supported yet in the conversion to JS"
| _ ->
@ -275,10 +260,10 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cname, typ) ->
match Marked.unmark typ with
| Dcalc.Ast.TTuple (_, None) ->
| TTuple _ ->
Cli.error_print
"Tuples aren't yet supported in the conversion to JS..."
| Dcalc.Ast.TLit TUnit ->
| TLit TUnit ->
Format.fprintf fmt "@[<hv 2>| \"%a\" ->@ %a.%a ()@]"
format_enum_cons_name cname fmt_module_enum_name ()
format_enum_cons_name cname
@ -329,8 +314,8 @@ module To_jsoo = struct
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(Dcalc.Ast.StructMap.bindings
(Dcalc.Ast.StructMap.filter
(StructMap.bindings
(StructMap.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in
@ -343,19 +328,19 @@ module To_jsoo = struct
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
(type_ordering @ scope_structs)
let fmt_input_struct_name fmt (scope_def : ('a expr, 'm) D.scope_def) =
let fmt_input_struct_name fmt (scope_def : 'a expr scope_def) =
format_struct_name fmt scope_def.scope_body.scope_body_input_struct
let fmt_output_struct_name fmt (scope_def : ('a expr, 'm) D.scope_def) =
let fmt_output_struct_name fmt (scope_def : 'a expr scope_def) =
format_struct_name fmt scope_def.scope_body.scope_body_output_struct
let rec format_scopes_to_fun
(ctx : Dcalc.Ast.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(scopes : ('expr, 'm) Dcalc.Ast.scopes) =
(scopes : 'e scopes) =
match scopes with
| Dcalc.Ast.Nil -> ()
| Dcalc.Ast.ScopeDef scope_def ->
| Nil -> ()
| ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let fmt_fun_call fmt _ =
Format.fprintf fmt "@[<hv>%a@ |> %a_of_jsoo@ |> %a@ |> %a_to_jsoo@]"
@ -369,12 +354,12 @@ module To_jsoo = struct
fmt_fun_call () (format_scopes_to_fun ctx) scope_next
let rec format_scopes_to_callbacks
(ctx : Dcalc.Ast.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(scopes : ('expr, 'm) Dcalc.Ast.scopes) : unit =
(scopes : 'e scopes) : unit =
match scopes with
| Dcalc.Ast.Nil -> ()
| Dcalc.Ast.ScopeDef scope_def ->
| Nil -> ()
| ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let fmt_meth_name fmt _ =
Format.fprintf fmt "method %a : (%a Js.t -> %a Js.t) Js.callback"

57
compiler/plugins/json_schema.ml
View File

@ -22,6 +22,7 @@ let extension = "_schema.json"
open Utils
open String_common
open Shared_ast
open Lcalc.Ast
open Lcalc.To_ocaml
module D = Dcalc.Ast
@ -37,9 +38,9 @@ module To_json = struct
let format_struct_field_name_camel_case
(fmt : Format.formatter)
(v : Dcalc.Ast.StructFieldName.t) : unit =
(v : StructFieldName.t) : unit =
let s =
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
Format.asprintf "%a" StructFieldName.format_t v
|> to_ascii
|> to_snake_case
|> avoid_keywords
@ -48,18 +49,16 @@ module To_json = struct
Format.fprintf fmt "%s" s
let rec find_scope_def (target_name : string) :
('m expr, 'm) D.scopes -> ('m expr, 'm) D.scope_def option = function
| D.Nil -> None
| D.ScopeDef scope_def ->
let name =
Format.asprintf "%a" D.ScopeName.format_t scope_def.scope_name
in
'm expr scopes -> 'm expr scope_def option = function
| Nil -> None
| ScopeDef scope_def ->
let name = Format.asprintf "%a" ScopeName.format_t scope_def.scope_name in
if name = target_name then Some scope_def
else
let _, next_scope = Bindlib.unbind scope_def.scope_next in
find_scope_def target_name next_scope
let fmt_tlit fmt (tlit : D.typ_lit) =
let fmt_tlit fmt (tlit : typ_lit) =
match tlit with
| TUnit -> Format.fprintf fmt "\"type\": \"null\",@\n\"default\": null"
| TInt | TRat -> Format.fprintf fmt "\"type\": \"number\",@\n\"default\": 0"
@ -70,15 +69,15 @@ module To_json = struct
| TDate -> Format.fprintf fmt "\"type\": \"string\",@\n\"format\": \"date\""
| TDuration -> failwith "TODO: tlit duration"
let rec fmt_type fmt (typ : D.marked_typ) =
let rec fmt_type fmt (typ : typ) =
match Marked.unmark typ with
| D.TLit tlit -> fmt_tlit fmt tlit
| D.TTuple (_, Some sname) ->
| TLit tlit -> fmt_tlit fmt tlit
| TStruct sname ->
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_struct_name
sname
| D.TEnum (_, ename) ->
| TEnum ename ->
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_enum_name ename
| D.TArray t ->
| TArray t ->
Format.fprintf fmt
"\"type\": \"array\",@\n\
\"default\": [],@\n\
@ -89,9 +88,9 @@ module To_json = struct
| _ -> ()
let fmt_struct_properties
(ctx : D.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(sname : D.StructName.t) =
(sname : StructName.t) =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
@ -101,26 +100,26 @@ module To_json = struct
(find_struct sname ctx)
let fmt_definitions
(ctx : D.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(scope_def : ('m expr, 'm) D.scope_def) =
(scope_def : 'e scope_def) =
let get_name t =
match Marked.unmark t with
| D.TTuple (_, Some sname) ->
Format.asprintf "%a" format_struct_name sname
| D.TEnum (_, ename) -> Format.asprintf "%a" format_enum_name ename
| TStruct sname -> Format.asprintf "%a" format_struct_name sname
| TEnum ename -> Format.asprintf "%a" format_enum_name ename
| _ -> failwith "unreachable: only structs and enums are collected."
in
let rec collect_required_type_defs_from_scope_input
(input_struct : D.StructName.t) : D.marked_typ list =
let rec collect (acc : D.marked_typ list) (t : D.marked_typ) :
D.marked_typ list =
(input_struct : StructName.t) : typ list =
let rec collect (acc : typ list) (t : typ) : typ list =
match Marked.unmark t with
| D.TTuple (_, Some s) ->
| TStruct s ->
(* Scope's input is a struct. *)
(t :: acc) @ collect_required_type_defs_from_scope_input s
| D.TEnum (ts, _) -> List.fold_left collect (t :: acc) ts
| D.TArray t -> collect acc t
| TEnum e ->
List.fold_left collect (t :: acc)
(List.map snd (EnumMap.find e ctx.ctx_enums))
| TArray t -> collect acc t
| _ -> acc
in
find_struct input_struct ctx
@ -177,7 +176,7 @@ module To_json = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt typ ->
match Marked.unmark typ with
| D.TTuple (_, Some sname) ->
| TStruct sname ->
Format.fprintf fmt
"@[<hov 2>\"%a\": {@\n\
\"type\": \"object\",@\n\
@ -188,7 +187,7 @@ module To_json = struct
format_struct_name sname
(fmt_struct_properties ctx)
sname
| D.TEnum (_, ename) ->
| TEnum ename ->
Format.fprintf fmt
"@[<hov 2>\"%a\": {@\n\
\"type\": \"object\",@\n\

41
compiler/scalc/ast.ml
View File

@ -15,6 +15,7 @@
the License. *)
open Utils
open Shared_ast
module D = Dcalc.Ast
module L = Lcalc.Ast
module TopLevelName = Uid.Make (Uid.MarkedString) ()
@ -24,44 +25,46 @@ let dead_value = LocalName.fresh ("dead_value", Pos.no_pos)
let handle_default = TopLevelName.fresh ("handle_default", Pos.no_pos)
let handle_default_opt = TopLevelName.fresh ("handle_default_opt", Pos.no_pos)
type expr =
type expr = naked_expr Marked.pos
and naked_expr =
| EVar of LocalName.t
| EFunc of TopLevelName.t
| EStruct of expr Marked.pos list * D.StructName.t
| EStructFieldAccess of expr Marked.pos * D.StructFieldName.t * D.StructName.t
| EInj of expr Marked.pos * D.EnumConstructor.t * D.EnumName.t
| EArray of expr Marked.pos list
| EStruct of expr list * StructName.t
| EStructFieldAccess of expr * StructFieldName.t * StructName.t
| EInj of expr * EnumConstructor.t * EnumName.t
| EArray of expr list
| ELit of L.lit
| EApp of expr Marked.pos * expr Marked.pos list
| EOp of Dcalc.Ast.operator
| EApp of expr * expr list
| EOp of operator
type stmt =
| SInnerFuncDef of LocalName.t Marked.pos * func
| SLocalDecl of LocalName.t Marked.pos * D.typ Marked.pos
| SLocalDef of LocalName.t Marked.pos * expr Marked.pos
| STryExcept of block * L.except * block
| SRaise of L.except
| SIfThenElse of expr Marked.pos * block * block
| SLocalDecl of LocalName.t Marked.pos * typ
| SLocalDef of LocalName.t Marked.pos * expr
| STryExcept of block * except * block
| SRaise of except
| SIfThenElse of expr * block * block
| SSwitch of
expr Marked.pos
* D.EnumName.t
expr
* EnumName.t
* (block (* Statements corresponding to arm closure body*)
* (* Variable instantiated with enum payload *) LocalName.t)
list (** Each block corresponds to one case of the enum *)
| SReturn of expr
| SAssert of expr
| SReturn of naked_expr
| SAssert of naked_expr
and block = stmt Marked.pos list
and func = {
func_params : (LocalName.t Marked.pos * D.typ Marked.pos) list;
func_params : (LocalName.t Marked.pos * typ) list;
func_body : block;
}
type scope_body = {
scope_body_name : Dcalc.Ast.ScopeName.t;
scope_body_name : ScopeName.t;
scope_body_var : TopLevelName.t;
scope_body_func : func;
}
type program = { decl_ctx : D.decl_ctx; scopes : scope_body list }
type program = { decl_ctx : decl_ctx; scopes : scope_body list }

132
compiler/scalc/compile_from_lambda.ml
View File

@ -15,13 +15,14 @@
the License. *)
open Utils
open Shared_ast
module A = Ast
module L = Lcalc.Ast
module D = Dcalc.Ast
type 'm ctxt = {
func_dict : ('m L.expr, A.TopLevelName.t) Var.Map.t;
decl_ctx : D.decl_ctx;
decl_ctx : decl_ctx;
var_dict : ('m L.expr, A.LocalName.t) Var.Map.t;
inside_definition_of : A.LocalName.t option;
context_name : string;
@ -29,16 +30,15 @@ type 'm ctxt = {
(* Expressions can spill out side effect, hence this function also returns a
list of statements to be prepended before the expression is evaluated *)
let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.marked_expr) :
A.block * A.expr Marked.pos =
let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
match Marked.unmark expr with
| L.EVar v ->
| EVar v ->
let local_var =
try A.EVar (Var.Map.find v ctxt.var_dict)
with Not_found -> A.EFunc (Var.Map.find v ctxt.func_dict)
in
[], (local_var, D.pos expr)
| L.ETuple (args, Some s_name) ->
[], (local_var, Expr.pos expr)
| ETuple (args, Some s_name) ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
@ -48,25 +48,23 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.marked_expr) :
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
args_stmts, (A.EStruct (new_args, s_name), D.pos expr)
| L.ETuple (_, None) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| L.ETupleAccess (e1, num_field, Some s_name, _) ->
args_stmts, (A.EStruct (new_args, s_name), Expr.pos expr)
| ETuple (_, None) -> failwith "Non-struct tuples cannot be compiled to scalc"
| ETupleAccess (e1, num_field, Some s_name, _) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let field_name =
fst
(List.nth (D.StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field)
fst (List.nth (StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field)
in
e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), D.pos expr)
| L.ETupleAccess (_, _, None, _) ->
e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), Expr.pos expr)
| ETupleAccess (_, _, None, _) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| L.EInj (e1, num_cons, e_name, _) ->
| EInj (e1, num_cons, e_name, _) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let cons_name =
fst (List.nth (D.EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons)
fst (List.nth (EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons)
in
e1_stmts, (A.EInj (new_e1, cons_name, e_name), D.pos expr)
| L.EApp (f, args) ->
e1_stmts, (A.EInj (new_e1, cons_name, e_name), Expr.pos expr)
| EApp (f, args) ->
let f_stmts, new_f = translate_expr ctxt f in
let args_stmts, new_args =
List.fold_left
@ -76,8 +74,8 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.marked_expr) :
([], []) args
in
let new_args = List.rev new_args in
f_stmts @ args_stmts, (A.EApp (new_f, new_args), D.pos expr)
| L.EArray args ->
f_stmts @ args_stmts, (A.EApp (new_f, new_args), Expr.pos expr)
| EArray args ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
@ -86,9 +84,9 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.marked_expr) :
([], []) args
in
let new_args = List.rev new_args in
args_stmts, (A.EArray new_args, D.pos expr)
| L.EOp op -> [], (A.EOp op, D.pos expr)
| L.ELit l -> [], (A.ELit l, D.pos expr)
args_stmts, (A.EArray new_args, Expr.pos expr)
| EOp op -> [], (A.EOp op, Expr.pos expr)
| ELit l -> [], (A.ELit l, Expr.pos expr)
| _ ->
let tmp_var =
A.LocalName.fresh
@ -101,7 +99,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.marked_expr) :
let v = Marked.unmark (A.LocalName.get_info v) in
let tmp_rex = Re.Pcre.regexp "^temp_" in
if Re.Pcre.pmatch ~rex:tmp_rex v then v else "temp_" ^ v),
D.pos expr )
Expr.pos expr )
in
let ctxt =
{
@ -111,20 +109,20 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.marked_expr) :
}
in
let tmp_stmts = translate_statements ctxt expr in
( (A.SLocalDecl ((tmp_var, D.pos expr), (D.TAny, D.pos expr)), D.pos expr)
( ( A.SLocalDecl ((tmp_var, Expr.pos expr), (TAny, Expr.pos expr)),
Expr.pos expr )
:: tmp_stmts,
(A.EVar tmp_var, D.pos expr) )
(A.EVar tmp_var, Expr.pos expr) )
and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.marked_expr) :
A.block =
and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
match Marked.unmark block_expr with
| L.EAssert e ->
| EAssert e ->
(* Assertions are always encapsulated in a unit-typed let binding *)
let e_stmts, new_e = translate_expr ctxt e in
e_stmts @ [A.SAssert (Marked.unmark new_e), D.pos block_expr]
| L.EApp ((L.EAbs (binder, taus), binder_mark), args) ->
e_stmts @ [A.SAssert (Marked.unmark new_e), Expr.pos block_expr]
| EApp ((EAbs (binder, taus), binder_mark), args) ->
(* This defines multiple local variables at the time *)
let binder_pos = D.mark_pos binder_mark in
let binder_pos = Expr.mark_pos binder_mark in
let vars, body = Bindlib.unmbind binder in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let ctxt =
@ -169,13 +167,13 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.marked_expr) :
in
let rest_of_block = translate_statements ctxt body in
local_decls @ List.flatten def_blocks @ rest_of_block
| L.EAbs (binder, taus) ->
| EAbs (binder, taus) ->
let vars, body = Bindlib.unmbind binder in
let binder_pos = D.pos block_expr in
let binder_pos = Expr.pos block_expr in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let closure_name =
match ctxt.inside_definition_of with
| None -> A.LocalName.fresh (ctxt.context_name, D.pos block_expr)
| None -> A.LocalName.fresh (ctxt.context_name, Expr.pos block_expr)
| Some x -> x
in
let ctxt =
@ -205,18 +203,18 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.marked_expr) :
} ),
binder_pos );
]
| L.EMatch (e1, args, e_name) ->
| EMatch (e1, args, e_name) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let new_args =
List.fold_left
(fun new_args arg ->
match Marked.unmark arg with
| L.EAbs (binder, _) ->
| EAbs (binder, _) ->
let vars, body = Bindlib.unmbind binder in
assert (Array.length vars = 1);
let var = vars.(0) in
let scalc_var =
A.LocalName.fresh (Bindlib.name_of var, D.pos arg)
A.LocalName.fresh (Bindlib.name_of var, Expr.pos arg)
in
let ctxt =
{ ctxt with var_dict = Var.Map.add var scalc_var ctxt.var_dict }
@ -228,17 +226,18 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.marked_expr) :
[] args
in
let new_args = List.rev new_args in
e1_stmts @ [A.SSwitch (new_e1, e_name, new_args), D.pos block_expr]
| L.EIfThenElse (cond, e_true, e_false) ->
e1_stmts @ [A.SSwitch (new_e1, e_name, new_args), Expr.pos block_expr]
| EIfThenElse (cond, e_true, e_false) ->
let cond_stmts, s_cond = translate_expr ctxt cond in
let s_e_true = translate_statements ctxt e_true in
let s_e_false = translate_statements ctxt e_false in
cond_stmts @ [A.SIfThenElse (s_cond, s_e_true, s_e_false), D.pos block_expr]
| L.ECatch (e_try, except, e_catch) ->
cond_stmts
@ [A.SIfThenElse (s_cond, s_e_true, s_e_false), Expr.pos block_expr]
| ECatch (e_try, except, e_catch) ->
let s_e_try = translate_statements ctxt e_try in
let s_e_catch = translate_statements ctxt e_catch in
[A.STryExcept (s_e_try, except, s_e_catch), D.pos block_expr]
| L.ERaise except ->
[A.STryExcept (s_e_try, except, s_e_catch), Expr.pos block_expr]
| ERaise except ->
(* Before raising the exception, we still give a dummy definition to the
current variable so that tools like mypy don't complain. *)
(match ctxt.inside_definition_of with
@ -246,10 +245,11 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.marked_expr) :
| Some x ->
[
( A.SLocalDef
((x, D.pos block_expr), (Ast.EVar Ast.dead_value, D.pos block_expr)),
D.pos block_expr );
( (x, Expr.pos block_expr),
(Ast.EVar Ast.dead_value, Expr.pos block_expr) ),
Expr.pos block_expr );
])
@ [A.SRaise except, D.pos block_expr]
@ [A.SRaise except, Expr.pos block_expr]
| _ -> (
let e_stmts, new_e = translate_expr ctxt block_expr in
e_stmts
@ -265,15 +265,15 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.marked_expr) :
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Marked.unmark new_e)
| Some x -> A.SLocalDef (Marked.same_mark_as x new_e, new_e)),
D.pos block_expr );
Expr.pos block_expr );
])
let rec translate_scope_body_expr
(scope_name : D.ScopeName.t)
(decl_ctx : D.decl_ctx)
(scope_name : ScopeName.t)
(decl_ctx : decl_ctx)
(var_dict : ('m L.expr, A.LocalName.t) Var.Map.t)
(func_dict : ('m L.expr, A.TopLevelName.t) Var.Map.t)
(scope_expr : ('m L.expr, 'm) D.scope_body_expr) : A.block =
(scope_expr : 'm L.expr scope_body_expr) : A.block =
match scope_expr with
| Result e ->
let block, new_e =
@ -283,7 +283,7 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = None;
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
context_name = Marked.unmark (ScopeName.get_info scope_name);
}
e
in
@ -295,14 +295,14 @@ let rec translate_scope_body_expr
in
let new_var_dict = Var.Map.add let_var let_var_id var_dict in
(match scope_let.scope_let_kind with
| D.Assertion ->
| Assertion ->
translate_statements
{
decl_ctx;
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
context_name = Marked.unmark (ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
| _ ->
@ -313,7 +313,7 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
context_name = Marked.unmark (ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
in
@ -330,16 +330,16 @@ let rec translate_scope_body_expr
let translate_program (p : 'm L.program) : A.program =
{
decl_ctx = p.D.decl_ctx;
decl_ctx = p.decl_ctx;
scopes =
(let _, new_scopes =
D.fold_left_scope_defs
Scope.fold_left
~f:(fun (func_dict, new_scopes) scope_def scope_var ->
let scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let input_pos =
Marked.get_mark (D.ScopeName.get_info scope_def.scope_name)
Marked.get_mark (ScopeName.get_info scope_def.scope_name)
in
let scope_input_var_id =
A.LocalName.fresh (Bindlib.name_of scope_input_var, input_pos)
@ -348,7 +348,7 @@ let translate_program (p : 'm L.program) : A.program =
Var.Map.singleton scope_input_var scope_input_var_id
in
let new_scope_body =
translate_scope_body_expr scope_def.D.scope_name p.decl_ctx
translate_scope_body_expr scope_def.scope_name p.decl_ctx
var_dict func_dict scope_body_expr
in
let func_id =
@ -357,22 +357,14 @@ let translate_program (p : 'm L.program) : A.program =
let func_dict = Var.Map.add scope_var func_id func_dict in
( func_dict,
{
Ast.scope_body_name = scope_def.D.scope_name;
Ast.scope_body_name = scope_def.scope_name;
Ast.scope_body_var = func_id;
scope_body_func =
{
A.func_params =
[
( (scope_input_var_id, input_pos),
( D.TTuple
( List.map snd
(D.StructMap.find
scope_def.D.scope_body
.D.scope_body_input_struct
p.D.decl_ctx.ctx_structs),
Some
scope_def.D.scope_body
.D.scope_body_input_struct ),
( TStruct scope_def.scope_body.scope_body_input_struct,
input_pos ) );
];
A.func_body = new_scope_body;
@ -384,7 +376,7 @@ let translate_program (p : 'm L.program) : A.program =
Var.Map.singleton L.handle_default_opt A.handle_default_opt
else Var.Map.singleton L.handle_default A.handle_default),
[] )
p.D.scopes
p.scopes
in
List.rev new_scopes);
}

163
compiler/scalc/print.ml
View File

@ -15,193 +15,176 @@
the License. *)
open Utils
open Shared_ast
open Ast
let needs_parens (_e : expr Marked.pos) : bool = false
let needs_parens (_e : expr) : bool = false
let format_local_name (fmt : Format.formatter) (v : LocalName.t) : unit =
Format.fprintf fmt "%a_%s" LocalName.format_t v
(string_of_int (LocalName.hash v))
let rec format_expr
(decl_ctx : Dcalc.Ast.decl_ctx)
(decl_ctx : decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(e : expr Marked.pos) : unit =
(e : expr) : unit =
let format_expr = format_expr decl_ctx ~debug in
let format_with_parens (fmt : Format.formatter) (e : expr Marked.pos) =
let format_with_parens (fmt : Format.formatter) (e : expr) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_expr
e Dcalc.Print.format_punctuation ")"
Format.fprintf fmt "%a%a%a" Print.punctuation "(" format_expr e
Print.punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_local_name v
| EFunc v -> Format.fprintf fmt "%a" TopLevelName.format_t v
| EStruct (es, s) ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" Dcalc.Ast.StructName.format_t s
Dcalc.Print.format_punctuation "{"
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" StructName.format_t s
Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a %a" Dcalc.Print.format_punctuation "\""
Dcalc.Ast.StructFieldName.format_t struct_field
Dcalc.Print.format_punctuation "\"" Dcalc.Print.format_punctuation
":" format_expr e))
(List.combine es
(List.map fst (Dcalc.Ast.StructMap.find s decl_ctx.ctx_structs)))
Dcalc.Print.format_punctuation "}"
Format.fprintf fmt "%a%a%a%a %a" Print.punctuation "\""
StructFieldName.format_t struct_field Print.punctuation "\""
Print.punctuation ":" format_expr e))
(List.combine es (List.map fst (StructMap.find s decl_ctx.ctx_structs)))
Print.punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Dcalc.Print.format_punctuation "["
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es Dcalc.Print.format_punctuation "]"
es Print.punctuation "]"
| EStructFieldAccess (e1, field, s) ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1
Dcalc.Print.format_punctuation "." Dcalc.Print.format_punctuation "\""
Dcalc.Ast.StructFieldName.format_t
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 Print.punctuation "."
Print.punctuation "\"" StructFieldName.format_t
(fst
(List.find
(fun (field', _) ->
Dcalc.Ast.StructFieldName.compare field' field = 0)
(Dcalc.Ast.StructMap.find s decl_ctx.ctx_structs)))
Dcalc.Print.format_punctuation "\""
(fun (field', _) -> StructFieldName.compare field' field = 0)
(StructMap.find s decl_ctx.ctx_structs)))
Print.punctuation "\""
| EInj (e, case, enum) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_enum_constructor
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.enum_constructor
(fst
(List.find
(fun (case', _) -> Dcalc.Ast.EnumConstructor.compare case' case = 0)
(Dcalc.Ast.EnumMap.find enum decl_ctx.ctx_enums)))
(fun (case', _) -> EnumConstructor.compare case' case = 0)
(EnumMap.find enum decl_ctx.ctx_enums)))
format_expr e
| ELit l ->
Format.fprintf fmt "%a" Lcalc.Print.format_lit (Marked.same_mark_as l e)
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop op
format_with_parens arg1 format_with_parens arg2
| ELit l -> Print.lit fmt l
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Print.binop op format_with_parens
arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
Dcalc.Print.format_binop op format_with_parens arg2
Print.binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop op
format_with_parens arg1
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.unop op format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop op
| EOp (Ternop op) -> Format.fprintf fmt "%a" Print.ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Print.binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Print.unop op
let rec format_statement
(decl_ctx : Dcalc.Ast.decl_ctx)
(decl_ctx : decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(stmt : stmt Marked.pos) : unit =
if debug then () else ();
match Marked.unmark stmt with
| SInnerFuncDef (name, func) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
Dcalc.Print.format_keyword "let" LocalName.format_t (Marked.unmark name)
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]" Print.keyword
"let" LocalName.format_t (Marked.unmark name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "("
LocalName.format_t name Dcalc.Print.format_punctuation ":"
(Dcalc.Print.format_typ decl_ctx)
(Marked.unmark typ) Dcalc.Print.format_punctuation ")"))
func.func_params Dcalc.Print.format_punctuation "="
Format.fprintf fmt "%a%a %a@ %a%a" Print.punctuation "("
LocalName.format_t name Print.punctuation ":" (Print.typ decl_ctx)
typ Print.punctuation ")"))
func.func_params Print.punctuation "="
(format_block decl_ctx ~debug)
func.func_body
| SLocalDecl (name, typ) ->
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Dcalc.Print.format_keyword
"decl" LocalName.format_t (Marked.unmark name)
Dcalc.Print.format_punctuation ":"
(Dcalc.Print.format_typ decl_ctx)
(Marked.unmark typ)
| SLocalDef (name, expr) ->
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Print.keyword "decl"
LocalName.format_t (Marked.unmark name) Print.punctuation ":"
(Print.typ decl_ctx) typ
| SLocalDef (name, naked_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" LocalName.format_t
(Marked.unmark name) Dcalc.Print.format_punctuation "="
(Marked.unmark name) Print.punctuation "="
(format_expr decl_ctx ~debug)
expr
naked_expr
| STryExcept (b_try, except, b_with) ->
Format.fprintf fmt "@[<v 2>%a%a@ %a@]@\n@[<v 2>%a %a%a@ %a@]"
Dcalc.Print.format_keyword "try" Dcalc.Print.format_punctuation ":"
Format.fprintf fmt "@[<v 2>%a%a@ %a@]@\n@[<v 2>%a %a%a@ %a@]" Print.keyword
"try" Print.punctuation ":"
(format_block decl_ctx ~debug)
b_try Dcalc.Print.format_keyword "with" Lcalc.Print.format_exception
except Dcalc.Print.format_punctuation ":"
b_try Print.keyword "with" Print.except except Print.punctuation ":"
(format_block decl_ctx ~debug)
b_with
| SRaise except ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Dcalc.Print.format_keyword "raise"
Lcalc.Print.format_exception except
Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "raise" Print.except
except
| SIfThenElse (e_if, b_true, b_false) ->
Format.fprintf fmt "@[<v 2>%a @[<hov 2>%a@]%a@ %a@ @]@[<v 2>%a%a@ %a@]"
Dcalc.Print.format_keyword "if"
Print.keyword "if"
(format_expr decl_ctx ~debug)
e_if Dcalc.Print.format_punctuation ":"
e_if Print.punctuation ":"
(format_block decl_ctx ~debug)
b_true Dcalc.Print.format_keyword "else" Dcalc.Print.format_punctuation
":"
b_true Print.keyword "else" Print.punctuation ":"
(format_block decl_ctx ~debug)
b_false
| SReturn ret ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Dcalc.Print.format_keyword "return"
Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "return"
(format_expr decl_ctx ~debug)
(ret, Marked.get_mark stmt)
| SAssert expr ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Dcalc.Print.format_keyword "assert"
| SAssert naked_expr ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "assert"
(format_expr decl_ctx ~debug)
(expr, Marked.get_mark stmt)
(naked_expr, Marked.get_mark stmt)
| SSwitch (e_switch, enum, arms) ->
Format.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@]%a"
Dcalc.Print.format_keyword "switch"
Format.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@]%a" Print.keyword "switch"
(format_expr decl_ctx ~debug)
e_switch Dcalc.Print.format_punctuation ":"
e_switch Print.punctuation ":"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt ((case, _), (arm_block, payload_name)) ->
Format.fprintf fmt "%a %a%a@ %a @[<v 2>%a@ %a@]"
Dcalc.Print.format_punctuation "|"
Dcalc.Print.format_enum_constructor case
Dcalc.Print.format_punctuation ":" LocalName.format_t payload_name
Dcalc.Print.format_punctuation "→"
Format.fprintf fmt "%a %a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation
"|" Print.enum_constructor case Print.punctuation ":"
LocalName.format_t payload_name Print.punctuation "→"
(format_block decl_ctx ~debug)
arm_block))
(List.combine (Dcalc.Ast.EnumMap.find enum decl_ctx.ctx_enums) arms)
(List.combine (EnumMap.find enum decl_ctx.ctx_enums) arms)
and format_block
(decl_ctx : Dcalc.Ast.decl_ctx)
(decl_ctx : decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(block : block) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";")
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Print.punctuation ";")
(format_statement decl_ctx ~debug)
fmt block
let format_scope
(decl_ctx : Dcalc.Ast.decl_ctx)
(decl_ctx : decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(body : scope_body) : unit =
if debug then () else ();
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
Dcalc.Print.format_keyword "let" TopLevelName.format_t body.scope_body_var
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]" Print.keyword
"let" TopLevelName.format_t body.scope_body_var
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "("
LocalName.format_t name Dcalc.Print.format_punctuation ":"
(Dcalc.Print.format_typ decl_ctx)
(Marked.unmark typ) Dcalc.Print.format_punctuation ")"))
body.scope_body_func.func_params Dcalc.Print.format_punctuation "="
Format.fprintf fmt "%a%a %a@ %a%a" Print.punctuation "("
LocalName.format_t name Print.punctuation ":" (Print.typ decl_ctx)
typ Print.punctuation ")"))
body.scope_body_func.func_params Print.punctuation "="
(format_block decl_ctx ~debug)
body.scope_body_func.func_body

2
compiler/scalc/print.mli
View File

@ -15,7 +15,7 @@
the License. *)
val format_scope :
Dcalc.Ast.decl_ctx ->
Shared_ast.decl_ctx ->
?debug:bool ->
Format.formatter ->
Ast.scope_body ->

124
compiler/scalc/to_python.ml
View File

@ -16,6 +16,7 @@
[@@@warning "-32-27"]
open Utils
open Shared_ast
open Ast
open String_common
module Runtime = Runtime_ocaml.Runtime
@ -29,9 +30,7 @@ let format_lit (fmt : Format.formatter) (l : L.lit Marked.pos) : unit =
| LInt i ->
Format.fprintf fmt "integer_of_string(\"%s\")" (Runtime.integer_to_string i)
| LUnit -> Format.fprintf fmt "Unit()"
| LRat i ->
Format.fprintf fmt "decimal_of_string(\"%a\")" Dcalc.Print.format_lit
(Dcalc.Ast.LRat i)
| LRat i -> Format.fprintf fmt "decimal_of_string(\"%a\")" Print.lit (LRat i)
| LMoney e ->
Format.fprintf fmt "money_of_cents_string(\"%s\")"
(Runtime.integer_to_string (Runtime.money_to_cents e))
@ -44,21 +43,19 @@ let format_lit (fmt : Format.formatter) (l : L.lit Marked.pos) : unit =
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers(%d,%d,%d)" years months days
let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) :
unit =
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
match entry with
| VarDef _ -> Format.fprintf fmt ":="
| BeginCall -> Format.fprintf fmt "→ "
| EndCall -> Format.fprintf fmt "%s" "← "
| PosRecordIfTrueBool -> Format.fprintf fmt "☛ "
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Marked.pos) :
unit =
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
match Marked.unmark op with
| Add _ | Concat -> Format.fprintf fmt "+"
| Sub _ -> Format.fprintf fmt "-"
| Mult _ -> Format.fprintf fmt "*"
| Div D.KInt -> Format.fprintf fmt "//"
| Div KInt -> Format.fprintf fmt "//"
| Div _ -> Format.fprintf fmt "/"
| And -> Format.fprintf fmt "and"
| Or -> Format.fprintf fmt "or"
@ -71,8 +68,7 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Marked.pos) :
| Map -> Format.fprintf fmt "list_map"
| Filter -> Format.fprintf fmt "list_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Marked.pos) :
unit =
let format_ternop (fmt : Format.formatter) (op : ternop Marked.pos) : unit =
match Marked.unmark op with Fold -> Format.fprintf fmt "list_fold_left"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
@ -94,8 +90,7 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Marked.pos) : unit
=
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
match Marked.unmark op with
| Minus _ -> Format.fprintf fmt "-"
| Not -> Format.fprintf fmt "not"
@ -127,43 +122,34 @@ let avoid_keywords (s : string) : string =
then s ^ "_"
else s
let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_camel_case (to_ascii (Format.asprintf "%a" StructName.format_t v))))
let format_struct_field_name (fmt : Format.formatter) (v : StructFieldName.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_camel_case
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v))))
(to_ascii (Format.asprintf "%a" StructFieldName.format_t v)))
let format_struct_field_name
(fmt : Format.formatter)
(v : Dcalc.Ast.StructFieldName.t) : unit =
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))
(to_camel_case (to_ascii (Format.asprintf "%a" EnumName.format_t v))))
let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit
=
let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_camel_case
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
(to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
let format_enum_cons_name
(fmt : Format.formatter)
(v : Dcalc.Ast.EnumConstructor.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
let typ_needs_parens (e : Dcalc.Ast.typ Marked.pos) : bool =
let typ_needs_parens (e : typ) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
unit =
let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
let format_typ = format_typ in
let format_typ_with_parens
(fmt : Format.formatter)
(t : Dcalc.Ast.typ Marked.pos) =
let format_typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
@ -175,17 +161,17 @@ let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
| TLit TDate -> Format.fprintf fmt "Date"
| TLit TDuration -> Format.fprintf fmt "Duration"
| TLit TBool -> Format.fprintf fmt "bool"
| TTuple (ts, None) ->
| TTuple ts ->
Format.fprintf fmt "Tuple[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ_with_parens t))
ts
| TTuple (_, Some s) -> Format.fprintf fmt "%a" format_struct_name s
| TEnum ([_; some_typ], e) when D.EnumName.compare e L.option_enum = 0 ->
| TStruct s -> Format.fprintf fmt "%a" format_struct_name s
| TOption some_typ ->
(* We translate the option type with an overloading by Python's [None] *)
Format.fprintf fmt "Optional[%a]" format_typ some_typ
| TEnum (_, e) -> Format.fprintf fmt "%a" format_enum_name e
| TEnum e -> Format.fprintf fmt "%a" format_enum_name e
| TArrow (t1, t2) ->
Format.fprintf fmt "Callable[[%a], %a]" format_typ_with_parens t1
format_typ_with_parens t2
@ -246,13 +232,12 @@ let format_toplevel_name (fmt : Format.formatter) (v : TopLevelName.t) : unit =
let v_str = Marked.unmark (TopLevelName.get_info v) in
format_name_cleaned fmt v_str
let needs_parens (e : expr Marked.pos) : bool =
let needs_parens (e : expr) : bool =
match Marked.unmark e with
| ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false
| _ -> true
let format_exception (fmt : Format.formatter) (exc : L.except Marked.pos) : unit
=
let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
let pos = Marked.get_mark exc in
match Marked.unmark exc with
| ConflictError ->
@ -274,10 +259,8 @@ let format_exception (fmt : Format.formatter) (exc : L.except Marked.pos) : unit
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
let rec format_expression
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(e : expr Marked.pos) : unit =
let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
unit =
match Marked.unmark e with
| EVar v -> format_var fmt v
| EFunc f -> format_toplevel_name fmt f
@ -288,19 +271,18 @@ let rec format_expression
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
(format_expression ctx) e))
(List.combine es
(List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
(List.combine es (List.map fst (StructMap.find s ctx.ctx_structs)))
| EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
format_struct_field_name field
| EInj (_, cons, e_name)
when D.EnumName.compare e_name L.option_enum = 0
&& D.EnumConstructor.compare cons L.none_constr = 0 ->
when EnumName.compare e_name L.option_enum = 0
&& EnumConstructor.compare cons L.none_constr = 0 ->
(* We translate the option type with an overloading by Python's [None] *)
Format.fprintf fmt "None"
| EInj (e, cons, e_name)
when D.EnumName.compare e_name L.option_enum = 0
&& D.EnumConstructor.compare cons L.some_constr = 0 ->
when EnumName.compare e_name L.option_enum = 0
&& EnumConstructor.compare cons L.some_constr = 0 ->
(* We translate the option type with an overloading by Python's [None] *)
format_expression ctx fmt e
| EInj (e, cons, enum_name) ->
@ -314,23 +296,21 @@ let rec format_expression
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.same_mark_as l e)
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
Format.fprintf fmt "%a(%a,@ %a)" format_binop (op, Pos.no_pos)
(format_expression ctx) arg1 (format_expression ctx) arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_binop
(op, Pos.no_pos) (format_expression ctx) arg2
| EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [f]), _), [arg])
| EApp ((EApp ((EOp (Unop (Log (BeginCall, info))), _), [f]), _), [arg])
when !Cli.trace_flag ->
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
(format_expression ctx) f (format_expression ctx) arg
| EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [arg1])
when !Cli.trace_flag ->
| EApp ((EOp (Unop (Log (VarDef tau, info))), _), [arg1]) when !Cli.trace_flag
->
Format.fprintf fmt "log_variable_definition(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [arg1])
| EApp ((EOp (Unop (Log (PosRecordIfTrueBool, _))), pos), [arg1])
when !Cli.trace_flag ->
Format.fprintf fmt
"log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ \
@ -338,11 +318,10 @@ let rec format_expression
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) (format_expression ctx) arg1
| EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [arg1])
when !Cli.trace_flag ->
| EApp ((EOp (Unop (Log (EndCall, info))), _), [arg1]) when !Cli.trace_flag ->
Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1
| EApp ((EOp (Unop (D.Log _)), _), [arg1]) ->
| EApp ((EOp (Unop (Log _)), _), [arg1]) ->
Format.fprintf fmt "%a" (format_expression ctx) arg1
| EApp ((EOp (Unop ((Minus _ | Not) as op)), _), [arg1]) ->
Format.fprintf fmt "%a %a" format_unop (op, Pos.no_pos)
@ -374,7 +353,7 @@ let rec format_expression
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
let rec format_statement
(ctx : Dcalc.Ast.decl_ctx)
(ctx : decl_ctx)
(fmt : Format.formatter)
(s : stmt Marked.pos) : unit =
match Marked.unmark s with
@ -403,7 +382,7 @@ let rec format_statement
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
| SSwitch (e1, e_name, [(case_none, _); (case_some, case_some_var)])
when D.EnumName.compare e_name L.option_enum = 0 ->
when EnumName.compare e_name L.option_enum = 0 ->
(* We translate the option type with an overloading by Python's [None] *)
let tmp_var = LocalName.fresh ("perhaps_none_arg", Pos.no_pos) in
Format.fprintf fmt
@ -421,7 +400,7 @@ let rec format_statement
List.map2
(fun (x, y) (cons, _) -> x, y, cons)
cases
(D.EnumMap.find e_name ctx.ctx_enums)
(EnumMap.find e_name ctx.ctx_enums)
in
let tmp_var = LocalName.fresh ("match_arg", Pos.no_pos) in
Format.fprintf fmt "%a = %a@\n@[<hov 4>if %a@]" format_var tmp_var
@ -450,8 +429,7 @@ let rec format_statement
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block)
: unit =
and format_block (ctx : decl_ctx) (fmt : Format.formatter) (b : block) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(format_statement ctx) fmt
@ -462,7 +440,7 @@ and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block)
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
(fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
(ctx : decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
Format.fprintf fmt
"class %a:@\n\
@ -562,8 +540,8 @@ let format_ctx
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(Dcalc.Ast.StructMap.bindings
(Dcalc.Ast.StructMap.filter
(StructMap.bindings
(StructMap.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in
@ -572,10 +550,10 @@ let format_ctx
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n@\n" format_struct_decl
(s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs)
(s, StructMap.find s ctx.ctx_structs)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n@\n" format_enum_decl
(e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums))
(e, EnumMap.find e ctx.ctx_enums))
(type_ordering @ scope_structs)
let format_program

268
compiler/scopelang/ast.ml
View File

@ -15,216 +15,38 @@
the License. *)
open Utils
module ScopeName = Dcalc.Ast.ScopeName
module ScopeNameSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName)
open Shared_ast
module ScopeMap : Map.S with type key = ScopeName.t = Map.Make (ScopeName)
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module SubScopeNameSet : Set.S with type elt = SubScopeName.t =
Set.Make (SubScopeName)
module SubScopeMap : Map.S with type key = SubScopeName.t =
Map.Make (SubScopeName)
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar)
module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar)
module StructName = Dcalc.Ast.StructName
module StructMap = Dcalc.Ast.StructMap
module StructFieldName = Dcalc.Ast.StructFieldName
module StructFieldMap : Map.S with type key = StructFieldName.t =
Map.Make (StructFieldName)
module StructFieldMapLift = Bindlib.Lift (StructFieldMap)
module EnumName = Dcalc.Ast.EnumName
module EnumMap = Dcalc.Ast.EnumMap
module EnumConstructor = Dcalc.Ast.EnumConstructor
module EnumConstructorMap : Map.S with type key = EnumConstructor.t =
Map.Make (EnumConstructor)
module EnumConstructorMapLift = Bindlib.Lift (EnumConstructorMap)
type location =
| ScopeVar of ScopeVar.t Marked.pos
| SubScopeVar of
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
type location = scopelang glocation
module LocationSet : Set.S with type elt = location Marked.pos =
Set.Make (struct
type t = location Marked.pos
let compare x y =
match Marked.unmark x, Marked.unmark y with
| ScopeVar (vx, _), ScopeVar (vy, _) -> ScopeVar.compare vx vy
| ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)),
SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) ->
let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| ScopeVar _, SubScopeVar _ -> -1
| SubScopeVar _, ScopeVar _ -> 1
let compare = Expr.compare_location
end)
type typ =
| TLit of Dcalc.Ast.typ_lit
| TStruct of StructName.t
| TEnum of EnumName.t
| TArrow of typ Marked.pos * typ Marked.pos
| TArray of typ
| TAny
type expr = (scopelang, untyped mark) gexpr
module Typ = struct
type t = typ
let rec compare ty1 ty2 =
match ty1, ty2 with
| TLit l1, TLit l2 -> Stdlib.compare l1 l2
| TStruct n1, TStruct n2 -> StructName.compare n1 n2
| TEnum en1, TEnum en2 -> EnumName.compare en1 en2
| TArrow ((a1, _), (b1, _)), TArrow ((a2, _), (b2, _)) -> (
match compare a1 a2 with 0 -> compare b1 b2 | n -> n)
| TArray t1, TArray t2 -> compare t1 t2
| TAny, TAny -> 0
| TLit _, _ -> -1
| _, TLit _ -> 1
| TStruct _, _ -> -1
| _, TStruct _ -> 1
| TEnum _, _ -> -1
| _, TEnum _ -> 1
| TArrow _, _ -> -1
| _, TArrow _ -> 1
| TArray _, _ -> -1
| _, TArray _ -> 1
end
type marked_expr = expr Marked.pos
and expr =
| ELocation of location
| EVar of expr Bindlib.var
| EStruct of StructName.t * marked_expr StructFieldMap.t
| EStructAccess of marked_expr * StructFieldName.t * StructName.t
| EEnumInj of marked_expr * EnumConstructor.t * EnumName.t
| EMatch of marked_expr * EnumName.t * marked_expr EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of (expr, marked_expr) Bindlib.mbinder * typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module Expr = struct
module ExprMap = Map.Make (struct
type t = expr
let rec compare e1 e2 =
let rec list_compare cmp l1 l2 =
(* List.compare is available from OCaml 4.12 on *)
match l1, l2 with
| [], [] -> 0
| [], _ :: _ -> -1
| _ :: _, [] -> 1
| a1 :: l1, a2 :: l2 ->
let c = cmp a1 a2 in
if c <> 0 then c else list_compare cmp l1 l2
in
match e1, e2 with
| ELocation _, ELocation _ -> 0
| EVar v1, EVar v2 -> Bindlib.compare_vars v1 v2
| EStruct (name1, field_map1), EStruct (name2, field_map2) -> (
match StructName.compare name1 name2 with
| 0 ->
StructFieldMap.compare (Marked.compare compare) field_map1 field_map2
| n -> n)
| ( EStructAccess ((e1, _), field_name1, struct_name1),
EStructAccess ((e2, _), field_name2, struct_name2) ) -> (
match compare e1 e2 with
| 0 -> (
match StructFieldName.compare field_name1 field_name2 with
| 0 -> StructName.compare struct_name1 struct_name2
| n -> n)
| n -> n)
| EEnumInj ((e1, _), cstr1, name1), EEnumInj ((e2, _), cstr2, name2) -> (
match compare e1 e2 with
| 0 -> (
match EnumName.compare name1 name2 with
| 0 -> EnumConstructor.compare cstr1 cstr2
| n -> n)
| n -> n)
| EMatch ((e1, _), name1, emap1), EMatch ((e2, _), name2, emap2) -> (
match compare e1 e2 with
| 0 -> (
match EnumName.compare name1 name2 with
| 0 -> EnumConstructorMap.compare (Marked.compare compare) emap1 emap2
| n -> n)
| n -> n)
| ELit l1, ELit l2 -> Stdlib.compare l1 l2
| EAbs (binder1, typs1), EAbs (binder2, typs2) -> (
match list_compare (Marked.compare Typ.compare) typs1 typs2 with
| 0 ->
let _, (e1, _), (e2, _) = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
| n -> n)
| EApp ((f1, _), args1), EApp ((f2, _), args2) -> (
match compare f1 f2 with
| 0 -> list_compare (fun (x1, _) (x2, _) -> compare x1 x2) args1 args2
| n -> n)
| EOp op1, EOp op2 -> Stdlib.compare op1 op2
| ( EDefault (exs1, (just1, _), (cons1, _)),
EDefault (exs2, (just2, _), (cons2, _)) ) -> (
match compare just1 just2 with
| 0 -> (
match compare cons1 cons2 with
| 0 -> list_compare (Marked.compare compare) exs1 exs2
| n -> n)
| n -> n)
| ( EIfThenElse ((i1, _), (t1, _), (e1, _)),
EIfThenElse ((i2, _), (t2, _), (e2, _)) ) -> (
match compare i1 i2 with
| 0 -> ( match compare t1 t2 with 0 -> compare e1 e2 | n -> n)
| n -> n)
| EArray a1, EArray a2 ->
list_compare (fun (e1, _) (e2, _) -> compare e1 e2) a1 a2
| ErrorOnEmpty (e1, _), ErrorOnEmpty (e2, _) -> compare e1 e2
| ELocation _, _ -> -1
| _, ELocation _ -> 1
| EVar _, _ -> -1
| _, EVar _ -> 1
| EStruct _, _ -> -1
| _, EStruct _ -> 1
| EStructAccess _, _ -> -1
| _, EStructAccess _ -> 1
| EEnumInj _, _ -> -1
| _, EEnumInj _ -> 1
| EMatch _, _ -> -1
| _, EMatch _ -> 1
| ELit _, _ -> -1
| _, ELit _ -> 1
| EAbs _, _ -> -1
| _, EAbs _ -> 1
| EApp _, _ -> -1
| _, EApp _ -> 1
| EOp _, _ -> -1
| _, EOp _ -> 1
| EDefault _, _ -> -1
| _, EDefault _ -> 1
| EIfThenElse _, _ -> -1
| _, EIfThenElse _ -> 1
| EArray _, _ -> -1
| _, EArray _ -> 1
end
let compare = Expr.compare
end)
module ExprMap = Map.Make (Expr)
let rec locations_used (e : expr Marked.pos) : LocationSet.t =
let rec locations_used (e : expr) : LocationSet.t =
match Marked.unmark e with
| ELocation l -> LocationSet.singleton (l, Marked.get_mark e)
| ELocation l -> LocationSet.singleton (l, Expr.pos e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
@ -235,7 +57,7 @@ let rec locations_used (e : expr Marked.pos) : LocationSet.t =
es LocationSet.empty
| EStructAccess (e1, _, _) -> locations_used e1
| EEnumInj (e1, _, _) -> locations_used e1
| EMatch (e1, _, es) ->
| EMatchS (e1, _, es) ->
EnumConstructorMap.fold
(fun _ e' acc -> LocationSet.union acc (locations_used e'))
es (locations_used e1)
@ -261,79 +83,17 @@ type io_input = NoInput | OnlyInput | Reentrant
type io = { io_output : bool Marked.pos; io_input : io_input Marked.pos }
type rule =
| Definition of location Marked.pos * typ Marked.pos * io * expr Marked.pos
| Assertion of expr Marked.pos
| Definition of location Marked.pos * typ * io * expr
| Assertion of expr
| Call of ScopeName.t * SubScopeName.t
type scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : (typ Marked.pos * io) ScopeVarMap.t;
scope_sig : (typ * io) ScopeVarMap.t;
scope_decl_rules : rule list;
}
type struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
type program = {
program_scopes : scope_decl ScopeMap.t;
program_enums : enum_ctx;
program_structs : struct_ctx;
program_ctx : decl_ctx;
}
module Var = struct
type t = expr Bindlib.var
let make (s : string) : t =
Bindlib.new_var (fun (x : expr Bindlib.var) : expr -> EVar x) s
let compare x y = Bindlib.compare_vars x y
end
type vars = expr Bindlib.mvar
let make_var ((x, pos) : Var.t Marked.pos) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun v -> v, pos) (Bindlib.box_var x)
let make_abs
(xs : vars)
(e : expr Marked.pos Bindlib.box)
(taus : typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun b -> EAbs (b, taus), pos) (Bindlib.bind_mvar xs e)
let make_app
(e : expr Marked.pos Bindlib.box)
(u : expr Marked.pos Bindlib.box list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply2 (fun e u -> EApp (e, u), pos) e (Bindlib.box_list u)
let make_let_in
(x : Var.t)
(tau : typ Marked.pos)
(e1 : expr Marked.pos Bindlib.box)
(e2 : expr Marked.pos Bindlib.box) : expr Marked.pos Bindlib.box =
Bindlib.box_apply2
(fun e u -> EApp (e, u), Marked.get_mark (Bindlib.unbox e2))
(make_abs (Array.of_list [x]) e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(Bindlib.box_list [e1])
let make_default ?(pos = Pos.no_pos) exceptions just cons =
let rec bool_value = function
| ELit (Dcalc.Ast.LBool b), _ -> Some b
| EApp ((EOp (Unop (Log (l, _))), _), [e]), _
when l <> Dcalc.Ast.PosRecordIfTrueBool
(* we don't remove the log calls corresponding to source code
definitions !*) ->
bool_value e
| _ -> None
in
match exceptions, bool_value just, cons with
| [], Some true, cons -> cons
| exceptions, Some true, (EDefault ([], just, cons), pos) ->
EDefault (exceptions, just, cons), pos
| [except], Some false, _ -> except
| exceptions, _, cons ->
let pos = if pos <> Pos.no_pos then pos else Marked.get_mark just in
EDefault (exceptions, just, cons), pos
module VarMap = Map.Make (Var)

120
compiler/scopelang/ast.mli
View File

@ -17,81 +17,35 @@
(** Abstract syntax tree of the scope language *)
open Utils
open Shared_ast
(** {1 Identifiers} *)
module ScopeName = Dcalc.Ast.ScopeName
module ScopeNameSet : Set.S with type elt = ScopeName.t
module ScopeMap : Map.S with type key = ScopeName.t
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info
module SubScopeNameSet : Set.S with type elt = SubScopeName.t
module SubScopeMap : Map.S with type key = SubScopeName.t
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info
module ScopeVarSet : Set.S with type elt = ScopeVar.t
module ScopeVarMap : Map.S with type key = ScopeVar.t
module StructName = Dcalc.Ast.StructName
module StructMap = Dcalc.Ast.StructMap
module StructFieldName = Dcalc.Ast.StructFieldName
module StructFieldMap : Map.S with type key = StructFieldName.t
module StructFieldMapLift : sig
val lift_box :
'a Bindlib.box StructFieldMap.t -> 'a StructFieldMap.t Bindlib.box
end
module EnumName = Dcalc.Ast.EnumName
module EnumMap = Dcalc.Ast.EnumMap
module EnumConstructor = Dcalc.Ast.EnumConstructor
module EnumConstructorMap : Map.S with type key = EnumConstructor.t
module EnumConstructorMapLift : sig
val lift_box :
'a Bindlib.box EnumConstructorMap.t -> 'a EnumConstructorMap.t Bindlib.box
end
type location =
| ScopeVar of ScopeVar.t Marked.pos
| SubScopeVar of
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
type location = scopelang glocation
module LocationSet : Set.S with type elt = location Marked.pos
(** {1 Abstract syntax tree} *)
type typ =
| TLit of Dcalc.Ast.typ_lit
| TStruct of StructName.t
| TEnum of EnumName.t
| TArrow of typ Marked.pos * typ Marked.pos
| TArray of typ
| TAny
type expr = (scopelang, untyped mark) gexpr
module Typ : Set.OrderedType with type t = typ
type marked_expr = expr Marked.pos
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
and expr =
| ELocation of location
| EVar of expr Bindlib.var
| EStruct of StructName.t * marked_expr StructFieldMap.t
| EStructAccess of marked_expr * StructFieldName.t * StructName.t
| EEnumInj of marked_expr * EnumConstructor.t * EnumName.t
| EMatch of marked_expr * EnumName.t * marked_expr EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of (expr, marked_expr) Bindlib.mbinder * typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module Expr : Set.OrderedType with type t = expr
module ExprMap : Map.S with type key = expr
val locations_used : expr Marked.pos -> LocationSet.t
val locations_used : expr -> LocationSet.t
(** This type characterizes the three levels of visibility for a given scope
variable with regards to the scope's input and possible redefinitions inside
@ -115,75 +69,17 @@ type io = {
(** Characterization of the input/output status of a scope variable. *)
type rule =
| Definition of location Marked.pos * typ Marked.pos * io * expr Marked.pos
| Assertion of expr Marked.pos
| Definition of location Marked.pos * typ * io * expr
| Assertion of expr
| Call of ScopeName.t * SubScopeName.t
type scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : (typ Marked.pos * io) ScopeVarMap.t;
scope_sig : (typ * io) ScopeVarMap.t;
scope_decl_rules : rule list;
}
type struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
type program = {
program_scopes : scope_decl ScopeMap.t;
program_enums : enum_ctx;
program_structs : struct_ctx;
program_ctx : decl_ctx;
}
(** {1 Variable helpers} *)
module Var : sig
type t = expr Bindlib.var
val make : string -> t
val compare : t -> t -> int
end
module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Marked.pos -> expr Marked.pos Bindlib.box
val make_abs :
vars ->
expr Marked.pos Bindlib.box ->
typ Marked.pos list ->
Pos.t ->
expr Marked.pos Bindlib.box
val make_app :
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
Pos.t ->
expr Marked.pos Bindlib.box
val make_let_in :
Var.t ->
typ Marked.pos ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box
val make_default :
?pos:Pos.t ->
expr Marked.pos list ->
expr Marked.pos ->
expr Marked.pos ->
expr Marked.pos
(** [make_default ?pos exceptions just cons] builds a term semantically
equivalent to [<exceptions | just :- cons>] (the [EDefault] constructor)
while avoiding redundant nested constructions. The position is extracted
from [just] by default.
Note that, due to the simplifications taking place, the result might not be
of the form [EDefault]:
- [<true :- x>] is rewritten as [x]
- [<ex | true :- def>], when [def] is a default term [<j :- c>] without
exceptions, is collapsed into [<ex | def>]
- [<ex | false :- _>], when [ex] is a single exception, is rewritten as [ex] *)

72
compiler/scopelang/dependency.ml
View File

@ -18,13 +18,14 @@
program. Vertices are functions, x -> y if x is used in the definition of y. *)
open Utils
open Shared_ast
module SVertex = struct
type t = Ast.ScopeName.t
type t = ScopeName.t
let hash x = Ast.ScopeName.hash x
let compare = Ast.ScopeName.compare
let equal x y = Ast.ScopeName.compare x y = 0
let hash x = ScopeName.hash x
let compare = ScopeName.compare
let equal x y = ScopeName.compare x y = 0
end
(** On the edges, the label is the expression responsible for the use of the
@ -62,13 +63,13 @@ let build_program_dep_graph (prgm : Ast.program) : SDependencies.t =
if subscope = scope_name then
Errors.raise_spanned_error
(Marked.get_mark
(Ast.ScopeName.get_info scope.Ast.scope_decl_name))
(ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
Ast.ScopeName.format_t scope.Ast.scope_decl_name
ScopeName.format_t scope.Ast.scope_decl_name
else
Ast.ScopeMap.add subscope
(Marked.get_mark (Ast.SubScopeName.get_info subindex))
(Marked.get_mark (SubScopeName.get_info subindex))
acc)
Ast.ScopeMap.empty scope.Ast.scope_decl_rules
in
@ -90,14 +91,13 @@ let check_for_cycle_in_scope (g : SDependencies.t) : unit =
(List.map
(fun v ->
let var_str, var_info =
( Format.asprintf "%a" Ast.ScopeName.format_t v,
Ast.ScopeName.get_info v )
Format.asprintf "%a" ScopeName.format_t v, ScopeName.get_info v
in
let succs = SDependencies.succ_e g v in
let _, edge_pos, succ =
List.find (fun (_, _, succ) -> List.mem succ scc) succs
in
let succ_str = Format.asprintf "%a" Ast.ScopeName.format_t succ in
let succ_str = Format.asprintf "%a" ScopeName.format_t succ in
[
( Some ("Cycle variable " ^ var_str ^ ", declared:"),
Marked.get_mark var_info );
@ -112,39 +112,37 @@ let check_for_cycle_in_scope (g : SDependencies.t) : unit =
Errors.raise_multispanned_error spans
"Cyclic dependency detected between scopes!"
let get_scope_ordering (g : SDependencies.t) : Ast.ScopeName.t list =
let get_scope_ordering (g : SDependencies.t) : ScopeName.t list =
List.rev (STopologicalTraversal.fold (fun sd acc -> sd :: acc) g [])
module TVertex = struct
type t = Struct of Ast.StructName.t | Enum of Ast.EnumName.t
type t = Struct of StructName.t | Enum of EnumName.t
let hash x =
match x with
| Struct x -> Ast.StructName.hash x
| Enum x -> Ast.EnumName.hash x
match x with Struct x -> StructName.hash x | Enum x -> EnumName.hash x
let compare x y =
match x, y with
| Struct x, Struct y -> Ast.StructName.compare x y
| Enum x, Enum y -> Ast.EnumName.compare x y
| Struct x, Struct y -> StructName.compare x y
| Enum x, Enum y -> EnumName.compare x y
| Struct _, Enum _ -> 1
| Enum _, Struct _ -> -1
let equal x y =
match x, y with
| Struct x, Struct y -> Ast.StructName.compare x y = 0
| Enum x, Enum y -> Ast.EnumName.compare x y = 0
| Struct x, Struct y -> StructName.compare x y = 0
| Enum x, Enum y -> EnumName.compare x y = 0
| _ -> false
let format_t (fmt : Format.formatter) (x : t) : unit =
match x with
| Struct x -> Ast.StructName.format_t fmt x
| Enum x -> Ast.EnumName.format_t fmt x
| Struct x -> StructName.format_t fmt x
| Enum x -> EnumName.format_t fmt x
let get_info (x : t) =
match x with
| Struct x -> Ast.StructName.get_info x
| Enum x -> Ast.EnumName.get_info x
| Struct x -> StructName.get_info x
| Enum x -> EnumName.get_info x
end
module TVertexSet = Set.Make (TVertex)
@ -166,22 +164,26 @@ module TTopologicalTraversal = Graph.Topological.Make (TDependencies)
module TSCC = Graph.Components.Make (TDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
let rec get_structs_or_enums_in_type (t : Ast.typ Marked.pos) : TVertexSet.t =
let rec get_structs_or_enums_in_type (t : typ) : TVertexSet.t =
match Marked.unmark t with
| Ast.TStruct s -> TVertexSet.singleton (TVertex.Struct s)
| Ast.TEnum e -> TVertexSet.singleton (TVertex.Enum e)
| Ast.TArrow (t1, t2) ->
| TStruct s -> TVertexSet.singleton (TVertex.Struct s)
| TEnum e -> TVertexSet.singleton (TVertex.Enum e)
| TArrow (t1, t2) ->
TVertexSet.union
(get_structs_or_enums_in_type t1)
(get_structs_or_enums_in_type t2)
| Ast.TLit _ | Ast.TAny -> TVertexSet.empty
| Ast.TArray t1 -> get_structs_or_enums_in_type (Marked.same_mark_as t1 t)
| TLit _ | TAny -> TVertexSet.empty
| TOption t1 | TArray t1 -> get_structs_or_enums_in_type t1
| TTuple ts ->
List.fold_left
(fun acc t -> TVertexSet.union acc (get_structs_or_enums_in_type t))
TVertexSet.empty ts
let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
TDependencies.t =
let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
=
let g = TDependencies.empty in
let g =
Ast.StructMap.fold
StructMap.fold
(fun s fields g ->
List.fold_left
(fun g (_, typ) ->
@ -205,7 +207,7 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
structs g
in
let g =
Ast.EnumMap.fold
EnumMap.fold
(fun e cases g ->
List.fold_left
(fun g (_, typ) ->
@ -230,8 +232,8 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
in
g
let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
TVertex.t list =
let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
=
let g = build_type_graph structs enums in
(* if there is a cycle, there will be an strongly connected component of
cardinality > 1 *)

15
compiler/scopelang/dependency.mli
View File

@ -18,25 +18,26 @@
program. Vertices are functions, x -> y if x is used in the definition of y. *)
open Utils
open Shared_ast
(** {1 Scope dependencies} *)
(** On the edges, the label is the expression responsible for the use of the
function *)
module SDependencies :
Graph.Sig.P with type V.t = Ast.ScopeName.t and type E.label = Pos.t
Graph.Sig.P with type V.t = ScopeName.t and type E.label = Pos.t
val build_program_dep_graph : Ast.program -> SDependencies.t
val check_for_cycle_in_scope : SDependencies.t -> unit
val get_scope_ordering : SDependencies.t -> Ast.ScopeName.t list
val get_scope_ordering : SDependencies.t -> ScopeName.t list
(** {1 Type dependencies} *)
module TVertex : sig
type t = Struct of Ast.StructName.t | Enum of Ast.EnumName.t
type t = Struct of StructName.t | Enum of EnumName.t
val format_t : Format.formatter -> t -> unit
val get_info : t -> Ast.StructName.info
val get_info : t -> StructName.info
include Graph.Sig.COMPARABLE with type t := t
end
@ -48,6 +49,6 @@ module TVertexSet : Set.S with type elt = TVertex.t
module TDependencies :
Graph.Sig.P with type V.t = TVertex.t and type E.label = Pos.t
val get_structs_or_enums_in_type : Ast.typ Marked.pos -> TVertexSet.t
val build_type_graph : Ast.struct_ctx -> Ast.enum_ctx -> TDependencies.t
val check_type_cycles : Ast.struct_ctx -> Ast.enum_ctx -> TVertex.t list
val get_structs_or_enums_in_type : typ -> TVertexSet.t
val build_type_graph : struct_ctx -> enum_ctx -> TDependencies.t
val check_type_cycles : struct_ctx -> enum_ctx -> TVertex.t list

279
compiler/scopelang/print.ml
View File

@ -15,267 +15,104 @@
the License. *)
open Utils
open Shared_ast
open Ast
let needs_parens (e : expr Marked.pos) : bool =
match Marked.unmark e with EAbs _ -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let format_location (fmt : Format.formatter) (l : location) : unit =
match l with
| ScopeVar v -> Format.fprintf fmt "%a" ScopeVar.format_t (Marked.unmark v)
| SubScopeVar (_, subindex, subvar) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Marked.unmark subindex)
ScopeVar.format_t (Marked.unmark subvar)
let typ_needs_parens (e : typ Marked.pos) : bool =
match Marked.unmark e with TArrow _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : typ Marked.pos) : unit =
let format_typ_with_parens (fmt : Format.formatter) (t : typ Marked.pos) =
if typ_needs_parens t then
Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_typ
t Dcalc.Print.format_punctuation ")"
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
| TLit l -> Dcalc.Print.format_tlit fmt l
| TStruct s -> Format.fprintf fmt "%a" Ast.StructName.format_t s
| TEnum e -> Format.fprintf fmt "%a" Ast.EnumName.format_t e
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens t1
Dcalc.Print.format_operator "→" format_typ t2
| TArray t1 ->
Format.fprintf fmt "@[%a@ %a@]" format_typ
(Marked.same_mark_as t1 typ)
Dcalc.Print.format_base_type "array"
| TAny -> Format.fprintf fmt "any"
let rec format_expr
?(debug : bool = false)
let struc
ctx
(fmt : Format.formatter)
(e : expr Marked.pos) : unit =
let format_expr = format_expr ~debug in
let format_with_parens (fmt : Format.formatter) (e : expr Marked.pos) =
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
| ELocation l -> Format.fprintf fmt "%a" format_location l
| EVar v -> Format.fprintf fmt "%a" format_var v
| ELit l -> Format.fprintf fmt "%a" Dcalc.Print.format_lit l
| EStruct (name, fields) ->
Format.fprintf fmt " @[<hov 2>%a@ %a@ %a@ %a@]" Ast.StructName.format_t name
Dcalc.Print.format_punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";")
(fun fmt (field_name, field_expr) ->
Format.fprintf fmt "%a%a%a%a@ %a" Dcalc.Print.format_punctuation "\""
Ast.StructFieldName.format_t field_name
Dcalc.Print.format_punctuation "\"" Dcalc.Print.format_punctuation
"=" format_expr field_expr))
(Ast.StructFieldMap.bindings fields)
Dcalc.Print.format_punctuation "}"
| EStructAccess (e1, field, _) ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1
Dcalc.Print.format_punctuation "." Dcalc.Print.format_punctuation "\""
Ast.StructFieldName.format_t field Dcalc.Print.format_punctuation "\""
| EEnumInj (e1, cons, _) ->
Format.fprintf fmt "%a@ %a" Ast.EnumConstructor.format_t cons format_expr e1
| EMatch (e1, _, cases) ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]"
Dcalc.Print.format_keyword "match" format_expr e1
Dcalc.Print.format_keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cons_name, case_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]"
Dcalc.Print.format_punctuation "|"
Dcalc.Print.format_enum_constructor cons_name
Dcalc.Print.format_punctuation "→" format_expr case_expr))
(Ast.EnumConstructorMap.bindings cases)
| EApp ((EAbs (binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args in
Format.fprintf fmt "@[%a%a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@ %a@\n@]"
Dcalc.Print.format_keyword "let" format_var x
Dcalc.Print.format_punctuation ":" format_typ tau
Dcalc.Print.format_punctuation "=" format_expr arg
Dcalc.Print.format_keyword "in"))
xs_tau_arg format_expr body
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]"
Dcalc.Print.format_punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
(fun fmt (x, tau) ->
Format.fprintf fmt "@[%a%a%a@ %a%a@]" Dcalc.Print.format_punctuation
"(" format_var x Dcalc.Print.format_punctuation ":" format_typ tau
Dcalc.Print.format_punctuation ")"))
xs_tau Dcalc.Print.format_punctuation "→" format_expr body
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1
Dcalc.Print.format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
format_expr fmt arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop op
format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[%a@ %a@]" format_expr f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]"
Dcalc.Print.format_keyword "if" format_expr e1 Dcalc.Print.format_keyword
"then" format_expr e2 Dcalc.Print.format_keyword "else" format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop op
| EDefault (excepts, just, cons) ->
if List.length excepts = 0 then
Format.fprintf fmt "@[%a%a %a@ %a%a@]" Dcalc.Print.format_punctuation "⟨"
format_expr just Dcalc.Print.format_punctuation "⊢" format_expr cons
Dcalc.Print.format_punctuation "⟩"
else
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a %a@ %a%a@]"
Dcalc.Print.format_punctuation "⟨"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
format_expr)
excepts Dcalc.Print.format_punctuation "|" format_expr just
Dcalc.Print.format_punctuation "⊢" format_expr cons
Dcalc.Print.format_punctuation "⟩"
| ErrorOnEmpty e' ->
Format.fprintf fmt "error_empty@ %a" format_with_parens e'
| EArray es ->
Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Dcalc.Print.format_punctuation fmt ";")
(fun fmt e -> Format.fprintf fmt "@[%a@]" format_expr e))
es Dcalc.Print.format_punctuation "]"
let format_struct
(fmt : Format.formatter)
((name, fields) : StructName.t * (StructFieldName.t * typ Marked.pos) list)
: unit =
Format.fprintf fmt "%a %a %a %a@\n@[<hov 2> %a@]@\n%a"
Dcalc.Print.format_keyword "type" StructName.format_t name
Dcalc.Print.format_punctuation "=" Dcalc.Print.format_punctuation "{"
((name, fields) : StructName.t * (StructFieldName.t * typ) list) : unit =
Format.fprintf fmt "%a %a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword "type"
StructName.format_t name Print.punctuation "=" Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a%a %a" StructFieldName.format_t field_name
Dcalc.Print.format_punctuation ":" format_typ typ))
fields Dcalc.Print.format_punctuation "}"
Print.punctuation ":" (Print.typ ctx) typ))
fields Print.punctuation "}"
let format_enum
let enum
ctx
(fmt : Format.formatter)
((name, cases) : EnumName.t * (EnumConstructor.t * typ Marked.pos) list) :
unit =
Format.fprintf fmt "%a %a %a @\n@[<hov 2> %a@]" Dcalc.Print.format_keyword
"type" EnumName.format_t name Dcalc.Print.format_punctuation "="
((name, cases) : EnumName.t * (EnumConstructor.t * typ) list) : unit =
Format.fprintf fmt "%a %a %a @\n@[<hov 2> %a@]" Print.keyword "type"
EnumName.format_t name Print.punctuation "="
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a %a%a %a" Dcalc.Print.format_punctuation "|"
EnumConstructor.format_t field_name Dcalc.Print.format_punctuation
":" format_typ typ))
Format.fprintf fmt "%a %a%a %a" Print.punctuation "|"
EnumConstructor.format_t field_name Print.punctuation ":"
(Print.typ ctx) typ))
cases
let format_scope
?(debug : bool = false)
(fmt : Format.formatter)
((name, decl) : ScopeName.t * scope_decl) : unit =
let scope ?(debug = false) ctx fmt (name, decl) =
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
Dcalc.Print.format_keyword "let" Dcalc.Print.format_keyword "scope"
ScopeName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
Print.keyword "let" Print.keyword "scope" ScopeName.format_t name
(Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun fmt (scope_var, (typ, vis)) ->
Format.fprintf fmt "%a%a%a %a%a%a%a%a" Dcalc.Print.format_punctuation
"(" ScopeVar.format_t scope_var Dcalc.Print.format_punctuation ":"
format_typ typ Dcalc.Print.format_punctuation "|"
Dcalc.Print.format_keyword
Format.fprintf fmt "%a%a%a %a%a%a%a%a" Print.punctuation "("
ScopeVar.format_t scope_var Print.punctuation ":" (Print.typ ctx) typ
Print.punctuation "|" Print.keyword
(match Marked.unmark vis.io_input with
| NoInput -> "internal"
| OnlyInput -> "input"
| Reentrant -> "context")
(if Marked.unmark vis.io_output then fun fmt () ->
Format.fprintf fmt "%a@,%a" Dcalc.Print.format_punctuation "|"
Dcalc.Print.format_keyword "output"
Format.fprintf fmt "%a@,%a" Print.punctuation "|" Print.keyword
"output"
else fun fmt () -> Format.fprintf fmt "@<0>")
() Dcalc.Print.format_punctuation ")"))
() Print.punctuation ")"))
(ScopeVarMap.bindings decl.scope_sig)
Dcalc.Print.format_punctuation "="
Print.punctuation "="
(Format.pp_print_list
~pp_sep:(fun fmt () ->
Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";")
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Print.punctuation ";")
(fun fmt rule ->
match rule with
| Definition (loc, typ, _, e) ->
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a@ %a@]"
Dcalc.Print.format_keyword "let" format_location
(Marked.unmark loc) Dcalc.Print.format_punctuation ":" format_typ
typ Dcalc.Print.format_punctuation "="
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a@ %a@]" Print.keyword
"let" Print.location (Marked.unmark loc) Print.punctuation ":"
(Print.typ ctx) typ Print.punctuation "="
(fun fmt e ->
match Marked.unmark loc with
| SubScopeVar _ -> format_expr fmt e
| ScopeVar v -> (
| SubScopeVar _ -> Print.naked_expr ctx fmt e
| ScopelangScopeVar v -> (
match
Marked.unmark
(snd (ScopeVarMap.find (Marked.unmark v) decl.scope_sig))
.io_input
with
| Reentrant ->
Format.fprintf fmt "%a@ %a" Dcalc.Print.format_operator
"reentrant or by default" (format_expr ~debug) e
| _ -> Format.fprintf fmt "%a" (format_expr ~debug) e))
Format.fprintf fmt "%a@ %a" Print.operator
"reentrant or by default"
(Print.naked_expr ~debug ctx)
e
| _ -> Format.fprintf fmt "%a" (Print.naked_expr ~debug ctx) e))
e
| Assertion e ->
Format.fprintf fmt "%a %a" Dcalc.Print.format_keyword "assert"
(format_expr ~debug) e
Format.fprintf fmt "%a %a" Print.keyword "assert"
(Print.naked_expr ~debug ctx)
e
| Call (scope_name, subscope_name) ->
Format.fprintf fmt "%a %a%a%a%a" Dcalc.Print.format_keyword "call"
ScopeName.format_t scope_name Dcalc.Print.format_punctuation "["
SubScopeName.format_t subscope_name Dcalc.Print.format_punctuation
"]"))
Format.fprintf fmt "%a %a%a%a%a" Print.keyword "call"
ScopeName.format_t scope_name Print.punctuation "["
SubScopeName.format_t subscope_name Print.punctuation "]"))
decl.scope_decl_rules
let format_program
?(debug : bool = false)
(fmt : Format.formatter)
(p : program) : unit =
Format.fprintf fmt "%a%a%a%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
format_struct)
(StructMap.bindings p.program_structs)
(fun fmt () ->
if StructMap.is_empty p.program_structs then Format.fprintf fmt ""
else Format.fprintf fmt "\n\n")
let program ?(debug : bool = false) (fmt : Format.formatter) (p : program) :
unit =
let ctx = p.program_ctx in
let pp_sep fmt () =
Format.pp_print_cut fmt ();
Format.pp_print_cut fmt ()
in
Format.fprintf fmt "@[<v>%a%a%a%a%a@]"
(Format.pp_print_list ~pp_sep (struc ctx))
(StructMap.bindings ctx.ctx_structs)
(if StructMap.is_empty ctx.ctx_structs then fun _ _ -> () else pp_sep)
()
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
format_enum)
(EnumMap.bindings p.program_enums)
(fun fmt () ->
if EnumMap.is_empty p.program_enums then Format.fprintf fmt ""
else Format.fprintf fmt "\n\n")
(Format.pp_print_list ~pp_sep (enum ctx))
(EnumMap.bindings ctx.ctx_enums)
(if EnumMap.is_empty ctx.ctx_enums then fun _ _ -> () else pp_sep)
()
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(format_scope ~debug))
(Format.pp_print_list ~pp_sep (scope ~debug ctx))
(ScopeMap.bindings p.program_scopes)

19
compiler/scopelang/print.mli
View File

@ -14,25 +14,14 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_location : Format.formatter -> Ast.location -> unit
val format_typ : Format.formatter -> Ast.typ Marked.pos -> unit
val format_expr :
val scope :
?debug:bool (** [true] for debug printing *) ->
Shared_ast.decl_ctx ->
Format.formatter ->
Ast.expr Marked.pos ->
Shared_ast.ScopeName.t * Ast.scope_decl ->
unit
val format_scope :
?debug:bool (** [true] for debug printing *) ->
Format.formatter ->
Ast.ScopeName.t * Ast.scope_decl ->
unit
val format_program :
val program :
?debug:bool (** [true] for debug printing *) ->
Format.formatter ->
Ast.program ->

547
compiler/scopelang/scope_to_dcalc.ml
View File

File diff suppressed because it is too large Load Diff

3
compiler/scopelang/scope_to_dcalc.mli
View File

@ -17,7 +17,8 @@
(** Scope language to default calculus translator *)
val translate_program :
Ast.program -> Dcalc.Ast.untyped Dcalc.Ast.program * Dependency.TVertex.t list
Ast.program ->
Shared_ast.untyped Dcalc.Ast.program * Dependency.TVertex.t list
(** Usage [translate_program p] returns a tuple [(new_program, types_list)]
where [new_program] is the map of translated scopes. Finally, [types_list]
is a list of all types (structs and enums) used in the program, correctly

237
compiler/utils/astgen.ml → compiler/shared_ast/definitions.ml
View File

@ -15,6 +15,12 @@
License for the specific language governing permissions and limitations under
the License. *)
(** This module defines generic types for types, literals and expressions shared
through several of the different ASTs. *)
(* Doesn't define values, so OK to have without an mli *)
open Utils
module Runtime = Runtime_ocaml.Runtime
module ScopeName : Uid.Id with type info = Uid.MarkedString.info =
@ -36,7 +42,25 @@ module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info =
module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
(** Abstract syntax tree for the default calculus *)
(** Only used by desugared/scopelang *)
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar)
module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar)
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module StructFieldMap : Map.S with type key = StructFieldName.t =
Map.Make (StructFieldName)
module EnumConstructorMap : Map.S with type key = EnumConstructor.t =
Map.Make (EnumConstructor)
module StateName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
(** {1 Abstract syntax tree} *)
@ -44,14 +68,16 @@ module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type marked_typ = typ Marked.pos
type typ = naked_typ Marked.pos
and typ =
and naked_typ =
| TLit of typ_lit
| TTuple of marked_typ list * StructName.t option
| TEnum of marked_typ list * EnumName.t
| TArrow of marked_typ * marked_typ
| TArray of marked_typ
| TTuple of typ list
| TStruct of StructName.t
| TEnum of EnumName.t
| TOption of typ
| TArrow of typ * typ
| TArray of typ
| TAny
(** {2 Constants and operators} *)
@ -87,7 +113,7 @@ type binop =
| Filter
type log_entry =
| VarDef of typ
| VarDef of naked_typ
(** During code generation, we need to know the type of the variable being
logged for embedding *)
| BeginCall
@ -121,8 +147,7 @@ type desugared = [ `Desugared ]
type scopelang = [ `Scopelang ]
type dcalc = [ `Dcalc ]
type lcalc = [ `Lcalc ]
type scalc = [ `Scalc ]
type any = [ desugared | scopelang | dcalc | lcalc | scalc ]
type 'a any = [< desugared | scopelang | dcalc | lcalc ] as 'a
(** Literals are the same throughout compilation except for the [LEmptyError]
case which is eliminated midway through. *)
@ -136,99 +161,119 @@ type 'a glit =
| LDate : date -> 'a glit
| LDuration : duration -> 'a glit
type ('a, 't) marked_gexpr = (('a, 't) gexpr, 't) Marked.t
(** Locations are handled differently in [desugared] and [scopelang] *)
type 'a glocation =
| DesugaredScopeVar :
ScopeVar.t Marked.pos * StateName.t option
-> desugared glocation
| ScopelangScopeVar : ScopeVar.t Marked.pos -> scopelang glocation
| SubScopeVar :
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
-> [< desugared | scopelang ] glocation
type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Marked.t
(** General expressions: groups all expression cases of the different ASTs, and
uses a GADT to eliminate irrelevant cases for each one. The ['t] annotations
are also totally unconstrained at this point. The dcalc exprs, for example,
are then defined with [type expr = dcalc gexpr] plus the annotations. *)
are then defined with [type naked_expr = dcalc naked_gexpr] plus the
annotations.
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax *)
and ('a, 't) gexpr =
A few tips on using this GADT:
- To write a function that handles cases from different ASTs, explicit the
type variables: [fun (type a) (x: a naked_gexpr) -> ...]
- For recursive functions, you may need to additionally explicit the
generalisation of the variable: [let rec f: type a . a naked_gexpr -> ...] *)
and ('a, 't) naked_gexpr =
(* Constructors common to all ASTs *)
| ELit : 'a glit -> ('a, 't) gexpr
| EApp : ('a, 't) marked_gexpr * ('a, 't) marked_gexpr list -> ('a, 't) gexpr
| EOp : operator -> ('a, 't) gexpr
| EArray : ('a, 't) marked_gexpr list -> ('a, 't) gexpr
(* All but statement calculus *)
| EVar :
('a, 't) gexpr Bindlib.var
-> (([< desugared | scopelang | dcalc | lcalc ] as 'a), 't) gexpr
| ELit : 'a glit -> ('a any, 't) naked_gexpr
| EApp : ('a, 't) gexpr * ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| EOp : operator -> ('a any, 't) naked_gexpr
| EArray : ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| EVar : ('a, 't) naked_gexpr Bindlib.var -> ('a any, 't) naked_gexpr
| EAbs :
(('a, 't) gexpr, ('a, 't) marked_gexpr) Bindlib.mbinder
* typ Marked.pos list
-> (([< desugared | scopelang | dcalc | lcalc ] as 'a), 't) gexpr
(('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder * typ list
-> ('a any, 't) naked_gexpr
| EIfThenElse :
('a, 't) marked_gexpr * ('a, 't) marked_gexpr * ('a, 't) marked_gexpr
-> (([< desugared | scopelang | dcalc | lcalc ] as 'a), 't) gexpr
(* (* Early stages *) | ELocation: location -> ([< desugared | scopelang ] as
'a, 't) gexpr | EStruct: StructName.t * ('a, 't) marked_gexpr
StructFieldMap.t -> ([< desugared | scopelang ] as 'a, 't) gexpr |
EStructAccess: ('a, 't) marked_gexpr * StructFieldName.t * StructName.t ->
([< desugared | scopelang ] as 'a, 't) gexpr | EEnumInj: ('a, 't)
marked_gexpr * EnumConstructor.t * EnumName.t -> ([< desugared | scopelang
] as 'a, 't) gexpr | EMatchS: ('a, 't) marked_gexpr * EnumName.t * ('a, 't)
marked_gexpr EnumConstructorMap.t -> ([< desugared | scopelang ] as 'a, 't)
gexpr *)
('a, 't) gexpr * ('a, 't) gexpr * ('a, 't) gexpr
-> ('a any, 't) naked_gexpr
(* Early stages *)
| ELocation :
'a glocation
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EStruct :
StructName.t * ('a, 't) gexpr StructFieldMap.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EStructAccess :
('a, 't) gexpr * StructFieldName.t * StructName.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EEnumInj :
('a, 't) gexpr * EnumConstructor.t * EnumName.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EMatchS :
('a, 't) gexpr * EnumName.t * ('a, 't) gexpr EnumConstructorMap.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
(* Lambda-like *)
| ETuple :
('a, 't) marked_gexpr list * StructName.t option
-> (([< dcalc | lcalc ] as 'a), 't) gexpr
('a, 't) gexpr list * StructName.t option
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| ETupleAccess :
('a, 't) marked_gexpr * int * StructName.t option * typ Marked.pos list
-> (([< dcalc | lcalc ] as 'a), 't) gexpr
('a, 't) gexpr * int * StructName.t option * typ list
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| EInj :
('a, 't) marked_gexpr * int * EnumName.t * typ Marked.pos list
-> (([< dcalc | lcalc ] as 'a), 't) gexpr
('a, 't) gexpr * int * EnumName.t * typ list
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| EMatch :
('a, 't) marked_gexpr * ('a, 't) marked_gexpr list * EnumName.t
-> (([< dcalc | lcalc ] as 'a), 't) gexpr
| EAssert : ('a, 't) marked_gexpr -> (([< dcalc | lcalc ] as 'a), 't) gexpr
('a, 't) gexpr * ('a, 't) gexpr list * EnumName.t
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| EAssert : ('a, 't) gexpr -> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
(* Default terms *)
| EDefault :
('a, 't) marked_gexpr list * ('a, 't) marked_gexpr * ('a, 't) marked_gexpr
-> (([< desugared | scopelang | dcalc ] as 'a), 't) gexpr
('a, 't) gexpr list * ('a, 't) gexpr * ('a, 't) gexpr
-> (([< desugared | scopelang | dcalc ] as 'a), 't) naked_gexpr
| ErrorOnEmpty :
('a, 't) marked_gexpr
-> (([< desugared | scopelang | dcalc ] as 'a), 't) gexpr
('a, 't) gexpr
-> (([< desugared | scopelang | dcalc ] as 'a), 't) naked_gexpr
(* Lambda calculus with exceptions *)
| ERaise : except -> ((lcalc as 'a), 't) gexpr
| ERaise : except -> ((lcalc as 'a), 't) naked_gexpr
| ECatch :
('a, 't) marked_gexpr * except * ('a, 't) marked_gexpr
-> ((lcalc as 'a), 't) gexpr
('a, 't) gexpr * except * ('a, 't) gexpr
-> ((lcalc as 'a), 't) naked_gexpr
(* (\* Statement calculus *\)
* | ESVar: LocalName.t -> (scalc as 'a, 't) gexpr
* | ESStruct: ('a, 't) marked_gexpr list * StructName.t -> (scalc as 'a, 't) gexpr
* | ESStructFieldAccess: ('a, 't) marked_gexpr * StructFieldName.t * StructName.t -> (scalc as 'a, 't) gexpr
* | ESInj: ('a, 't) marked_gexpr * EnumConstructor.t * EnumName.t -> (scalc as 'a, 't) gexpr
* | ESFunc: TopLevelName.t -> (scalc as 'a, 't) gexpr *)
type 'a box = 'a Bindlib.box
type ('e, 'b) binder = (('a, 't) naked_gexpr, 'b) Bindlib.binder
constraint 'e = ('a, 't) gexpr
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax *)
type ('e, 'b) mbinder = (('a, 't) naked_gexpr, 'b) Bindlib.mbinder
constraint 'e = ('a, 't) gexpr
(** {2 Markings} *)
type untyped = { pos : Pos.t } [@@ocaml.unboxed]
type typed = { pos : Pos.t; ty : marked_typ }
(* type inferring = { pos : Pos.t; uf : Infer.unionfind_typ } *)
type typed = { pos : Pos.t; ty : typ }
(** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when
appropriate. Expected to fill the ['t] parameter of [gexpr] and
[marked_gexpr] *)
appropriate. Expected to fill the ['t] parameter of [naked_gexpr] and
[gexpr] (a ['t] annotation different from this type is used in the middle of
the typing processing, but all visible ASTs should otherwise use this. *)
type _ mark = Untyped : untyped -> untyped mark | Typed : typed -> typed mark
(* | Inferring : inferring -> inferring mark *)
type ('a, 'm) marked = ('a, 'm mark) Marked.t
(** Useful for errors and printing, for example *)
type any_marked_expr =
| AnyExpr : ([< any ], 'm mark) marked_gexpr -> any_marked_expr
type any_expr = AnyExpr : (_ any, _ mark) gexpr -> any_expr
(** {2 Higher-level program structure} *)
(** Constructs scopes and programs on top of expressions. We may use the [gexpr]
type above at some point, but at the moment this is polymorphic in the types
of the expressions. Their markings are constrained to belong to the [mark]
GADT defined above. *)
(** Constructs scopes and programs on top of expressions. The ['e] type
parameter throughout is expected to match instances of the [naked_gexpr]
type defined above. Markings are constrained to the [mark] GADT defined
above. Note that this structure is at the moment only relevant for [dcalc]
and [lcalc], as [scopelang] has its own scope structure, as the name
implies. *)
(** This kind annotation signals that the let-binding respects a structural
invariant. These invariants concern the shape of the expression in the
@ -243,51 +288,51 @@ type scope_let_kind =
| DestructuringSubScopeResults (** [let s.x = result.x ]**)
| Assertion (** [let _ = assert e]*)
type ('expr, 'm) scope_let = {
type 'e scope_let = {
scope_let_kind : scope_let_kind;
scope_let_typ : marked_typ;
scope_let_expr : ('expr, 'm) marked;
scope_let_next : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
scope_let_typ : typ;
scope_let_expr : 'e;
scope_let_next : ('e, 'e scope_body_expr) binder;
scope_let_pos : Pos.t;
}
constraint 'e = (_ any, _ mark) gexpr
(** This type is parametrized by the expression type so it can be reused in
later intermediate representations. *)
(** A scope let-binding has all the information necessary to make a proper
let-binding expression, plus an annotation for the kind of the let-binding
that comes from the compilation of a {!module: Scopelang.Ast} statement. *)
and ('expr, 'm) scope_body_expr =
| Result of ('expr, 'm) marked
| ScopeLet of ('expr, 'm) scope_let
and 'e scope_body_expr =
| Result of 'e
| ScopeLet of 'e scope_let
constraint 'e = (_ any, _ mark) gexpr
type ('expr, 'm) scope_body = {
type 'e scope_body = {
scope_body_input_struct : StructName.t;
scope_body_output_struct : StructName.t;
scope_body_expr : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
scope_body_expr : ('e, 'e scope_body_expr) binder;
}
constraint 'e = (_ any, _ mark) gexpr
(** Instead of being a single expression, we give a little more ad-hoc structure
to the scope body by decomposing it in an ordered list of let-bindings, and
a result expression that uses the let-binded variables. The first binder is
the argument of type [scope_body_input_struct]. *)
type ('expr, 'm) scope_def = {
type 'e scope_def = {
scope_name : ScopeName.t;
scope_body : ('expr, 'm) scope_body;
scope_next : ('expr, ('expr, 'm) scopes) Bindlib.binder;
scope_body : 'e scope_body;
scope_next : ('e, 'e scopes) binder;
}
constraint 'e = (_ any, _ mark) gexpr
(** Finally, we do the same transformation for the whole program for the kinded
lets. This permit us to use bindlib variables for scopes names. *)
and ('expr, 'm) scopes = Nil | ScopeDef of ('expr, 'm) scope_def
and 'e scopes =
| Nil
| ScopeDef of 'e scope_def
constraint 'e = (_ any, _ mark) gexpr
type struct_ctx = (StructFieldName.t * marked_typ) list StructMap.t
type decl_ctx = {
ctx_enums : (EnumConstructor.t * marked_typ) list EnumMap.t;
ctx_structs : struct_ctx;
}
type ('expr, 'm) program_generic = {
decl_ctx : decl_ctx;
scopes : ('expr, 'm) scopes;
}
type struct_ctx = (StructFieldName.t * typ) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
type 'e program = { decl_ctx : decl_ctx; scopes : 'e scopes }

6
compiler/shared_ast/dune Normal file
View File

@ -0,0 +1,6 @@
(library
(name shared_ast)
(public_name catala.shared_ast)
(flags
(:standard -short-paths))
(libraries bindlib unionFind utils catala.runtime_ocaml))

758
compiler/shared_ast/expr.ml Normal file
View File

@ -0,0 +1,758 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Definitions
(** Functions handling the types of [shared_ast] *)
(* Basic block constructors *)
let evar v mark = Bindlib.box_apply (Marked.mark mark) (Bindlib.box_var v)
let etuple args s mark =
Bindlib.box_apply (fun args -> ETuple (args, s), mark) (Bindlib.box_list args)
let etupleaccess e1 i s typs mark =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), mark) e1
let einj e1 i e_name typs mark =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), mark) e1
let ematch arg arms e_name mark =
Bindlib.box_apply2
(fun arg arms -> EMatch (arg, arms, e_name), mark)
arg (Bindlib.box_list arms)
let earray args mark =
Bindlib.box_apply (fun args -> EArray args, mark) (Bindlib.box_list args)
let elit l mark = Bindlib.box (ELit l, mark)
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) binder
let eapp e1 args mark =
Bindlib.box_apply2
(fun e1 args -> EApp (e1, args), mark)
e1 (Bindlib.box_list args)
let eassert e1 mark = Bindlib.box_apply (fun e1 -> EAssert e1, mark) e1
let eop op mark = Bindlib.box (EOp op, mark)
let edefault excepts just cons mark =
Bindlib.box_apply3
(fun excepts just cons -> EDefault (excepts, just, cons), mark)
(Bindlib.box_list excepts) just cons
let eifthenelse e1 e2 e3 mark =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), mark) e1 e2 e3
let eerroronempty e1 mark =
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, mark) e1
let eraise e1 mark = Bindlib.box (ERaise e1, mark)
let ecatch e1 exn e2 mark =
Bindlib.box_apply2 (fun e1 e2 -> ECatch (e1, exn, e2), mark) e1 e2
let elocation loc mark = Bindlib.box (ELocation loc, mark)
let estruct name fields mark =
Bindlib.box_apply (fun es -> EStruct (name, es), mark) fields
let estructaccess e1 field struc mark =
Bindlib.box_apply (fun e1 -> EStructAccess (e1, field, struc), mark) e1
let eenuminj e1 cons enum mark =
Bindlib.box_apply (fun e1 -> EEnumInj (e1, cons, enum), mark) e1
let ematchs e1 enum cases mark =
Bindlib.box_apply2 (fun e1 cases -> EMatchS (e1, enum, cases), mark) e1 cases
(* - Manipulation of marks - *)
let no_mark : type m. m mark -> m mark = function
| Untyped _ -> Untyped { pos = Pos.no_pos }
| Typed _ -> Typed { pos = Pos.no_pos; ty = Marked.mark Pos.no_pos TAny }
let mark_pos (type m) (m : m mark) : Pos.t =
match m with Untyped { pos } | Typed { pos; _ } -> pos
let pos (type m) (x : ('a, m mark) Marked.t) : Pos.t =
mark_pos (Marked.get_mark x)
let ty (_, m) : typ = match m with Typed { ty; _ } -> ty
let with_ty (type m) (ty : typ) (x : ('a, m mark) Marked.t) :
('a, typed mark) Marked.t =
Marked.mark
(match Marked.get_mark x with
| Untyped { pos } -> Typed { pos; ty }
| Typed m -> Typed { m with ty })
(Marked.unmark x)
let map_mark (type m) (pos_f : Pos.t -> Pos.t) (ty_f : typ -> typ) (m : m mark)
: m mark =
match m with
| Untyped { pos } -> Untyped { pos = pos_f pos }
| Typed { pos; ty } -> Typed { pos = pos_f pos; ty = ty_f ty }
let map_mark2
(type m)
(pos_f : Pos.t -> Pos.t -> Pos.t)
(ty_f : typed -> typed -> typ)
(m1 : m mark)
(m2 : m mark) : m mark =
match m1, m2 with
| Untyped m1, Untyped m2 -> Untyped { pos = pos_f m1.pos m2.pos }
| Typed m1, Typed m2 -> Typed { pos = pos_f m1.pos m2.pos; ty = ty_f m1 m2 }
let fold_marks
(type m)
(pos_f : Pos.t list -> Pos.t)
(ty_f : typed list -> typ)
(ms : m mark list) : m mark =
match ms with
| [] -> invalid_arg "Dcalc.Ast.fold_mark"
| Untyped _ :: _ as ms ->
Untyped { pos = pos_f (List.map (function Untyped { pos } -> pos) ms) }
| Typed _ :: _ ->
Typed
{
pos = pos_f (List.map (function Typed { pos; _ } -> pos) ms);
ty = ty_f (List.map (function Typed m -> m) ms);
}
(* - Traversal functions - *)
(* shallow map *)
let map
(type a)
(ctx : 'ctx)
~(f : 'ctx -> (a, 'm1) gexpr -> (a, 'm2) gexpr box)
(e : ((a, 'm1) naked_gexpr, 'm2) Marked.t) : (a, 'm2) gexpr box =
let m = Marked.get_mark e in
match Marked.unmark e with
| ELit l -> elit l m
| EApp (e1, args) -> eapp (f ctx e1) (List.map (f ctx) args) m
| EOp op -> Bindlib.box (EOp op, m)
| EArray args -> earray (List.map (f ctx) args) m
| EVar v -> evar (Var.translate v) m
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
eabs (Bindlib.bind_mvar (Array.map Var.translate vars) (f ctx body)) typs m
| EIfThenElse (e1, e2, e3) ->
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) m
| ETuple (args, s) -> etuple (List.map (f ctx) args) s m
| ETupleAccess (e1, n, s_name, typs) ->
etupleaccess ((f ctx) e1) n s_name typs m
| EInj (e1, i, e_name, typs) -> einj ((f ctx) e1) i e_name typs m
| EMatch (arg, arms, e_name) ->
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name m
| EAssert e1 -> eassert ((f ctx) e1) m
| EDefault (excepts, just, cons) ->
edefault (List.map (f ctx) excepts) ((f ctx) just) ((f ctx) cons) m
| ErrorOnEmpty e1 -> eerroronempty ((f ctx) e1) m
| ECatch (e1, exn, e2) -> ecatch (f ctx e1) exn (f ctx e2) m
| ERaise exn -> eraise exn m
| ELocation loc -> elocation loc m
| EStruct (name, fields) ->
let fields =
StructFieldMap.fold
(fun fld e -> Bindlib.box_apply2 (StructFieldMap.add fld) (f ctx e))
fields
(Bindlib.box StructFieldMap.empty)
in
estruct name fields m
| EStructAccess (e1, field, struc) -> estructaccess (f ctx e1) field struc m
| EEnumInj (e1, cons, enum) -> eenuminj (f ctx e1) cons enum m
| EMatchS (e1, enum, cases) ->
let cases =
EnumConstructorMap.fold
(fun cstr e ->
Bindlib.box_apply2 (EnumConstructorMap.add cstr) (f ctx e))
cases
(Bindlib.box EnumConstructorMap.empty)
in
ematchs (f ctx e1) enum cases m
let rec map_top_down ~f e = map () ~f:(fun () -> map_top_down ~f) (f e)
let map_marks ~f e =
map_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
(* - *)
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let box e =
let rec id_t () e = map () ~f:id_t e in
id_t () e
let untype e = map_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e
(* - Expression building helpers - *)
let make_var (x, mark) =
Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
let make_abs xs e taus mark =
Bindlib.box_apply (fun b -> EAbs (b, taus), mark) (Bindlib.bind_mvar xs e)
let make_app e u mark =
Bindlib.box_apply2 (fun e u -> EApp (e, u), mark) e (Bindlib.box_list u)
let empty_thunked_term mark =
let silent = Var.make "_" in
let pos = mark_pos mark in
Bindlib.unbox
(make_abs [| silent |]
(Bindlib.box (ELit LEmptyError, mark))
[TLit TUnit, pos]
(map_mark
(fun pos -> pos)
(fun ty ->
Marked.mark pos (TArrow (Marked.mark pos (TLit TUnit), ty)))
mark))
let make_let_in x tau e1 e2 pos =
let m_e1 = Marked.get_mark (Bindlib.unbox e1) in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (TArrow (m1.ty, m2.ty)))
m_e1 m_e2
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let make_multiple_let_in xs taus e1s e2 pos =
(* let m_e1s = List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s in *)
let m_e1s =
fold_marks List.hd
(fun tys -> TTuple (List.map (fun t -> t.ty) tys), (List.hd tys).pos)
(List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s)
in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (TArrow (m1.ty, m2.ty)))
m_e1s m_e2
in
make_app (make_abs xs e2 taus m_abs) e1s m_e2
let make_default exceptions just cons mark =
let rec bool_value = function
| ELit (LBool b), _ -> Some b
| EApp ((EOp (Unop (Log (l, _))), _), [e]), _
when l <> PosRecordIfTrueBool
(* we don't remove the log calls corresponding to source code
definitions !*) ->
bool_value e
| _ -> None
in
match exceptions, bool_value just, cons with
| [], Some true, cons -> cons
| exceptions, Some true, (EDefault ([], just, cons), mark) ->
EDefault (exceptions, just, cons), mark
| [except], Some false, _ -> except
| exceptions, _, cons -> EDefault (exceptions, just, cons), mark
(* Tests *)
let is_value (type a) (e : (a, _) gexpr) =
match Marked.unmark e with
| ELit _ | EAbs _ | EOp _ | ERaise _ -> true
| _ -> false
let equal_tlit l1 l2 = l1 = l2
let compare_tlit l1 l2 = Stdlib.compare l1 l2
let rec equal_typ ty1 ty2 =
match Marked.unmark ty1, Marked.unmark ty2 with
| TLit l1, TLit l2 -> equal_tlit l1 l2
| TTuple tys1, TTuple tys2 -> equal_typ_list tys1 tys2
| TStruct n1, TStruct n2 -> StructName.equal n1 n2
| TEnum n1, TEnum n2 -> EnumName.equal n1 n2
| TOption t1, TOption t2 -> equal_typ t1 t2
| TArrow (t1, t1'), TArrow (t2, t2') -> equal_typ t1 t2 && equal_typ t1' t2'
| TArray t1, TArray t2 -> equal_typ t1 t2
| TAny, TAny -> true
| ( ( TLit _ | TTuple _ | TStruct _ | TEnum _ | TOption _ | TArrow _
| TArray _ | TAny ),
_ ) ->
false
and equal_typ_list tys1 tys2 =
try List.for_all2 equal_typ tys1 tys2 with Invalid_argument _ -> false
let rec compare_typ ty1 ty2 =
match Marked.unmark ty1, Marked.unmark ty2 with
| TLit l1, TLit l2 -> compare_tlit l1 l2
| TTuple tys1, TTuple tys2 -> List.compare compare_typ tys1 tys2
| TStruct n1, TStruct n2 -> StructName.compare n1 n2
| TEnum en1, TEnum en2 -> EnumName.compare en1 en2
| TOption t1, TOption t2 -> compare_typ t1 t2
| TArrow (a1, b1), TArrow (a2, b2) -> (
match compare_typ a1 a2 with 0 -> compare_typ b1 b2 | n -> n)
| TArray t1, TArray t2 -> compare_typ t1 t2
| TAny, TAny -> 0
| TLit _, _ -> -1
| _, TLit _ -> 1
| TTuple _, _ -> -1
| _, TTuple _ -> 1
| TStruct _, _ -> -1
| _, TStruct _ -> 1
| TEnum _, _ -> -1
| _, TEnum _ -> 1
| TOption _, _ -> -1
| _, TOption _ -> 1
| TArrow _, _ -> -1
| _, TArrow _ -> 1
| TArray _, _ -> -1
| _, TArray _ -> 1
let equal_lit (type a) (l1 : a glit) (l2 : a glit) =
match l1, l2 with
| LBool b1, LBool b2 -> Bool.equal b1 b2
| LEmptyError, LEmptyError -> true
| LInt n1, LInt n2 -> Runtime.( =! ) n1 n2
| LRat r1, LRat r2 -> Runtime.( =& ) r1 r2
| LMoney m1, LMoney m2 -> Runtime.( =$ ) m1 m2
| LUnit, LUnit -> true
| LDate d1, LDate d2 -> Runtime.( =@ ) d1 d2
| LDuration d1, LDuration d2 -> Runtime.( =^ ) d1 d2
| ( ( LBool _ | LEmptyError | LInt _ | LRat _ | LMoney _ | LUnit | LDate _
| LDuration _ ),
_ ) ->
false
let compare_lit (type a) (l1 : a glit) (l2 : a glit) =
match l1, l2 with
| LBool b1, LBool b2 -> Bool.compare b1 b2
| LEmptyError, LEmptyError -> 0
| LInt n1, LInt n2 ->
if Runtime.( <! ) n1 n2 then -1 else if Runtime.( =! ) n1 n2 then 0 else 1
| LRat r1, LRat r2 ->
if Runtime.( <& ) r1 r2 then -1 else if Runtime.( =& ) r1 r2 then 0 else 1
| LMoney m1, LMoney m2 ->
if Runtime.( <$ ) m1 m2 then -1 else if Runtime.( =$ ) m1 m2 then 0 else 1
| LUnit, LUnit -> 0
| LDate d1, LDate d2 ->
if Runtime.( <@ ) d1 d2 then -1 else if Runtime.( =@ ) d1 d2 then 0 else 1
| LDuration d1, LDuration d2 -> (
(* Duration comparison in the runtime may fail, so rely on a basic
lexicographic comparison instead *)
let y1, m1, d1 = Runtime.duration_to_years_months_days d1 in
let y2, m2, d2 = Runtime.duration_to_years_months_days d2 in
match compare y1 y2 with
| 0 -> ( match compare m1 m2 with 0 -> compare d1 d2 | n -> n)
| n -> n)
| LBool _, _ -> -1
| _, LBool _ -> 1
| LEmptyError, _ -> -1
| _, LEmptyError -> 1
| LInt _, _ -> -1
| _, LInt _ -> 1
| LRat _, _ -> -1
| _, LRat _ -> 1
| LMoney _, _ -> -1
| _, LMoney _ -> 1
| LUnit, _ -> -1
| _, LUnit -> 1
| LDate _, _ -> -1
| _, LDate _ -> 1
| LDuration _, _ -> .
| _, LDuration _ -> .
let compare_location
(type a)
(x : a glocation Marked.pos)
(y : a glocation Marked.pos) =
match Marked.unmark x, Marked.unmark y with
| DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, None)
| DesugaredScopeVar (vx, Some _), DesugaredScopeVar (vy, None)
| DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, Some _) ->
ScopeVar.compare (Marked.unmark vx) (Marked.unmark vy)
| DesugaredScopeVar ((x, _), Some sx), DesugaredScopeVar ((y, _), Some sy) ->
let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp
| ScopelangScopeVar (vx, _), ScopelangScopeVar (vy, _) ->
ScopeVar.compare vx vy
| ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)),
SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) ->
let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| DesugaredScopeVar _, _ -> -1
| _, DesugaredScopeVar _ -> 1
| ScopelangScopeVar _, _ -> -1
| _, ScopelangScopeVar _ -> 1
| SubScopeVar _, _ -> .
| _, SubScopeVar _ -> .
let equal_location a b = compare_location a b = 0
let equal_log_entries l1 l2 =
match l1, l2 with
| VarDef t1, VarDef t2 -> equal_typ (t1, Pos.no_pos) (t2, Pos.no_pos)
| x, y -> x = y
let compare_log_entries l1 l2 =
match l1, l2 with
| VarDef t1, VarDef t2 -> compare_typ (t1, Pos.no_pos) (t2, Pos.no_pos)
| BeginCall, BeginCall
| EndCall, EndCall
| PosRecordIfTrueBool, PosRecordIfTrueBool ->
0
| VarDef _, _ -> -1
| _, VarDef _ -> 1
| BeginCall, _ -> -1
| _, BeginCall -> 1
| EndCall, _ -> -1
| _, EndCall -> 1
| PosRecordIfTrueBool, _ -> .
| _, PosRecordIfTrueBool -> .
(* let equal_op_kind = Stdlib.(=) *)
let compare_op_kind = Stdlib.compare
let equal_unops op1 op2 =
match op1, op2 with
(* Log entries contain a typ which contain position information, we thus need
to descend into them *)
| Log (l1, info1), Log (l2, info2) ->
equal_log_entries l1 l2 && List.equal Uid.MarkedString.equal info1 info2
| Log _, _ | _, Log _ -> false
(* All the other cases can be discharged through equality *)
| ( ( Not | Minus _ | Length | IntToRat | MoneyToRat | RatToMoney | GetDay
| GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | RoundMoney
| RoundDecimal ),
_ ) ->
op1 = op2
let compare_unops op1 op2 =
match op1, op2 with
| Not, Not -> 0
| Minus k1, Minus k2 -> compare_op_kind k1 k2
| Log (l1, info1), Log (l2, info2) -> (
match compare_log_entries l1 l2 with
| 0 -> List.compare Uid.MarkedString.compare info1 info2
| n -> n)
| Length, Length
| IntToRat, IntToRat
| MoneyToRat, MoneyToRat
| RatToMoney, RatToMoney
| GetDay, GetDay
| GetMonth, GetMonth
| GetYear, GetYear
| FirstDayOfMonth, FirstDayOfMonth
| LastDayOfMonth, LastDayOfMonth
| RoundMoney, RoundMoney
| RoundDecimal, RoundDecimal ->
0
| Not, _ -> -1
| _, Not -> 1
| Minus _, _ -> -1
| _, Minus _ -> 1
| Log _, _ -> -1
| _, Log _ -> 1
| Length, _ -> -1
| _, Length -> 1
| IntToRat, _ -> -1
| _, IntToRat -> 1
| MoneyToRat, _ -> -1
| _, MoneyToRat -> 1
| RatToMoney, _ -> -1
| _, RatToMoney -> 1
| GetDay, _ -> -1
| _, GetDay -> 1
| GetMonth, _ -> -1
| _, GetMonth -> 1
| GetYear, _ -> -1
| _, GetYear -> 1
| FirstDayOfMonth, _ -> -1
| _, FirstDayOfMonth -> 1
| LastDayOfMonth, _ -> -1
| _, LastDayOfMonth -> 1
| RoundMoney, _ -> -1
| _, RoundMoney -> 1
| RoundDecimal, _ -> .
| _, RoundDecimal -> .
let equal_binop = Stdlib.( = )
let compare_binop = Stdlib.compare
let equal_ternop = Stdlib.( = )
let compare_ternop = Stdlib.compare
let equal_ops op1 op2 =
match op1, op2 with
| Ternop op1, Ternop op2 -> equal_ternop op1 op2
| Binop op1, Binop op2 -> equal_binop op1 op2
| Unop op1, Unop op2 -> equal_unops op1 op2
| _, _ -> false
let compare_op op1 op2 =
match op1, op2 with
| Ternop op1, Ternop op2 -> compare_ternop op1 op2
| Binop op1, Binop op2 -> compare_binop op1 op2
| Unop op1, Unop op2 -> compare_unops op1 op2
| Ternop _, _ -> -1
| _, Ternop _ -> 1
| Binop _, _ -> -1
| _, Binop _ -> 1
| Unop _, _ -> .
| _, Unop _ -> .
let equal_except ex1 ex2 = ex1 = ex2
let compare_except ex1 ex2 = Stdlib.compare ex1 ex2
(* weird indentation; see
https://github.com/ocaml-ppx/ocamlformat/issues/2143 *)
let rec equal_list : 'a. ('a, 't) gexpr list -> ('a, 't) gexpr list -> bool =
fun es1 es2 ->
try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
fun e1 e2 ->
match Marked.unmark e1, Marked.unmark e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple (es1, n1), ETuple (es2, n2) -> n1 = n2 && equal_list es1 es2
| ETupleAccess (e1, id1, n1, tys1), ETupleAccess (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typ_list tys1 tys2
| EInj (e1, id1, n1, tys1), EInj (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typ_list tys1 tys2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
n1 = n2 && equal e1 e2 && equal_list cases1 cases2
| EArray es1, EArray es2 -> equal_list es1 es2
| ELit l1, ELit l2 -> l1 = l2
| EAbs (b1, tys1), EAbs (b2, tys2) ->
equal_typ_list tys1 tys2
&&
let vars1, body1 = Bindlib.unmbind b1 in
let body2 = Bindlib.msubst b2 (Array.map (fun x -> EVar x) vars1) in
equal body1 body2
| EApp (e1, args1), EApp (e2, args2) -> equal e1 e2 && equal_list args1 args2
| EAssert e1, EAssert e2 -> equal e1 e2
| EOp op1, EOp op2 -> equal_ops op1 op2
| EDefault (exc1, def1, cons1), EDefault (exc2, def2, cons2) ->
equal def1 def2 && equal cons1 cons2 && equal_list exc1 exc2
| EIfThenElse (if1, then1, else1), EIfThenElse (if2, then2, else2) ->
equal if1 if2 && equal then1 then2 && equal else1 else2
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal e1 e2
| ERaise ex1, ERaise ex2 -> equal_except ex1 ex2
| ECatch (etry1, ex1, ewith1), ECatch (etry2, ex2, ewith2) ->
equal etry1 etry2 && equal_except ex1 ex2 && equal ewith1 ewith2
| ELocation l1, ELocation l2 ->
equal_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| EStruct (s1, fields1), EStruct (s2, fields2) ->
StructName.equal s1 s2 && StructFieldMap.equal equal fields1 fields2
| EStructAccess (e1, f1, s1), EStructAccess (e2, f2, s2) ->
StructName.equal s1 s2 && StructFieldName.equal f1 f2 && equal e1 e2
| EEnumInj (e1, c1, n1), EEnumInj (e2, c2, n2) ->
EnumName.equal n1 n2 && EnumConstructor.equal c1 c2 && equal e1 e2
| EMatchS (e1, n1, cases1), EMatchS (e2, n2, cases2) ->
EnumName.equal n1 n2
&& equal e1 e2
&& EnumConstructorMap.equal equal cases1 cases2
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | EArray _
| ELit _ | EAbs _ | EApp _ | EAssert _ | EOp _ | EDefault _
| EIfThenElse _ | ErrorOnEmpty _ | ERaise _ | ECatch _ | ELocation _
| EStruct _ | EStructAccess _ | EEnumInj _ | EMatchS _ ),
_ ) ->
false
let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
fun e1 e2 ->
(* Infix operator to chain comparisons lexicographically. *)
let ( @@< ) cmp1 cmpf = match cmp1 with 0 -> cmpf () | n -> n in
(* OCamlformat doesn't know to keep consistency in match cases so disabled
locally for readability *)
match[@ocamlformat "disable"] Marked.unmark e1, Marked.unmark e2 with
| ELit l1, ELit l2 ->
compare_lit l1 l2
| EApp (f1, args1), EApp (f2, args2) ->
compare f1 f2 @@< fun () ->
List.compare compare args1 args2
| EOp op1, EOp op2 ->
compare_op op1 op2
| EArray a1, EArray a2 ->
List.compare compare a1 a2
| EVar v1, EVar v2 ->
Bindlib.compare_vars v1 v2
| EAbs (binder1, typs1), EAbs (binder2, typs2) ->
List.compare compare_typ typs1 typs2 @@< fun () ->
let _, e1, e2 = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
| EIfThenElse (i1, t1, e1), EIfThenElse (i2, t2, e2) ->
compare i1 i2 @@< fun () ->
compare t1 t2 @@< fun () ->
compare e1 e2
| ELocation l1, ELocation l2 ->
compare_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| EStruct (name1, field_map1), EStruct (name2, field_map2) ->
StructName.compare name1 name2 @@< fun () ->
StructFieldMap.compare compare field_map1 field_map2
| EStructAccess (e1, field_name1, struct_name1),
EStructAccess (e2, field_name2, struct_name2) ->
compare e1 e2 @@< fun () ->
StructFieldName.compare field_name1 field_name2 @@< fun () ->
StructName.compare struct_name1 struct_name2
| EEnumInj (e1, cstr1, name1), EEnumInj (e2, cstr2, name2) ->
compare e1 e2 @@< fun () ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructor.compare cstr1 cstr2
| EMatchS (e1, name1, emap1), EMatchS (e2, name2, emap2) ->
compare e1 e2 @@< fun () ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructorMap.compare compare emap1 emap2
| ETuple (es1, s1), ETuple (es2, s2) ->
Option.compare StructName.compare s1 s2 @@< fun () ->
List.compare compare es1 es2
| ETupleAccess (e1, n1, s1, tys1), ETupleAccess (e2, n2, s2, tys2) ->
Option.compare StructName.compare s1 s2 @@< fun () ->
Int.compare n1 n2 @@< fun () ->
List.compare compare_typ tys1 tys2 @@< fun () ->
compare e1 e2
| EInj (e1, n1, name1, ts1), EInj (e2, n2, name2, ts2) ->
EnumName.compare name1 name2 @@< fun () ->
Int.compare n1 n2 @@< fun () ->
List.compare compare_typ ts1 ts2 @@< fun () ->
compare e1 e2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
EnumName.compare n1 n2 @@< fun () ->
compare e1 e2 @@< fun () ->
List.compare compare cases1 cases2
| EAssert e1, EAssert e2 ->
compare e1 e2
| EDefault (exs1, just1, cons1), EDefault (exs2, just2, cons2) ->
compare just1 just2 @@< fun () ->
compare cons1 cons2 @@< fun () ->
List.compare compare exs1 exs2
| ErrorOnEmpty e1, ErrorOnEmpty e2 ->
compare e1 e2
| ERaise ex1, ERaise ex2 ->
compare_except ex1 ex2
| ECatch (etry1, ex1, ewith1), ECatch (etry2, ex2, ewith2) ->
compare_except ex1 ex2 @@< fun () ->
compare etry1 etry2 @@< fun () ->
compare ewith1 ewith2
| ELit _, _ -> -1 | _, ELit _ -> 1
| EApp _, _ -> -1 | _, EApp _ -> 1
| EOp _, _ -> -1 | _, EOp _ -> 1
| EArray _, _ -> -1 | _, EArray _ -> 1
| EVar _, _ -> -1 | _, EVar _ -> 1
| EAbs _, _ -> -1 | _, EAbs _ -> 1
| EIfThenElse _, _ -> -1 | _, EIfThenElse _ -> 1
| ELocation _, _ -> -1 | _, ELocation _ -> 1
| EStruct _, _ -> -1 | _, EStruct _ -> 1
| EStructAccess _, _ -> -1 | _, EStructAccess _ -> 1
| EEnumInj _, _ -> -1 | _, EEnumInj _ -> 1
| EMatchS _, _ -> -1 | _, EMatchS _ -> 1
| ETuple _, _ -> -1 | _, ETuple _ -> 1
| ETupleAccess _, _ -> -1 | _, ETupleAccess _ -> 1
| EInj _, _ -> -1 | _, EInj _ -> 1
| EMatch _, _ -> -1 | _, EMatch _ -> 1
| EAssert _, _ -> -1 | _, EAssert _ -> 1
| EDefault _, _ -> -1 | _, EDefault _ -> 1
| ErrorOnEmpty _, _ -> . | _, ErrorOnEmpty _ -> .
| ERaise _, _ -> -1 | _, ERaise _ -> 1
| ECatch _, _ -> . | _, ECatch _ -> .
let rec free_vars : type a. (a, 't) gexpr -> (a, 't) gexpr Var.Set.t =
fun e ->
match Marked.unmark e with
| EOp _ | ELit _ | ERaise _ -> Var.Set.empty
| EVar v -> Var.Set.singleton v
| ETuple (es, _) ->
es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EArray es ->
es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| ETupleAccess (e1, _, _, _) -> free_vars e1
| EAssert e1 -> free_vars e1
| EInj (e1, _, _, _) -> free_vars e1
| ErrorOnEmpty e1 -> free_vars e1
| ECatch (etry, _, ewith) -> Var.Set.union (free_vars etry) (free_vars ewith)
| EApp (e1, es) ->
e1 :: es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EMatch (e1, es, _) ->
e1 :: es |> List.map free_vars |> List.fold_left Var.Set.union Var.Set.empty
| EDefault (es, ejust, econs) ->
ejust :: econs :: es
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EIfThenElse (e1, e2, e3) ->
[e1; e2; e3]
|> List.map free_vars
|> List.fold_left Var.Set.union Var.Set.empty
| EAbs (binder, _) ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right Var.Set.remove vs (free_vars body)
| ELocation _ -> Var.Set.empty
| EStruct (_, fields) ->
StructFieldMap.fold
(fun _ e -> Var.Set.union (free_vars e))
fields Var.Set.empty
| EStructAccess (e1, _, _) -> free_vars e1
| EEnumInj (e1, _, _) -> free_vars e1
| EMatchS (e1, _, cases) ->
free_vars e1
|> EnumConstructorMap.fold (fun _ e -> Var.Set.union (free_vars e)) cases
let remove_logging_calls e =
let rec f () e =
match Marked.unmark e with
| EApp ((EOp (Unop (Log _)), _), [arg]) -> map () ~f arg
| _ -> map () ~f e
in
f () e
let format ?debug decl_ctx ppf e = Print.naked_expr ?debug decl_ctx ppf e
let rec size : type a. (a, 't) gexpr -> int =
fun e ->
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| EArray args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| ETupleAccess (e1, _, _, _) -> size e1 + 1
| EInj (e1, _, _, _) -> size e1 + 1
| EAssert e1 -> size e1 + 1
| ErrorOnEmpty e1 -> size e1 + 1
| EMatch (arg, args, _) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EApp (arg, args) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
1 + size body
| EIfThenElse (e1, e2, e3) -> 1 + size e1 + size e2 + size e3
| EDefault (exceptions, just, cons) ->
List.fold_left
(fun acc except -> acc + size except)
(1 + size just + size cons)
exceptions
| ERaise _ -> 1
| ECatch (etry, _, ewith) -> 1 + size etry + size ewith
| ELocation _ -> 1
| EStruct (_, fields) ->
StructFieldMap.fold (fun _ e acc -> acc + 1 + size e) fields 0
| EStructAccess (e1, _, _) -> 1 + size e1
| EEnumInj (e1, _, _) -> 1 + size e1
| EMatchS (e1, _, cases) ->
EnumConstructorMap.fold (fun _ e acc -> acc + 1 + size e) cases (size e1)

246
compiler/shared_ast/expr.mli Normal file
View File

@ -0,0 +1,246 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Functions handling the expressions of [shared_ast] *)
open Utils
open Definitions
(** {2 Boxed constructors} *)
val box : ('a, 't) gexpr -> ('a, 't) gexpr box
val evar : ('a, 't) gexpr Var.t -> 't -> ('a, 't) gexpr box
val etuple :
(([< dcalc | lcalc ] as 'a), 't) gexpr box list ->
StructName.t option ->
't ->
('a, 't) gexpr box
val etupleaccess :
(([< dcalc | lcalc ] as 'a), 't) gexpr box ->
int ->
StructName.t option ->
typ list ->
't ->
('a, 't) gexpr box
val einj :
(([< dcalc | lcalc ] as 'a), 't) gexpr box ->
int ->
EnumName.t ->
typ list ->
't ->
('a, 't) gexpr box
val ematch :
(([< dcalc | lcalc ] as 'a), 't) gexpr box ->
('a, 't) gexpr box list ->
EnumName.t ->
't ->
('a, 't) gexpr box
val earray : ('a any, 't) gexpr box list -> 't -> ('a, 't) gexpr box
val elit : 'a any glit -> 't -> ('a, 't) gexpr box
val eabs :
(('a any, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder box ->
typ list ->
't ->
('a, 't) gexpr box
val eapp :
('a any, 't) gexpr box -> ('a, 't) gexpr box list -> 't -> ('a, 't) gexpr box
val eassert :
(([< dcalc | lcalc ] as 'a), 't) gexpr box -> 't -> ('a, 't) gexpr box
val eop : operator -> 't -> (_ any, 't) gexpr box
val edefault :
(([< desugared | scopelang | dcalc ] as 'a), 't) gexpr box list ->
('a, 't) gexpr box ->
('a, 't) gexpr box ->
't ->
('a, 't) gexpr box
val eifthenelse :
('a any, 't) gexpr box ->
('a, 't) gexpr box ->
('a, 't) gexpr box ->
't ->
('a, 't) gexpr box
val eerroronempty :
(([< desugared | scopelang | dcalc ] as 'a), 't) gexpr box ->
't ->
('a, 't) gexpr box
val ecatch :
(lcalc, 't) gexpr box ->
except ->
(lcalc, 't) gexpr box ->
't ->
(lcalc, 't) gexpr box
val eraise : except -> 't -> (lcalc, 't) gexpr box
(** Manipulation of marks *)
val no_mark : 'm mark -> 'm mark
val mark_pos : 'm mark -> Pos.t
val pos : ('e, _ mark) gexpr -> Pos.t
val ty : (_, typed mark) Marked.t -> typ
val with_ty : typ -> ('a, _ mark) Marked.t -> ('a, typed mark) Marked.t
val map_mark : (Pos.t -> Pos.t) -> (typ -> typ) -> 'm mark -> 'm mark
val map_mark2 :
(Pos.t -> Pos.t -> Pos.t) ->
(typed -> typed -> typ) ->
'm mark ->
'm mark ->
'm mark
val fold_marks :
(Pos.t list -> Pos.t) -> (typed list -> typ) -> 'm mark list -> 'm mark
val untype : ('a, 'm mark) gexpr -> ('a, untyped mark) gexpr box
(** {2 Traversal functions} *)
val map :
'ctx ->
f:('ctx -> ('a, 't1) gexpr -> ('a, 't2) gexpr box) ->
(('a, 't1) naked_gexpr, 't2) Marked.t ->
('a, 't2) gexpr box
(** Flat (non-recursive) mapping on expressions.
If you want to apply a map transform to an expression, you can save up
writing a painful match over all the cases of the AST. For instance, if you
want to remove all errors on empty, you can write
{[
let remove_error_empty =
let rec f () e =
match Marked.unmark e with
| ErrorOnEmpty e1 -> Expr.map () f e1
| _ -> Expr.map () f e
in
f () e
]}
The first argument of map_expr is an optional context that you can carry
around during your map traversal. *)
val map_top_down :
f:(('a, 't1) gexpr -> (('a, 't1) naked_gexpr, 't2) Marked.t) ->
('a, 't1) gexpr ->
('a, 't2) gexpr box
(** Recursively applies [f] to the nodes of the expression tree. The type
returned by [f] is hybrid since the mark at top-level has been rewritten,
but not yet the marks in the subtrees. *)
val map_marks : f:('t1 -> 't2) -> ('a, 't1) gexpr -> ('a, 't2) gexpr box
(** {2 Expression building helpers} *)
val make_var : ('a, 't) gexpr Var.t * 'b -> (('a, 't) naked_gexpr * 'b) box
val make_abs :
('a, 't) gexpr Var.vars ->
('a, 't) gexpr box ->
typ list ->
't ->
('a, 't) gexpr box
val make_app :
('a any, 'm mark) gexpr box ->
('a, 'm mark) gexpr box list ->
'm mark ->
('a, 'm mark) gexpr box
val empty_thunked_term :
'm mark -> ([< dcalc | desugared | scopelang ], 'm mark) gexpr
val make_let_in :
('a, 'm mark) gexpr Var.t ->
typ ->
('a, 'm mark) gexpr box ->
('a, 'm mark) gexpr box ->
Utils.Pos.t ->
('a, 'm mark) gexpr box
val make_multiple_let_in :
('a, 'm mark) gexpr Var.vars ->
typ list ->
('a, 'm mark) gexpr box list ->
('a, 'm mark) gexpr box ->
Pos.t ->
('a, 'm mark) gexpr box
val make_default :
(([< desugared | scopelang | dcalc ] as 'a), 't) gexpr list ->
('a, 't) gexpr ->
('a, 't) gexpr ->
't ->
('a, 't) gexpr
(** [make_default ?pos exceptions just cons] builds a term semantically
equivalent to [<exceptions | just :- cons>] (the [EDefault] constructor)
while avoiding redundant nested constructions. The position is extracted
from [just] by default.
Note that, due to the simplifications taking place, the result might not be
of the form [EDefault]:
- [<true :- x>] is rewritten as [x]
- [<ex | true :- def>], when [def] is a default term [<j :- c>] without
exceptions, is collapsed into [<ex | def>]
- [<ex | false :- _>], when [ex] is a single exception, is rewritten as [ex] *)
(** {2 Transformations} *)
val remove_logging_calls : ('a any, 't) gexpr -> ('a, 't) gexpr box
(** Removes all calls to [Log] unary operators in the AST, replacing them by
their argument. *)
val format :
?debug:bool (** [true] for debug printing *) ->
decl_ctx ->
Format.formatter ->
(_, _ mark) gexpr ->
unit
(** {2 Analysis and tests} *)
val equal_lit : 'a glit -> 'a glit -> bool
val compare_lit : 'a glit -> 'a glit -> int
val equal_location : 'a glocation Marked.pos -> 'a glocation Marked.pos -> bool
val compare_location : 'a glocation Marked.pos -> 'a glocation Marked.pos -> int
val equal : ('a, 't) gexpr -> ('a, 't) gexpr -> bool
(** Determines if two expressions are equal, omitting their position information *)
val compare : ('a, 't) gexpr -> ('a, 't) gexpr -> int
(** Standard comparison function, suitable for e.g. [Set.Make]. Ignores position
information *)
val compare_typ : typ -> typ -> int
val is_value : ('a any, 't) gexpr -> bool
val free_vars : ('a any, 't) gexpr -> ('a, 't) gexpr Var.Set.t
val size : ('a, 't) gexpr -> int
(** Used by the optimizer to know when to stop *)

365
compiler/shared_ast/print.ml Normal file
View File

@ -0,0 +1,365 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open String_common
open Definitions
let typ_needs_parens (ty : typ) : bool =
match Marked.unmark ty with TArrow _ | TArray _ -> true | _ -> false
let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) :
unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
(fun fmt info ->
Utils.Cli.format_with_style
(if begins_with_uppercase (Marked.unmark info) then [ANSITerminal.red]
else [])
fmt
(Utils.Uid.MarkedString.to_string info))
fmt infos
let keyword (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.red] fmt s
let base_type (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.yellow] fmt s
let punctuation (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.cyan] fmt s
let operator (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.green] fmt s
let lit_style (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.yellow] fmt s
let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
base_type fmt
(match l with
| TUnit -> "unit"
| TBool -> "bool"
| TInt -> "integer"
| TRat -> "decimal"
| TMoney -> "money"
| TDuration -> "duration"
| TDate -> "date")
let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
match l with
| DesugaredScopeVar (v, _st) ->
Format.fprintf fmt "%a" ScopeVar.format_t (Marked.unmark v)
| ScopelangScopeVar v ->
Format.fprintf fmt "%a" ScopeVar.format_t (Marked.unmark v)
| SubScopeVar (_, subindex, subvar) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Marked.unmark subindex)
ScopeVar.format_t (Marked.unmark subvar)
let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
Format.fprintf fmt "%a"
(Utils.Cli.format_with_style [ANSITerminal.magenta])
(Format.asprintf "%a" EnumConstructor.format_t c)
let rec typ (ctx : decl_ctx) (fmt : Format.formatter) (ty : typ) : unit =
let typ = typ ctx in
let typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" typ t
else Format.fprintf fmt "%a" typ t
in
match Marked.unmark ty with
| TLit l -> tlit fmt l
| TTuple ts ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " operator "*")
(fun fmt t -> Format.fprintf fmt "%a" typ t))
ts
| TStruct s ->
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" StructName.format_t s punctuation
"{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (field, mty) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t field punctuation "\"" punctuation ":" typ
mty))
(StructMap.find s ctx.ctx_structs)
punctuation "}"
| TEnum e ->
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" EnumName.format_t e punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|")
(fun fmt (case, mty) ->
Format.fprintf fmt "%a%a@ %a" enum_constructor case punctuation ":"
typ mty))
(EnumMap.find e ctx.ctx_enums)
punctuation "]"
| TOption t -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "option" typ t
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" typ_with_parens t1 operator "→"
typ t2
| TArray t1 -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "array" typ t1
| TAny -> base_type fmt "any"
let lit (type a) (fmt : Format.formatter) (l : a glit) : unit =
match l with
| LBool b -> lit_style fmt (string_of_bool b)
| LInt i -> lit_style fmt (Runtime.integer_to_string i)
| LEmptyError -> lit_style fmt "∅ "
| LUnit -> lit_style fmt "()"
| LRat i ->
lit_style fmt
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
| LMoney e -> (
match !Utils.Cli.locale_lang with
| En -> lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e))
| Fr -> lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e))
| Pl -> lit_style fmt (Format.asprintf "%s PLN" (Runtime.money_to_string e))
)
| LDate d -> lit_style fmt (Runtime.date_to_string d)
| LDuration d -> lit_style fmt (Runtime.duration_to_string d)
let op_kind (fmt : Format.formatter) (k : op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> ""
| KRat -> "."
| KMoney -> "$"
| KDate -> "@"
| KDuration -> "^")
let binop (fmt : Format.formatter) (op : binop) : unit =
operator fmt
(match op with
| Add k -> Format.asprintf "+%a" op_kind k
| Sub k -> Format.asprintf "-%a" op_kind k
| Mult k -> Format.asprintf "*%a" op_kind k
| Div k -> Format.asprintf "/%a" op_kind k
| And -> "&&"
| Or -> "||"
| Xor -> "xor"
| Eq -> "="
| Neq -> "!="
| Lt k -> Format.asprintf "%s%a" "<" op_kind k
| Lte k -> Format.asprintf "%s%a" "<=" op_kind k
| Gt k -> Format.asprintf "%s%a" ">" op_kind k
| Gte k -> Format.asprintf "%s%a" ">=" op_kind k
| Concat -> "++"
| Map -> "map"
| Filter -> "filter")
let ternop (fmt : Format.formatter) (op : ternop) : unit =
match op with Fold -> keyword fmt "fold"
let log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "@<2>%a"
(fun fmt -> function
| VarDef _ -> Utils.Cli.format_with_style [ANSITerminal.blue] fmt "≔ "
| BeginCall -> Utils.Cli.format_with_style [ANSITerminal.yellow] fmt "→ "
| EndCall -> Utils.Cli.format_with_style [ANSITerminal.yellow] fmt "← "
| PosRecordIfTrueBool ->
Utils.Cli.format_with_style [ANSITerminal.green] fmt "☛ ")
entry
let unop (fmt : Format.formatter) (op : unop) : unit =
match op with
| Minus _ -> Format.pp_print_string fmt "-"
| Not -> Format.pp_print_string fmt "~"
| Log (entry, infos) ->
Format.fprintf fmt "log@[<hov 2>[%a|%a]@]" log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
infos
| Length -> Format.pp_print_string fmt "length"
| IntToRat -> Format.pp_print_string fmt "int_to_rat"
| MoneyToRat -> Format.pp_print_string fmt "money_to_rat"
| RatToMoney -> Format.pp_print_string fmt "rat_to_money"
| GetDay -> Format.pp_print_string fmt "get_day"
| GetMonth -> Format.pp_print_string fmt "get_month"
| GetYear -> Format.pp_print_string fmt "get_year"
| FirstDayOfMonth -> Format.pp_print_string fmt "first_day_of_month"
| LastDayOfMonth -> Format.pp_print_string fmt "last_day_of_month"
| RoundMoney -> Format.pp_print_string fmt "round_money"
| RoundDecimal -> Format.pp_print_string fmt "round_decimal"
let except (fmt : Format.formatter) (exn : except) : unit =
operator fmt
(match exn with
| EmptyError -> "EmptyError"
| ConflictError -> "ConflictError"
| Crash -> "Crash"
| NoValueProvided -> "NoValueProvided")
let var fmt v =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let needs_parens (type a) (e : (a, _) gexpr) : bool =
match Marked.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let rec naked_expr :
'a.
?debug:bool -> decl_ctx -> Format.formatter -> ('a, 't) gexpr -> unit
=
fun (type a) ?(debug : bool = false) (ctx : decl_ctx) (fmt : Format.formatter)
(e : (a, 't) gexpr) ->
let naked_expr e = naked_expr ~debug ctx e in
let with_parens fmt e =
if needs_parens e then (
punctuation fmt "(";
naked_expr fmt e;
punctuation fmt ")")
else naked_expr fmt e
in
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" var v
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" naked_expr e))
es punctuation ")"
| ETuple (es, Some s) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a%a%a@]@]" StructName.format_t s
punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t struct_field punctuation "\"" punctuation
"=" naked_expr e))
(List.combine es (List.map fst (StructMap.find s ctx.ctx_structs)))
punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" naked_expr e))
es punctuation "]"
| ETupleAccess (e1, n, s, _ts) -> (
match s with
| None -> Format.fprintf fmt "%a%a%d" naked_expr e1 punctuation "." n
| Some s ->
Format.fprintf fmt "%a%a%a%a%a" naked_expr e1 operator "." punctuation
"\"" StructFieldName.format_t
(fst (List.nth (StructMap.find s ctx.ctx_structs) n))
punctuation "\"")
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" enum_constructor
(fst (List.nth (EnumMap.find en ctx.ctx_enums) n))
naked_expr e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" keyword "match"
naked_expr e keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (e, c) ->
Format.fprintf fmt "@[<hov 2>%a %a%a@ %a@]" punctuation "|"
enum_constructor c punctuation ":" naked_expr e))
(List.combine es (List.map fst (EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> lit fmt l
| EApp ((EAbs (binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt (x, tau, arg) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n"
keyword "let" var x punctuation ":" (typ ctx) tau punctuation "="
naked_expr arg keyword "in"))
xs_tau_arg naked_expr body
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) taus in
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "%a%a%a %a%a" punctuation "(" var x punctuation
":" (typ ctx) tau punctuation ")"))
xs_tau punctuation "→" naked_expr body
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" binop op with_parens arg1
with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" with_parens arg1 binop op
with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
naked_expr fmt arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" unop op with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" naked_expr f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" keyword "if"
naked_expr e1 keyword "then" naked_expr e2 keyword "else" naked_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" unop op
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a%a@]" punctuation "⟨" naked_expr
just punctuation "⊢" naked_expr cons punctuation "⟩"
else
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@ %a@ %a%a@]" punctuation "⟨"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ",")
naked_expr)
exceptions punctuation "|" naked_expr just punctuation "⊢" naked_expr
cons punctuation "⟩"
| ErrorOnEmpty e' ->
Format.fprintf fmt "%a@ %a" operator "error_empty" with_parens e'
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" keyword "assert" punctuation "("
naked_expr e' punctuation ")"
| ECatch (e1, exn, e2) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a ->@ %a@]" keyword "try"
with_parens e1 keyword "with" except exn with_parens e2
| ERaise exn ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
| ELocation loc -> location fmt loc
| EStruct (name, fields) ->
Format.fprintf fmt " @[<hov 2>%a@ %a@ %a@ %a@]" StructName.format_t name
punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (field_name, field_expr) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t field_name punctuation "\"" punctuation
"=" naked_expr field_expr))
(StructFieldMap.bindings fields)
punctuation "}"
| EStructAccess (e1, field, _) ->
Format.fprintf fmt "%a%a%a%a%a" naked_expr e1 punctuation "." punctuation
"\"" StructFieldName.format_t field punctuation "\""
| EEnumInj (e1, cons, _) ->
Format.fprintf fmt "%a@ %a" EnumConstructor.format_t cons naked_expr e1
| EMatchS (e1, _, cases) ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" keyword "match"
naked_expr e1 keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cons_name, case_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
enum_constructor cons_name punctuation "→" naked_expr case_expr))
(EnumConstructorMap.bindings cases)

51
compiler/shared_ast/print.mli Normal file
View File

@ -0,0 +1,51 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Printing functions for the default calculus AST *)
open Utils
open Definitions
(** {1 Common syntax highlighting helpers}*)
val base_type : Format.formatter -> string -> unit
val keyword : Format.formatter -> string -> unit
val punctuation : Format.formatter -> string -> unit
val operator : Format.formatter -> string -> unit
val lit_style : Format.formatter -> string -> unit
(** {1 Formatters} *)
val uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val enum_constructor : Format.formatter -> EnumConstructor.t -> unit
val tlit : Format.formatter -> typ_lit -> unit
val location : Format.formatter -> 'a glocation -> unit
val typ : decl_ctx -> Format.formatter -> typ -> unit
val lit : Format.formatter -> 'a glit -> unit
val op_kind : Format.formatter -> op_kind -> unit
val binop : Format.formatter -> binop -> unit
val ternop : Format.formatter -> ternop -> unit
val log_entry : Format.formatter -> log_entry -> unit
val unop : Format.formatter -> unop -> unit
val except : Format.formatter -> except -> unit
val var : Format.formatter -> 'e Var.t -> unit
val naked_expr :
?debug:bool (** [true] for debug printing *) ->
decl_ctx ->
Format.formatter ->
('a, 't) gexpr ->
unit

41
compiler/shared_ast/program.ml Normal file
View File

@ -0,0 +1,41 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Definitions
let map_exprs ~f ~varf { scopes; decl_ctx } =
Bindlib.box_apply
(fun scopes -> { scopes; decl_ctx })
(Scope.map_exprs ~f ~varf scopes)
let untype : 'm. ('a, 'm mark) gexpr program -> ('a, untyped mark) gexpr program
=
fun prg -> Bindlib.unbox (map_exprs ~f:Expr.untype ~varf:Var.translate prg)
let rec find_scope name vars = function
| Nil -> raise Not_found
| ScopeDef { scope_name; scope_body; _ } when scope_name = name ->
List.rev vars, scope_body
| ScopeDef { scope_next; _ } ->
let var, next = Bindlib.unbind scope_next in
find_scope name (var :: vars) next
let to_expr p main_scope =
let _, main_scope_body = find_scope main_scope [] p.scopes in
Scope.unfold p.decl_ctx p.scopes
(Scope.get_body_mark main_scope_body)
(ScopeName main_scope)

36
compiler/shared_ast/program.mli Normal file
View File

@ -0,0 +1,36 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Definitions
(** {2 Transformations} *)
val map_exprs :
f:('expr1 -> 'expr2 box) ->
varf:('expr1 Var.t -> 'expr2 Var.t) ->
'expr1 program ->
'expr2 program box
val untype :
(([< dcalc | lcalc ] as 'a), 'm mark) gexpr program ->
('a, untyped mark) gexpr program
val to_expr :
(([< dcalc | lcalc ], _) gexpr as 'e) program -> ScopeName.t -> 'e box
(** Usage: [build_whole_program_expr program main_scope] builds an expression
corresponding to the main program and returning the main scope as a
function. *)

195
compiler/shared_ast/scope.ml Normal file
View File

@ -0,0 +1,195 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Definitions
let rec fold_left_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result _ -> init
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
fold_left_lets ~f ~init:(f init scope_let var) next
let rec fold_right_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result result -> init result
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
let next_result = fold_right_lets ~f ~init next in
f scope_let var next_result
let map_exprs_in_lets ~f ~varf scope_body_expr =
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 })
(Bindlib.bind_var (varf var_next) acc)
(f scope_let.scope_let_expr))
~init:(fun res -> Bindlib.box_apply (fun res -> Result res) (f res))
scope_body_expr
let rec fold_left ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
let var, next = Bindlib.unbind scope_def.scope_next in
fold_left ~f ~init:(f init scope_def var) next
let rec fold_right ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
let var_next, next = Bindlib.unbind scope_def.scope_next in
let result_next = fold_right ~f ~init next in
f scope_def var_next result_next
let map ~f scopes =
fold_right
~f:(fun scope_def var_next acc ->
let new_def = f scope_def in
let new_next = Bindlib.bind_var var_next acc in
Bindlib.box_apply2
(fun new_def new_next ->
ScopeDef { new_def with scope_next = new_next })
new_def new_next)
~init:(Bindlib.box Nil) scopes
let map_exprs ~f ~varf scopes =
fold_right
~f:(fun scope_def var_next acc ->
let scope_input_var, scope_lets =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let new_body_expr = map_exprs_in_lets ~f ~varf scope_lets in
let new_body_expr =
Bindlib.bind_var (varf scope_input_var) new_body_expr
in
let new_next = Bindlib.bind_var (varf var_next) acc in
Bindlib.box_apply2
(fun scope_body_expr scope_next ->
ScopeDef
{
scope_def with
scope_body = { scope_def.scope_body with scope_body_expr };
scope_next;
})
new_body_expr new_next)
~init:(Bindlib.box Nil) scopes
let get_body_mark scope_body =
match snd (Bindlib.unbind scope_body.scope_body_expr) with
| Result e | ScopeLet { scope_let_expr = e; _ } -> Marked.get_mark e
let rec unfold_body_expr (ctx : decl_ctx) (scope_let : 'e scope_body_expr) :
'e box =
match scope_let with
| Result e -> Expr.box e
| ScopeLet
{
scope_let_kind = _;
scope_let_typ;
scope_let_expr;
scope_let_next;
scope_let_pos;
} ->
let var, next = Bindlib.unbind scope_let_next in
Expr.make_let_in var scope_let_typ (Expr.box scope_let_expr)
(unfold_body_expr ctx next)
scope_let_pos
let build_typ_from_sig
(_ctx : decl_ctx)
(scope_input_struct_name : StructName.t)
(scope_return_struct_name : StructName.t)
(pos : Pos.t) : typ =
let input_typ = Marked.mark pos (TStruct scope_input_struct_name) in
let result_typ = Marked.mark pos (TStruct scope_return_struct_name) in
Marked.mark pos (TArrow (input_typ, result_typ))
type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
let to_expr (ctx : decl_ctx) (body : 'e scope_body) (mark_scope : 'm mark) :
'e box =
let var, body_expr = Bindlib.unbind body.scope_body_expr in
let body_expr = unfold_body_expr ctx body_expr in
Expr.make_abs [| var |] body_expr
[TStruct body.scope_body_input_struct, Expr.mark_pos mark_scope]
mark_scope
let format
?(debug : bool = false)
(ctx : decl_ctx)
(fmt : Format.formatter)
((n, s) : ScopeName.t * 'm scope_body) =
Format.fprintf fmt "@[<hov 2>%a %a =@ %a@]" Print.keyword "let"
ScopeName.format_t n (Expr.format ctx ~debug)
(Bindlib.unbox
(to_expr ctx s
(Expr.map_mark
(fun _ -> Marked.get_mark (ScopeName.get_info n))
(fun ty -> ty)
(get_body_mark s))))
let rec unfold
(ctx : decl_ctx)
(s : 'e scopes)
(mark : 'm mark)
(main_scope : 'expr scope_name_or_var) : 'e Bindlib.box =
match s with
| Nil -> (
match main_scope with
| ScopeVar v -> Bindlib.box_apply (fun v -> v, mark) (Bindlib.box_var v)
| ScopeName _ -> failwith "should not happen")
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, scope_next = Bindlib.unbind scope_next in
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
let scope_body_mark = get_body_mark scope_body in
let main_scope =
match main_scope with
| ScopeVar v -> ScopeVar v
| ScopeName n ->
if ScopeName.compare n scope_name = 0 then ScopeVar scope_var
else ScopeName n
in
Expr.make_let_in scope_var
(build_typ_from_sig ctx scope_body.scope_body_input_struct
scope_body.scope_body_output_struct scope_pos)
(to_expr ctx scope_body scope_body_mark)
(unfold ctx scope_next mark main_scope)
scope_pos
let rec free_vars_body_expr scope_lets =
match scope_lets with
| Result e -> Expr.free_vars e
| ScopeLet { scope_let_expr = e; scope_let_next = next; _ } ->
let v, body = Bindlib.unbind next in
Var.Set.union (Expr.free_vars e)
(Var.Set.remove v (free_vars_body_expr body))
let free_vars_body scope_body =
let { scope_body_expr = binder; _ } = scope_body in
let v, body = Bindlib.unbind binder in
Var.Set.remove v (free_vars_body_expr body)
let rec free_vars scopes =
match scopes with
| Nil -> Var.Set.empty
| ScopeDef { scope_body = body; scope_next = next; _ } ->
let v, next = Bindlib.unbind next in
Var.Set.union (Var.Set.remove v (free_vars next)) (free_vars_body body)

117
compiler/shared_ast/scope.mli Normal file
View File

@ -0,0 +1,117 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Functions handling the scope structures of [shared_ast] *)
open Utils
open Definitions
(** {2 Traversal functions} *)
val fold_left_lets :
f:('a -> 'e scope_let -> 'e Var.t -> 'a) ->
init:'a ->
'e scope_body_expr ->
'a
(** Usage:
[fold_left_lets ~f:(fun acc scope_let scope_let_var -> ...) ~init scope_lets],
where [scope_let_var] is the variable bound to the scope let in the next
scope lets to be examined. *)
val fold_right_lets :
f:('expr1 scope_let -> 'expr1 Var.t -> 'a -> 'a) ->
init:('expr1 -> 'a) ->
'expr1 scope_body_expr ->
'a
(** Usage:
[fold_right_lets ~f:(fun scope_let scope_let_var acc -> ...) ~init scope_lets],
where [scope_let_var] is the variable bound to the scope let in the next
scope lets to be examined (which are before in the program order). *)
val map_exprs_in_lets :
f:('expr1 -> 'expr2 box) ->
varf:('expr1 Var.t -> 'expr2 Var.t) ->
'expr1 scope_body_expr ->
'expr2 scope_body_expr box
val fold_left :
f:('a -> 'expr1 scope_def -> 'expr1 Var.t -> 'a) ->
init:'a ->
'expr1 scopes ->
'a
(** Usage: [fold_left ~f:(fun acc scope_def scope_var -> ...) ~init scope_def],
where [scope_var] is the variable bound to the scope in the next scopes to
be examined. *)
val fold_right :
f:('expr1 scope_def -> 'expr1 Var.t -> 'a -> 'a) ->
init:'a ->
'expr1 scopes ->
'a
(** Usage:
[fold_right_scope ~f:(fun scope_def scope_var acc -> ...) ~init scope_def],
where [scope_var] is the variable bound to the scope in the next scopes to
be examined (which are before in the program order). *)
val map : f:('e scope_def -> 'e scope_def box) -> 'e scopes -> 'e scopes box
val map_exprs :
f:('expr1 -> 'expr2 box) ->
varf:('expr1 Var.t -> 'expr2 Var.t) ->
'expr1 scopes ->
'expr2 scopes box
(** This is the main map visitor for all the expressions inside all the scopes
of the program. *)
val get_body_mark : (_, 'm mark) gexpr scope_body -> 'm mark
(** {2 Conversions} *)
val format :
?debug:bool (** [true] for debug printing *) ->
decl_ctx ->
Format.formatter ->
ScopeName.t * 'e scope_body ->
unit
val to_expr :
decl_ctx ->
('a any, 'm mark) gexpr scope_body ->
'm mark ->
('a, 'm mark) gexpr box
(** Usage: [to_expr ctx body scope_position] where [scope_position] corresponds
to the line of the scope declaration for instance. *)
type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
val unfold :
decl_ctx ->
((_, 'm mark) gexpr as 'e) scopes ->
'm mark ->
'e scope_name_or_var ->
'e box
val build_typ_from_sig :
decl_ctx -> StructName.t -> StructName.t -> Pos.t -> typ
(** [build_typ_from_sig ctx in_struct out_struct pos] builds the arrow type for
the specified scope *)
(** {2 Analysis and tests} *)
val free_vars_body_expr : 'e scope_body_expr -> 'e Var.Set.t
val free_vars_body : 'e scope_body -> 'e Var.Set.t
val free_vars : 'e scopes -> 'e Var.Set.t

29
compiler/lcalc/print.mli → compiler/shared_ast/shared_ast.ml
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
@ -14,24 +14,9 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
(** {1 Formatters} *)
val format_lit : Format.formatter -> Ast.lit Marked.pos -> unit
val format_var : Format.formatter -> 'm Ast.var -> unit
val format_exception : Format.formatter -> Ast.except -> unit
val format_expr :
?debug:bool ->
Dcalc.Ast.decl_ctx ->
Format.formatter ->
'm Ast.marked_expr ->
unit
val format_scope :
?debug:bool ->
Dcalc.Ast.decl_ctx ->
Format.formatter ->
Dcalc.Ast.ScopeName.t * ('m Ast.expr, 'm) Dcalc.Ast.scope_body ->
unit
include Definitions
module Var = Var
module Expr = Expr
module Scope = Scope
module Program = Program
module Print = Print

40
compiler/shared_ast/shared_ast.mld Normal file
View File

@ -0,0 +1,40 @@
{0 Default calculus}
This module contains a generic AST structure, various type definitions and
helpers that are reused in various passes of the compiler.
{1 The {!modules: Shared_ast.Definitions} module}
The main module {!modules: Shared_ast.Definitions} is exposed at top-level of
the library (so that [open Shared_ast] gives access to the structures). It
defines literals, operators, and in particular the type {!types:
Shared_ast.naked_gexpr}.
The {!types: Shared_ast.naked_gexpr} type regroups all the cases for the {{:
../dcalc.html} Dcalc} and {{: ../lcalc.html} Lcalc} ASTs, with unconstrained
annotations (used for positions, types, etc.). A GADT is used to eliminate
irrelevant cases, so that e.g. [(dcalc, _) naked_gexpr] doesn't have the [ERaise] and
[ECatch] cases, while [(lcalc, _) naked_gexpr] doesn't have [EDefault].
For example, Lcalc expressions are then defined as
[type 'm naked_expr = (Shared_ast.lcalc, 'm mark) Shared_ast.naked_gexpr].
This makes it possible to write a single function that works on the different
ASTs, by having it take a [('a, _) naked_gexpr] as input, while retaining a much
stricter policy than polymorphic variants.
The module additionally defines the encompassing [scope] and [program]
structures that are also shared between different compiler passes.
{1 Helper library}
The {!modules: Shared_ast.Var} defines ['e Var.Set.t] and [('e, _) Var.Map.t]
types that are useful to handle variables for the different ['e] expression
types without re-instanciating [Set.Make] and [Map.Make] each time.
{!modules: Shared_ast.Expr} contains various helpers to build well-formed
expressions, and for traversal.
{!modules: Shared_ast.Scope Shared_ast.Program} are dedicated to handling the
program structure around expressions. Note that these don't make sense for the
early compiler passes (up to [Scopelang]).

27
compiler/utils/var.ml → compiler/shared_ast/var.ml
View File

@ -14,28 +14,27 @@
License for the specific language governing permissions and limitations under
the License. *)
open Astgen
open Definitions
(** {1 Variables and their collections} *)
(** This module provides types and helpers for Bindlib variables on the
[Astgen.gexpr] type *)
(** This module provides types and helpers for Bindlib variables on the [gexpr]
type *)
(* The subtypes of the generic AST that hold vars *)
type 'e expr = 'e
constraint 'e = ([< desugared | scopelang | dcalc | lcalc ], 't) gexpr
type 'e t = ('a, 't) naked_gexpr Bindlib.var constraint 'e = ('a any, 't) gexpr
type 'e var = 'e expr Bindlib.var
type 'e t = 'e var
type 'e vars = 'e expr Bindlib.mvar
type 'e vars = ('a, 't) naked_gexpr Bindlib.mvar
constraint 'e = ('a any, 't) gexpr
let make (name : string) : 'e var = Bindlib.new_var (fun x -> EVar x) name
let make (name : string) : 'e t = Bindlib.new_var (fun x -> EVar x) name
let compare = Bindlib.compare_vars
let eq = Bindlib.eq_vars
let translate (v : 'e1 var) : 'e2 var =
let translate (v : 'e1 t) : 'e2 t =
Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
type 'e var = 'e t
(* The purpose of this module is just to lift a type parameter outside of
[Set.S] and [Map.S], so that we can have ['e Var.Set.t] for sets of variables
bound to the ['e = ('a, 't) gexpr] expression type. This is made possible by
@ -59,6 +58,7 @@ module Generic = struct
let t v = Var v
let get (Var v) = Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
let compare (Var x) (Var y) = Bindlib.compare_vars x y
let eq (Var x) (Var y) = Bindlib.eq_vars x y [@@ocaml.warning "-32"]
end
(* Wrapper around Set.Make to re-add type parameters (avoid inconsistent
@ -67,7 +67,7 @@ module Set = struct
open Generic
open Set.Make (Generic)
type nonrec 'e t = t constraint 'e = 'e expr
type nonrec 'e t = t
let empty = empty
let singleton x = singleton (t x)
@ -77,6 +77,7 @@ module Set = struct
let mem x s = mem (t x) s
let of_list l = of_list (List.map t l)
let elements s = elements s |> List.map get
let diff s1 s2 = diff s1 s2
(* Add more as needed *)
end
@ -87,7 +88,7 @@ module Map = struct
open Generic
open Map.Make (Generic)
type nonrec ('e, 'x) t = 'x t constraint 'e = 'e expr
type nonrec ('e, 'x) t = 'x t
let empty = empty
let singleton v x = singleton (t v) x

23
compiler/utils/var.mli → compiler/shared_ast/var.mli
View File

@ -14,20 +14,17 @@
License for the specific language governing permissions and limitations under
the License. *)
open Astgen
open Definitions
(** {1 Variables and their collections} *)
(** This module provides types and helpers for Bindlib variables on the
[Astgen.gexpr] type *)
(** This module provides types and helpers for Bindlib variables on the [gexpr]
type *)
type 'e expr = 'e
constraint 'e = ([< desugared | scopelang | dcalc | lcalc ], 't) gexpr
(** Subtype of Astgen.gexpr where variables are handled *)
type 'e t = ('a, 't) naked_gexpr Bindlib.var constraint 'e = ('a any, 't) gexpr
type 'e var = 'e expr Bindlib.var
type 'e t = 'e var
type 'e vars = 'e expr Bindlib.mvar
type 'e vars = ('a, 't) naked_gexpr Bindlib.mvar
constraint 'e = ('a any, 't) gexpr
val make : string -> 'e t
val compare : 'e t -> 'e t -> int
@ -37,10 +34,13 @@ val translate : 'e1 t -> 'e2 t
(** Needed when converting from one AST type to another. See the note of caution
on [Bindlib.copy_var]. *)
type 'e var = 'e t
(** Alias to allow referring to the type in the submodules *)
(** Wrapper over [Set.S] but with a type variable for the AST type parameters.
Extend as needed *)
module Set : sig
type 'e t constraint 'e = 'e expr
type 'e t
val empty : 'e t
val singleton : 'e var -> 'e t
@ -50,12 +50,13 @@ module Set : sig
val mem : 'e var -> 'e t -> bool
val of_list : 'e var list -> 'e t
val elements : 'e t -> 'e var list
val diff : 'e t -> 'e t -> 'e t
end
(** Wrapper over [Map.S] but with a type variable for the AST type parameters.
Extend as needed *)
module Map : sig
type ('e, 'x) t constraint 'e = 'e expr
type ('e, 'x) t
val empty : ('e, 'x) t
val singleton : 'e var -> 'x -> ('e, 'x) t

10
compiler/surface/ast.ml
View File

@ -134,7 +134,9 @@ type func_typ = {
nude = true;
}]
type typ = Base of base_typ | Func of func_typ
type typ = naked_typ Marked.pos
and naked_typ = Base of base_typ | Func of func_typ
[@@deriving
visitors
{
@ -153,7 +155,7 @@ type typ = Base of base_typ | Func of func_typ
type struct_decl_field = {
struct_decl_field_name : ident Marked.pos;
struct_decl_field_typ : typ Marked.pos;
struct_decl_field_typ : typ;
}
[@@deriving
visitors
@ -189,7 +191,7 @@ type struct_decl = {
type enum_decl_case = {
enum_decl_case_name : constructor Marked.pos;
enum_decl_case_typ : typ Marked.pos option;
enum_decl_case_typ : typ option;
}
[@@deriving
visitors
@ -671,7 +673,7 @@ type scope_decl_context_scope = {
type scope_decl_context_data = {
scope_decl_context_item_name : ident Marked.pos;
scope_decl_context_item_typ : typ Marked.pos;
scope_decl_context_item_typ : typ;
scope_decl_context_item_attribute : scope_decl_context_io;
scope_decl_context_item_states : ident Marked.pos list;
}

738
compiler/surface/desugaring.ml
View File

File diff suppressed because it is too large Load Diff

223
compiler/surface/name_resolution.ml
View File

@ -19,11 +19,11 @@
lexical scopes into account *)
open Utils
open Shared_ast
(** {1 Name resolution context} *)
type ident = string
type typ = Scopelang.Ast.typ
type unique_rulename =
| Ambiguous of Pos.t list
@ -35,58 +35,51 @@ type scope_def_context = {
}
type scope_context = {
var_idmap : Desugared.Ast.ScopeVar.t Desugared.Ast.IdentMap.t;
(** Scope variables *)
var_idmap : ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
scope_defs_contexts : scope_def_context Desugared.Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t;
sub_scopes_idmap : SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
sub_scopes : ScopeName.t Scopelang.Ast.SubScopeMap.t;
(** To what scope sub-scopes refer to? *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ Marked.pos Scopelang.Ast.StructFieldMap.t
type struct_context = typ StructFieldMap.t
(** Types of the fields of a struct *)
type enum_context = typ Marked.pos Scopelang.Ast.EnumConstructorMap.t
type enum_context = typ EnumConstructorMap.t
(** Types of the payloads of the cases of an enum *)
type var_sig = {
var_sig_typ : typ Marked.pos;
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_io : Ast.scope_decl_context_io;
var_sig_states_idmap : Desugared.Ast.StateName.t Desugared.Ast.IdentMap.t;
var_sig_states_list : Desugared.Ast.StateName.t list;
var_sig_states_idmap : StateName.t Desugared.Ast.IdentMap.t;
var_sig_states_list : StateName.t list;
}
type context = {
local_var_idmap : Desugared.Ast.Var.t Desugared.Ast.IdentMap.t;
local_var_idmap : Desugared.Ast.expr Var.t Desugared.Ast.IdentMap.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t;
scope_idmap : ScopeName.t Desugared.Ast.IdentMap.t;
(** The names of the scopes *)
struct_idmap : Scopelang.Ast.StructName.t Desugared.Ast.IdentMap.t;
struct_idmap : StructName.t Desugared.Ast.IdentMap.t;
(** The names of the structs *)
field_idmap :
Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t
Desugared.Ast.IdentMap.t;
field_idmap : StructFieldName.t StructMap.t Desugared.Ast.IdentMap.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t;
enum_idmap : EnumName.t Desugared.Ast.IdentMap.t;
(** The names of the enums *)
constructor_idmap :
Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t
Desugared.Ast.IdentMap.t;
constructor_idmap : EnumConstructor.t EnumMap.t Desugared.Ast.IdentMap.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context Scopelang.Ast.ScopeMap.t;
(** For each scope, its context *)
structs : struct_context Scopelang.Ast.StructMap.t;
(** For each struct, its context *)
enums : enum_context Scopelang.Ast.EnumMap.t;
(** For each enum, its context *)
var_typs : var_sig Desugared.Ast.ScopeVarMap.t;
structs : struct_context StructMap.t; (** For each struct, its context *)
enums : enum_context EnumMap.t; (** For each enum, its context *)
var_typs : var_sig ScopeVarMap.t;
(** The signatures of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
@ -107,36 +100,33 @@ let raise_unknown_identifier (msg : string) (ident : ident Marked.pos) =
msg
(** Gets the type associated to an uid *)
let get_var_typ (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) :
typ Marked.pos =
(Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_typ
let get_var_typ (ctxt : context) (uid : ScopeVar.t) : typ =
(ScopeVarMap.find uid ctxt.var_typs).var_sig_typ
let is_var_cond (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : bool =
(Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_is_condition
let is_var_cond (ctxt : context) (uid : ScopeVar.t) : bool =
(ScopeVarMap.find uid ctxt.var_typs).var_sig_is_condition
let get_var_io (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) :
Ast.scope_decl_context_io =
(Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_io
let get_var_io (ctxt : context) (uid : ScopeVar.t) : Ast.scope_decl_context_io =
(ScopeVarMap.find uid ctxt.var_typs).var_sig_io
(** Get the variable uid inside the scope given in argument *)
let get_var_uid
(scope_uid : Scopelang.Ast.ScopeName.t)
(scope_uid : ScopeName.t)
(ctxt : context)
((x, pos) : ident Marked.pos) : Desugared.Ast.ScopeVar.t =
((x, pos) : ident Marked.pos) : ScopeVar.t =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt x scope.var_idmap with
| None ->
raise_unknown_identifier
(Format.asprintf "for a variable of scope %a"
Scopelang.Ast.ScopeName.format_t scope_uid)
(Format.asprintf "for a variable of scope %a" ScopeName.format_t scope_uid)
(x, pos)
| Some uid -> uid
(** Get the subscope uid inside the scope given in argument *)
let get_subscope_uid
(scope_uid : Scopelang.Ast.ScopeName.t)
(scope_uid : ScopeName.t)
(ctxt : context)
((y, pos) : ident Marked.pos) : Scopelang.Ast.SubScopeName.t =
((y, pos) : ident Marked.pos) : SubScopeName.t =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt y scope.sub_scopes_idmap with
| None -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
@ -144,26 +134,21 @@ let get_subscope_uid
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
let is_subscope_uid
(scope_uid : Scopelang.Ast.ScopeName.t)
(ctxt : context)
(y : ident) : bool =
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : ident) :
bool =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.mem y scope.sub_scopes_idmap
(** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to
(ctxt : context)
(uid : Desugared.Ast.ScopeVar.t)
(scope_uid : Scopelang.Ast.ScopeName.t) : bool =
let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) :
bool =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.exists
(fun _ var_uid -> Desugared.Ast.ScopeVar.compare uid var_uid = 0)
(fun _ var_uid -> ScopeVar.compare uid var_uid = 0)
scope.var_idmap
(** Retrieves the type of a scope definition from the context *)
let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) :
typ Marked.pos =
let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : typ =
match def with
| Desugared.Ast.ScopeDef.SubScopeVar (_, x)
(* we don't need to look at the subscope prefix because [x] is already the uid
@ -183,7 +168,7 @@ let is_def_cond (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : bool =
(** Process a subscope declaration *)
let process_subscope_decl
(scope : Scopelang.Ast.ScopeName.t)
(scope : ScopeName.t)
(ctxt : context)
(decl : Ast.scope_decl_context_scope) : context =
let name, name_pos = decl.scope_decl_context_scope_name in
@ -195,15 +180,14 @@ let process_subscope_decl
| Some use ->
Errors.raise_multispanned_error
[
( Some "first use",
Marked.get_mark (Scopelang.Ast.SubScopeName.get_info use) );
Some "first use", Marked.get_mark (SubScopeName.get_info use);
Some "second use", s_pos;
]
"Subscope name \"%a\" already used"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
subscope
| None ->
let sub_scope_uid = Scopelang.Ast.SubScopeName.fresh (name, name_pos) in
let sub_scope_uid = SubScopeName.fresh (name, name_pos) in
let original_subscope_uid =
match Desugared.Ast.IdentMap.find_opt subscope ctxt.scope_idmap with
| None -> raise_unknown_identifier "for a scope" (subscope, s_pos)
@ -225,7 +209,7 @@ let process_subscope_decl
scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes;
}
let is_type_cond ((typ, _) : Ast.typ Marked.pos) =
let is_type_cond ((typ, _) : Ast.typ) =
match typ with
| Ast.Base Ast.Condition
| Ast.Func { arg_typ = _; return_typ = Ast.Condition, _ } ->
@ -235,30 +219,28 @@ let is_type_cond ((typ, _) : Ast.typ Marked.pos) =
(** Process a basic type (all types except function types) *)
let rec process_base_typ
(ctxt : context)
((typ, typ_pos) : Ast.base_typ Marked.pos) : Scopelang.Ast.typ Marked.pos =
((typ, typ_pos) : Ast.base_typ Marked.pos) : typ =
match typ with
| Ast.Condition -> Scopelang.Ast.TLit TBool, typ_pos
| Ast.Condition -> TLit TBool, typ_pos
| Ast.Data (Ast.Collection t) ->
( Scopelang.Ast.TArray
(Marked.unmark
(process_base_typ ctxt
(Ast.Data (Marked.unmark t), Marked.get_mark t))),
( TArray
(process_base_typ ctxt (Ast.Data (Marked.unmark t), Marked.get_mark t)),
typ_pos )
| Ast.Data (Ast.Primitive prim) -> (
match prim with
| Ast.Integer -> Scopelang.Ast.TLit TInt, typ_pos
| Ast.Decimal -> Scopelang.Ast.TLit TRat, typ_pos
| Ast.Money -> Scopelang.Ast.TLit TMoney, typ_pos
| Ast.Duration -> Scopelang.Ast.TLit TDuration, typ_pos
| Ast.Date -> Scopelang.Ast.TLit TDate, typ_pos
| Ast.Boolean -> Scopelang.Ast.TLit TBool, typ_pos
| Ast.Integer -> TLit TInt, typ_pos
| Ast.Decimal -> TLit TRat, typ_pos
| Ast.Money -> TLit TMoney, typ_pos
| Ast.Duration -> TLit TDuration, typ_pos
| Ast.Date -> TLit TDate, typ_pos
| Ast.Boolean -> TLit TBool, typ_pos
| Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Ast.Named ident -> (
match Desugared.Ast.IdentMap.find_opt ident ctxt.struct_idmap with
| Some s_uid -> Scopelang.Ast.TStruct s_uid, typ_pos
| Some s_uid -> TStruct s_uid, typ_pos
| None -> (
match Desugared.Ast.IdentMap.find_opt ident ctxt.enum_idmap with
| Some e_uid -> Scopelang.Ast.TEnum e_uid, typ_pos
| Some e_uid -> TEnum e_uid, typ_pos
| None ->
Errors.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
@ -266,18 +248,16 @@ let rec process_base_typ
ident)))
(** Process a type (function or not) *)
let process_type (ctxt : context) ((typ, typ_pos) : Ast.typ Marked.pos) :
Scopelang.Ast.typ Marked.pos =
match typ with
let process_type (ctxt : context) ((naked_typ, typ_pos) : Ast.typ) : typ =
match naked_typ with
| Ast.Base base_typ -> process_base_typ ctxt (base_typ, typ_pos)
| Ast.Func { arg_typ; return_typ } ->
( Scopelang.Ast.TArrow
(process_base_typ ctxt arg_typ, process_base_typ ctxt return_typ),
( TArrow (process_base_typ ctxt arg_typ, process_base_typ ctxt return_typ),
typ_pos )
(** Process data declaration *)
let process_data_decl
(scope : Scopelang.Ast.ScopeName.t)
(scope : ScopeName.t)
(ctxt : context)
(decl : Ast.scope_decl_context_data) : context =
(* First check the type of the context data *)
@ -289,14 +269,14 @@ let process_data_decl
| Some use ->
Errors.raise_multispanned_error
[
Some "First use:", Marked.get_mark (Desugared.Ast.ScopeVar.get_info use);
Some "First use:", Marked.get_mark (ScopeVar.get_info use);
Some "Second use:", pos;
]
"Variable name \"%a\" already used"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
name
| None ->
let uid = Desugared.Ast.ScopeVar.fresh (name, pos) in
let uid = ScopeVar.fresh (name, pos) in
let scope_ctxt =
{
scope_ctxt with
@ -306,7 +286,7 @@ let process_data_decl
let states_idmap, states_list =
List.fold_right
(fun state_id (states_idmap, states_list) ->
let state_uid = Desugared.Ast.StateName.fresh state_id in
let state_uid = StateName.fresh state_id in
( Desugared.Ast.IdentMap.add (Marked.unmark state_id) state_uid
states_idmap,
state_uid :: states_list ))
@ -317,7 +297,7 @@ let process_data_decl
ctxt with
scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes;
var_typs =
Desugared.Ast.ScopeVarMap.add uid
ScopeVarMap.add uid
{
var_sig_typ = data_typ;
var_sig_is_condition = is_cond;
@ -330,7 +310,7 @@ let process_data_decl
(** Process an item declaration *)
let process_item_decl
(scope : Scopelang.Ast.ScopeName.t)
(scope : ScopeName.t)
(ctxt : context)
(decl : Ast.scope_decl_context_item) : context =
match decl with
@ -339,8 +319,8 @@ let process_item_decl
(** Adds a binding to the context *)
let add_def_local_var (ctxt : context) (name : ident) :
context * Desugared.Ast.Var.t =
let local_var_uid = Desugared.Ast.Var.make name in
context * Desugared.Ast.expr Var.t =
let local_var_uid = Var.make name in
let ctxt =
{
ctxt with
@ -371,9 +351,7 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
(Marked.unmark sdecl.struct_decl_name);
List.fold_left
(fun ctxt (fdecl, _) ->
let f_uid =
Scopelang.Ast.StructFieldName.fresh fdecl.Ast.struct_decl_field_name
in
let f_uid = StructFieldName.fresh fdecl.Ast.struct_decl_field_name in
let ctxt =
{
ctxt with
@ -382,25 +360,24 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
(Marked.unmark fdecl.Ast.struct_decl_field_name)
(fun uids ->
match uids with
| None -> Some (Scopelang.Ast.StructMap.singleton s_uid f_uid)
| Some uids ->
Some (Scopelang.Ast.StructMap.add s_uid f_uid uids))
| None -> Some (StructMap.singleton s_uid f_uid)
| Some uids -> Some (StructMap.add s_uid f_uid uids))
ctxt.field_idmap;
}
in
{
ctxt with
structs =
Scopelang.Ast.StructMap.update s_uid
StructMap.update s_uid
(fun fields ->
match fields with
| None ->
Some
(Scopelang.Ast.StructFieldMap.singleton f_uid
(StructFieldMap.singleton f_uid
(process_type ctxt fdecl.Ast.struct_decl_field_typ))
| Some fields ->
Some
(Scopelang.Ast.StructFieldMap.add f_uid
(StructFieldMap.add f_uid
(process_type ctxt fdecl.Ast.struct_decl_field_typ)
fields))
ctxt.structs;
@ -420,9 +397,7 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
(Marked.unmark edecl.enum_decl_name);
List.fold_left
(fun ctxt (cdecl, cdecl_pos) ->
let c_uid =
Scopelang.Ast.EnumConstructor.fresh cdecl.Ast.enum_decl_case_name
in
let c_uid = EnumConstructor.fresh cdecl.Ast.enum_decl_case_name in
let ctxt =
{
ctxt with
@ -431,26 +406,24 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
(Marked.unmark cdecl.Ast.enum_decl_case_name)
(fun uids ->
match uids with
| None -> Some (Scopelang.Ast.EnumMap.singleton e_uid c_uid)
| Some uids -> Some (Scopelang.Ast.EnumMap.add e_uid c_uid uids))
| None -> Some (EnumMap.singleton e_uid c_uid)
| Some uids -> Some (EnumMap.add e_uid c_uid uids))
ctxt.constructor_idmap;
}
in
{
ctxt with
enums =
Scopelang.Ast.EnumMap.update e_uid
EnumMap.update e_uid
(fun cases ->
let typ =
match cdecl.Ast.enum_decl_case_typ with
| None -> Scopelang.Ast.TLit TUnit, cdecl_pos
| None -> TLit TUnit, cdecl_pos
| Some typ -> process_type ctxt typ
in
match cases with
| None ->
Some (Scopelang.Ast.EnumConstructorMap.singleton c_uid typ)
| Some fields ->
Some (Scopelang.Ast.EnumConstructorMap.add c_uid typ fields))
| None -> Some (EnumConstructorMap.singleton c_uid typ)
| Some fields -> Some (EnumConstructorMap.add c_uid typ fields))
ctxt.enums;
})
ctxt edecl.enum_decl_cases
@ -474,11 +447,9 @@ let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
(* Checks if the name is already used *)
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| Some use ->
raise_already_defined_error
(Scopelang.Ast.ScopeName.get_info use)
name pos "scope"
raise_already_defined_error (ScopeName.get_info use) name pos "scope"
| None ->
let scope_uid = Scopelang.Ast.ScopeName.fresh (name, pos) in
let scope_uid = ScopeName.fresh (name, pos) in
{
ctxt with
scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
@ -496,11 +467,9 @@ let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
let name, pos = sdecl.struct_decl_name in
match Desugared.Ast.IdentMap.find_opt name ctxt.struct_idmap with
| Some use ->
raise_already_defined_error
(Scopelang.Ast.StructName.get_info use)
name pos "struct"
raise_already_defined_error (StructName.get_info use) name pos "struct"
| None ->
let s_uid = Scopelang.Ast.StructName.fresh sdecl.struct_decl_name in
let s_uid = StructName.fresh sdecl.struct_decl_name in
{
ctxt with
struct_idmap =
@ -512,11 +481,9 @@ let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
let name, pos = edecl.enum_decl_name in
match Desugared.Ast.IdentMap.find_opt name ctxt.enum_idmap with
| Some use ->
raise_already_defined_error
(Scopelang.Ast.EnumName.get_info use)
name pos "enum"
raise_already_defined_error (EnumName.get_info use) name pos "enum"
| None ->
let e_uid = Scopelang.Ast.EnumName.fresh edecl.enum_decl_name in
let e_uid = EnumName.fresh edecl.enum_decl_name in
{
ctxt with
@ -561,14 +528,14 @@ let rec process_law_structure
let get_def_key
(name : Ast.qident)
(state : Ast.ident Marked.pos option)
(scope_uid : Scopelang.Ast.ScopeName.t)
(scope_uid : ScopeName.t)
(ctxt : context)
(default_pos : Pos.t) : Desugared.Ast.ScopeDef.t =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
match name with
| [x] ->
let x_uid = get_var_uid scope_uid ctxt x in
let var_sig = Desugared.Ast.ScopeVarMap.find x_uid ctxt.var_typs in
let var_sig = ScopeVarMap.find x_uid ctxt.var_typs in
Desugared.Ast.ScopeDef.Var
( x_uid,
match state with
@ -582,10 +549,10 @@ let get_def_key
[
None, Marked.get_mark state;
( Some "Variable declaration:",
Marked.get_mark (Desugared.Ast.ScopeVar.get_info x_uid) );
Marked.get_mark (ScopeVar.get_info x_uid) );
]
"This identifier is not a state declared for variable %a."
Desugared.Ast.ScopeVar.format_t x_uid)
ScopeVar.format_t x_uid)
| None ->
if not (Desugared.Ast.IdentMap.is_empty var_sig.var_sig_states_idmap)
then
@ -593,17 +560,15 @@ let get_def_key
[
None, Marked.get_mark x;
( Some "Variable declaration:",
Marked.get_mark (Desugared.Ast.ScopeVar.get_info x_uid) );
Marked.get_mark (ScopeVar.get_info x_uid) );
]
"This definition does not indicate which state has to be \
considered for variable %a."
Desugared.Ast.ScopeVar.format_t x_uid
ScopeVar.format_t x_uid
else None )
| [y; x] ->
let subscope_uid : Scopelang.Ast.SubScopeName.t =
get_subscope_uid scope_uid ctxt y
in
let subscope_real_uid : Scopelang.Ast.ScopeName.t =
let subscope_uid : SubScopeName.t = get_subscope_uid scope_uid ctxt y in
let subscope_real_uid : ScopeName.t =
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
in
let x_uid = get_var_uid subscope_real_uid ctxt x in
@ -616,7 +581,7 @@ let get_def_key
let process_definition
(ctxt : context)
(s_name : Scopelang.Ast.ScopeName.t)
(s_name : ScopeName.t)
(d : Ast.definition) : context =
(* We update the definition context inside the big context *)
{
@ -725,7 +690,7 @@ let process_definition
}
let process_scope_use_item
(s_name : Scopelang.Ast.ScopeName.t)
(s_name : ScopeName.t)
(ctxt : context)
(sitem : Ast.scope_use_item Marked.pos) : context =
match Marked.unmark sitem with
@ -763,11 +728,11 @@ let form_context (prgm : Ast.program) : context =
local_var_idmap = Desugared.Ast.IdentMap.empty;
scope_idmap = Desugared.Ast.IdentMap.empty;
scopes = Scopelang.Ast.ScopeMap.empty;
var_typs = Desugared.Ast.ScopeVarMap.empty;
structs = Scopelang.Ast.StructMap.empty;
var_typs = ScopeVarMap.empty;
structs = StructMap.empty;
struct_idmap = Desugared.Ast.IdentMap.empty;
field_idmap = Desugared.Ast.IdentMap.empty;
enums = Scopelang.Ast.EnumMap.empty;
enums = EnumMap.empty;
enum_idmap = Desugared.Ast.IdentMap.empty;
constructor_idmap = Desugared.Ast.IdentMap.empty;
}

75
compiler/surface/name_resolution.mli
View File

@ -19,11 +19,11 @@
lexical scopes into account *)
open Utils
open Shared_ast
(** {1 Name resolution context} *)
type ident = string
type typ = Scopelang.Ast.typ
type unique_rulename =
| Ambiguous of Pos.t list
@ -35,58 +35,51 @@ type scope_def_context = {
}
type scope_context = {
var_idmap : Desugared.Ast.ScopeVar.t Desugared.Ast.IdentMap.t;
(** Scope variables *)
var_idmap : ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
scope_defs_contexts : scope_def_context Desugared.Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t;
sub_scopes_idmap : SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
sub_scopes : ScopeName.t Scopelang.Ast.SubScopeMap.t;
(** To what scope sub-scopes refer to? *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ Marked.pos Scopelang.Ast.StructFieldMap.t
type struct_context = typ StructFieldMap.t
(** Types of the fields of a struct *)
type enum_context = typ Marked.pos Scopelang.Ast.EnumConstructorMap.t
type enum_context = typ EnumConstructorMap.t
(** Types of the payloads of the cases of an enum *)
type var_sig = {
var_sig_typ : typ Marked.pos;
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_io : Ast.scope_decl_context_io;
var_sig_states_idmap : Desugared.Ast.StateName.t Desugared.Ast.IdentMap.t;
var_sig_states_list : Desugared.Ast.StateName.t list;
var_sig_states_idmap : StateName.t Desugared.Ast.IdentMap.t;
var_sig_states_list : StateName.t list;
}
type context = {
local_var_idmap : Desugared.Ast.Var.t Desugared.Ast.IdentMap.t;
local_var_idmap : Desugared.Ast.expr Var.t Desugared.Ast.IdentMap.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t;
scope_idmap : ScopeName.t Desugared.Ast.IdentMap.t;
(** The names of the scopes *)
struct_idmap : Scopelang.Ast.StructName.t Desugared.Ast.IdentMap.t;
struct_idmap : StructName.t Desugared.Ast.IdentMap.t;
(** The names of the structs *)
field_idmap :
Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t
Desugared.Ast.IdentMap.t;
field_idmap : StructFieldName.t StructMap.t Desugared.Ast.IdentMap.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t;
enum_idmap : EnumName.t Desugared.Ast.IdentMap.t;
(** The names of the enums *)
constructor_idmap :
Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t
Desugared.Ast.IdentMap.t;
constructor_idmap : EnumConstructor.t EnumMap.t Desugared.Ast.IdentMap.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context Scopelang.Ast.ScopeMap.t;
(** For each scope, its context *)
structs : struct_context Scopelang.Ast.StructMap.t;
(** For each struct, its context *)
enums : enum_context Scopelang.Ast.EnumMap.t;
(** For each enum, its context *)
var_typs : var_sig Desugared.Ast.ScopeVarMap.t;
structs : struct_context StructMap.t; (** For each struct, its context *)
enums : enum_context EnumMap.t; (** For each enum, its context *)
var_typs : var_sig ScopeVarMap.t;
(** The signatures of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
@ -101,49 +94,39 @@ val raise_unknown_identifier : string -> ident Marked.pos -> 'a
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
val get_var_typ : context -> Desugared.Ast.ScopeVar.t -> typ Marked.pos
val get_var_typ : context -> ScopeVar.t -> typ
(** Gets the type associated to an uid *)
val is_var_cond : context -> Desugared.Ast.ScopeVar.t -> bool
val is_var_cond : context -> ScopeVar.t -> bool
val get_var_io : context -> ScopeVar.t -> Ast.scope_decl_context_io
val get_var_io :
context -> Desugared.Ast.ScopeVar.t -> Ast.scope_decl_context_io
val get_var_uid :
Scopelang.Ast.ScopeName.t ->
context ->
ident Marked.pos ->
Desugared.Ast.ScopeVar.t
val get_var_uid : ScopeName.t -> context -> ident Marked.pos -> ScopeVar.t
(** Get the variable uid inside the scope given in argument *)
val get_subscope_uid :
Scopelang.Ast.ScopeName.t ->
context ->
ident Marked.pos ->
Scopelang.Ast.SubScopeName.t
ScopeName.t -> context -> ident Marked.pos -> SubScopeName.t
(** Get the subscope uid inside the scope given in argument *)
val is_subscope_uid : Scopelang.Ast.ScopeName.t -> context -> ident -> bool
val is_subscope_uid : ScopeName.t -> context -> ident -> bool
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
val belongs_to :
context -> Desugared.Ast.ScopeVar.t -> Scopelang.Ast.ScopeName.t -> bool
val belongs_to : context -> ScopeVar.t -> ScopeName.t -> bool
(** Checks if the var_uid belongs to the scope scope_uid *)
val get_def_typ : context -> Desugared.Ast.ScopeDef.t -> typ Marked.pos
val get_def_typ : context -> Desugared.Ast.ScopeDef.t -> typ
(** Retrieves the type of a scope definition from the context *)
val is_def_cond : context -> Desugared.Ast.ScopeDef.t -> bool
val is_type_cond : Ast.typ Marked.pos -> bool
val is_type_cond : Ast.typ -> bool
val add_def_local_var : context -> ident -> context * Desugared.Ast.Var.t
val add_def_local_var : context -> ident -> context * Desugared.Ast.expr Var.t
(** Adds a binding to the context *)
val get_def_key :
Ast.qident ->
Ast.ident Marked.pos option ->
Scopelang.Ast.ScopeName.t ->
ScopeName.t ->
context ->
Pos.t ->
Desugared.Ast.ScopeDef.t

180
compiler/utils/astgen_utils.ml
View File

@ -1,180 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Astgen
(** Functions handling the types in [Astgen] *)
let evar v mark = Bindlib.box_apply (Marked.mark mark) (Bindlib.box_var v)
let etuple args s mark =
Bindlib.box_apply (fun args -> ETuple (args, s), mark) (Bindlib.box_list args)
let etupleaccess e1 i s typs mark =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), mark) e1
let einj e1 i e_name typs mark =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), mark) e1
let ematch arg arms e_name mark =
Bindlib.box_apply2
(fun arg arms -> EMatch (arg, arms, e_name), mark)
arg (Bindlib.box_list arms)
let earray args mark =
Bindlib.box_apply (fun args -> EArray args, mark) (Bindlib.box_list args)
let elit l mark = Bindlib.box (ELit l, mark)
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) binder
let eapp e1 args mark =
Bindlib.box_apply2
(fun e1 args -> EApp (e1, args), mark)
e1 (Bindlib.box_list args)
let eassert e1 mark = Bindlib.box_apply (fun e1 -> EAssert e1, mark) e1
let eop op mark = Bindlib.box (EOp op, mark)
let edefault excepts just cons mark =
Bindlib.box_apply3
(fun excepts just cons -> EDefault (excepts, just, cons), mark)
(Bindlib.box_list excepts) just cons
let eifthenelse e1 e2 e3 mark =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), mark) e1 e2 e3
let eerroronempty e1 mark =
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, mark) e1
let eraise e1 pos = Bindlib.box (ERaise e1, pos)
let ecatch e1 exn e2 pos =
Bindlib.box_apply2 (fun e1 e2 -> ECatch (e1, exn, e2), pos) e1 e2
let translate_var v = Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
let map_gexpr
(type a)
(ctx : 'ctx)
~(f : 'ctx -> (a, 'm1) marked_gexpr -> (a, 'm2) marked_gexpr Bindlib.box)
(e : ((a, 'm1) gexpr, 'm2) Marked.t) : (a, 'm2) marked_gexpr Bindlib.box =
let m = Marked.get_mark e in
match Marked.unmark e with
| ELit l -> elit l m
| EApp (e1, args) -> eapp (f ctx e1) (List.map (f ctx) args) m
| EOp op -> Bindlib.box (EOp op, m)
| EArray args -> earray (List.map (f ctx) args) m
| EVar v -> evar (translate_var v) m
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
eabs (Bindlib.bind_mvar (Array.map translate_var vars) (f ctx body)) typs m
| EIfThenElse (e1, e2, e3) ->
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) m
| ETuple (args, s) -> etuple (List.map (f ctx) args) s m
| ETupleAccess (e1, n, s_name, typs) ->
etupleaccess ((f ctx) e1) n s_name typs m
| EInj (e1, i, e_name, typs) -> einj ((f ctx) e1) i e_name typs m
| EMatch (arg, arms, e_name) ->
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name m
| EAssert e1 -> eassert ((f ctx) e1) m
| EDefault (excepts, just, cons) ->
edefault (List.map (f ctx) excepts) ((f ctx) just) ((f ctx) cons) m
| ErrorOnEmpty e1 -> eerroronempty ((f ctx) e1) m
| ECatch (e1, exn, e2) -> ecatch (f ctx e1) exn (f ctx e2) (Marked.get_mark e)
| ERaise exn -> eraise exn (Marked.get_mark e)
let rec map_gexpr_top_down ~f e =
map_gexpr () ~f:(fun () -> map_gexpr_top_down ~f) (f e)
let map_gexpr_marks ~f e =
map_gexpr_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
let rec fold_left_scope_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result _ -> init
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
fold_left_scope_lets ~f ~init:(f init scope_let var) next
let rec fold_right_scope_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result result -> init result
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
let next_result = fold_right_scope_lets ~f ~init next in
f scope_let var next_result
let map_exprs_in_scope_lets ~f ~varf scope_body_expr =
fold_right_scope_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 })
(Bindlib.bind_var (varf var_next) acc)
(f scope_let.scope_let_expr))
~init:(fun res -> Bindlib.box_apply (fun res -> Result res) (f res))
scope_body_expr
let rec fold_left_scope_defs ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
let var, next = Bindlib.unbind scope_def.scope_next in
fold_left_scope_defs ~f ~init:(f init scope_def var) next
let rec fold_right_scope_defs ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
let var_next, next = Bindlib.unbind scope_def.scope_next in
let result_next = fold_right_scope_defs ~f ~init next in
f scope_def var_next result_next
let map_scope_defs ~f scopes =
fold_right_scope_defs
~f:(fun scope_def var_next acc ->
let new_scope_def = f scope_def in
let new_next = Bindlib.bind_var var_next acc in
Bindlib.box_apply2
(fun new_scope_def new_next ->
ScopeDef { new_scope_def with scope_next = new_next })
new_scope_def new_next)
~init:(Bindlib.box Nil) scopes
let map_exprs_in_scopes ~f ~varf scopes =
fold_right_scope_defs
~f:(fun scope_def var_next acc ->
let scope_input_var, scope_lets =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let new_scope_body_expr = map_exprs_in_scope_lets ~f ~varf scope_lets in
let new_scope_body_expr =
Bindlib.bind_var (varf scope_input_var) new_scope_body_expr
in
let new_next = Bindlib.bind_var (varf var_next) acc in
Bindlib.box_apply2
(fun scope_body_expr scope_next ->
ScopeDef
{
scope_def with
scope_body = { scope_def.scope_body with scope_body_expr };
scope_next;
})
new_scope_body_expr new_next)
~init:(Bindlib.box Nil) scopes

183
compiler/utils/astgen_utils.mli
View File

@ -1,183 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Functions handling the types in [Astgen] *)
open Astgen
(** {2 Boxed constructors} *)
val evar :
(([< desugared | scopelang | dcalc | lcalc ] as 'a), 't) gexpr Bindlib.var ->
't ->
('a, 't) marked_gexpr Bindlib.box
val etuple :
(([< dcalc | lcalc ] as 'a), 't) marked_gexpr Bindlib.box list ->
StructName.t option ->
't ->
('a, 't) marked_gexpr Bindlib.box
val etupleaccess :
(([< dcalc | lcalc ] as 'a), 't) marked_gexpr Bindlib.box ->
int ->
StructName.t option ->
marked_typ list ->
't ->
('a, 't) marked_gexpr Bindlib.box
val einj :
(([< dcalc | lcalc ] as 'a), 't) marked_gexpr Bindlib.box ->
int ->
EnumName.t ->
marked_typ list ->
't ->
('a, 't) marked_gexpr Bindlib.box
val ematch :
(([< dcalc | lcalc ] as 'a), 't) marked_gexpr Bindlib.box ->
('a, 't) marked_gexpr Bindlib.box list ->
EnumName.t ->
't ->
('a, 't) marked_gexpr Bindlib.box
val earray :
('a, 't) marked_gexpr Bindlib.box list ->
't ->
('a, 't) marked_gexpr Bindlib.box
val elit : 'a glit -> 't -> ('a, 't) marked_gexpr Bindlib.box
val eabs :
( (([< desugared | scopelang | dcalc | lcalc ] as 'a), 't) gexpr,
('a, 't) marked_gexpr )
Bindlib.mbinder
Bindlib.box ->
marked_typ list ->
't ->
('a, 't) marked_gexpr Bindlib.box
val eapp :
('a, 't) marked_gexpr Bindlib.box ->
('a, 't) marked_gexpr Bindlib.box list ->
't ->
('a, 't) marked_gexpr Bindlib.box
val eassert :
(([< dcalc | lcalc ] as 'a), 't) marked_gexpr Bindlib.box ->
't ->
('a, 't) marked_gexpr Bindlib.box
val eop : operator -> 't -> ('a, 't) marked_gexpr Bindlib.box
val edefault :
(([< desugared | scopelang | dcalc ] as 'a), 't) marked_gexpr Bindlib.box list ->
('a, 't) marked_gexpr Bindlib.box ->
('a, 't) marked_gexpr Bindlib.box ->
't ->
('a, 't) marked_gexpr Bindlib.box
val eifthenelse :
(([< desugared | scopelang | dcalc | lcalc ] as 'a), 't) marked_gexpr
Bindlib.box ->
('a, 't) marked_gexpr Bindlib.box ->
('a, 't) marked_gexpr Bindlib.box ->
't ->
('a, 't) marked_gexpr Bindlib.box
val eerroronempty :
(([< desugared | scopelang | dcalc ] as 'a), 't) marked_gexpr Bindlib.box ->
't ->
('a, 't) marked_gexpr Bindlib.box
(** ---------- *)
val map_gexpr :
'ctx ->
f:('ctx -> ('a, 't1) marked_gexpr -> ('a, 't2) marked_gexpr Bindlib.box) ->
(('a, 't1) gexpr, 't2) Marked.t ->
('a, 't2) marked_gexpr Bindlib.box
val map_gexpr_top_down :
f:(('a, 't1) marked_gexpr -> (('a, 't1) gexpr, 't2) Marked.t) ->
('a, 't1) marked_gexpr ->
('a, 't2) marked_gexpr Bindlib.box
(** Recursively applies [f] to the nodes of the expression tree. The type
returned by [f] is hybrid since the mark at top-level has been rewritten,
but not yet the marks in the subtrees. *)
val map_gexpr_marks :
f:('t1 -> 't2) -> ('a, 't1) marked_gexpr -> ('a, 't2) marked_gexpr Bindlib.box
val fold_left_scope_lets :
f:('a -> ('expr, 'm) scope_let -> 'expr Bindlib.var -> 'a) ->
init:'a ->
('expr, 'm) scope_body_expr ->
'a
(** Usage:
[fold_left_scope_lets ~f:(fun acc scope_let scope_let_var -> ...) ~init scope_lets],
where [scope_let_var] is the variable bound to the scope let in the next
scope lets to be examined. *)
val fold_right_scope_lets :
f:(('expr1, 'm1) scope_let -> 'expr1 Bindlib.var -> 'a -> 'a) ->
init:(('expr1, 'm1) marked -> 'a) ->
('expr1, 'm1) scope_body_expr ->
'a
(** Usage:
[fold_right_scope_lets ~f:(fun scope_let scope_let_var acc -> ...) ~init scope_lets],
where [scope_let_var] is the variable bound to the scope let in the next
scope lets to be examined (which are before in the program order). *)
val map_exprs_in_scope_lets :
f:(('expr1, 'm1) marked -> ('expr2, 'm2) marked Bindlib.box) ->
varf:('expr1 Bindlib.var -> 'expr2 Bindlib.var) ->
('expr1, 'm1) scope_body_expr ->
('expr2, 'm2) scope_body_expr Bindlib.box
val fold_left_scope_defs :
f:('a -> ('expr1, 'm1) scope_def -> 'expr1 Bindlib.var -> 'a) ->
init:'a ->
('expr1, 'm1) scopes ->
'a
(** Usage:
[fold_left_scope_defs ~f:(fun acc scope_def scope_var -> ...) ~init scope_def],
where [scope_var] is the variable bound to the scope in the next scopes to
be examined. *)
val fold_right_scope_defs :
f:(('expr1, 'm1) scope_def -> 'expr1 Bindlib.var -> 'a -> 'a) ->
init:'a ->
('expr1, 'm1) scopes ->
'a
(** Usage:
[fold_right_scope_defs ~f:(fun scope_def scope_var acc -> ...) ~init scope_def],
where [scope_var] is the variable bound to the scope in the next scopes to
be examined (which are before in the program order). *)
val map_scope_defs :
f:(('expr, 'm) scope_def -> ('expr, 'm) scope_def Bindlib.box) ->
('expr, 'm) scopes ->
('expr, 'm) scopes Bindlib.box
val map_exprs_in_scopes :
f:(('expr1, 'm1) marked -> ('expr2, 'm2) marked Bindlib.box) ->
varf:('expr1 Bindlib.var -> 'expr2 Bindlib.var) ->
('expr1, 'm1) scopes ->
('expr2, 'm2) scopes Bindlib.box
(** This is the main map visitor for all the expressions inside all the scopes
of the program. *)

12
compiler/utils/uid.ml
View File

@ -17,7 +17,10 @@
module type Info = sig
type info
val to_string : info -> string
val format_info : Format.formatter -> info -> unit
val equal : info -> info -> bool
val compare : info -> info -> int
end
module type Id = sig
@ -27,6 +30,7 @@ module type Id = sig
val fresh : info -> t
val get_info : t -> info
val compare : t -> t -> int
val equal : t -> t -> bool
val format_t : Format.formatter -> t -> unit
val hash : t -> int
end
@ -43,9 +47,10 @@ module Make (X : Info) () : Id with type info = X.info = struct
let get_info (uid : t) : X.info = uid.info
let compare (x : t) (y : t) : int = compare x.id y.id
let equal x y = Int.equal x.id y.id
let format_t (fmt : Format.formatter) (x : t) : unit =
Format.fprintf fmt "%a" X.format_info x.info
X.format_info fmt x.info
let hash (x : t) : int = x.id
end
@ -53,5 +58,8 @@ end
module MarkedString = struct
type info = string Marked.pos
let format_info fmt (s, _) = Format.fprintf fmt "%s" s
let to_string (s, _) = s
let format_info fmt i = Format.pp_print_string fmt (to_string i)
let equal i1 i2 = String.equal (Marked.unmark i1) (Marked.unmark i2)
let compare i1 i2 = String.compare (Marked.unmark i1) (Marked.unmark i2)
end

8
compiler/utils/uid.mli
View File

@ -20,7 +20,14 @@
module type Info = sig
type info
val to_string : info -> string
val format_info : Format.formatter -> info -> unit
val equal : info -> info -> bool
(** Equality disregards position *)
val compare : info -> info -> int
(** Comparison disregards position *)
end
module MarkedString : Info with type info = string Marked.pos
@ -38,6 +45,7 @@ module type Id = sig
val fresh : info -> t
val get_info : t -> info
val compare : t -> t -> int
val equal : t -> t -> bool
val format_t : Format.formatter -> t -> unit
val hash : t -> int
end

51
compiler/verification/conditions.ml
View File

@ -16,20 +16,21 @@
the License. *)
open Utils
open Shared_ast
open Dcalc
open Ast
(** {1 Helpers and type definitions}*)
type vc_return = typed marked_expr * (typed expr, typ Marked.pos) Var.Map.t
type vc_return = typed expr * (typed expr, typ) Var.Map.t
(** The return type of VC generators is the VC expression plus the types of any
locally free variable inside that expression. *)
type ctx = {
current_scope_name : ScopeName.t;
decl : decl_ctx;
input_vars : typed var list;
scope_variables_typs : (typed expr, typ Marked.pos) Var.Map.t;
input_vars : typed expr Var.t list;
scope_variables_typs : (typed expr, typ) Var.Map.t;
}
let conjunction (args : vc_return list) (mark : typed mark) : vc_return =
@ -73,8 +74,8 @@ let half_product (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list =
variables, or [fun () -> e1] for subscope variables. But what we really want
to analyze is only [e1], so we match this outermost structure explicitely
and have a clean verification condition generator that only runs on [e1] *)
let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed marked_expr)
: typed marked_expr =
let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
typed expr =
match Marked.unmark e with
| ErrorOnEmpty
( EDefault
@ -92,11 +93,11 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed marked_expr)
| ErrorOnEmpty d ->
d (* input subscope variables and non-input scope variable *)
| _ ->
Errors.raise_spanned_error (pos e)
Errors.raise_spanned_error (Expr.pos e)
"Internal error: this expression does not have the structure expected by \
the VC generator:\n\
%a"
(Print.format_expr ~debug:true ctx.decl)
(Expr.format ~debug:true ctx.decl)
e
(** {1 Verification conditions generator}*)
@ -105,7 +106,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed marked_expr)
[b] such that if [b] is true, then [e] will never return an empty error. It
also returns a map of all the types of locally free variables inside the
expression. *)
let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed marked_expr) :
let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
vc_return =
let out =
match Marked.unmark e with
@ -131,10 +132,10 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed marked_expr) :
(generate_vc_must_not_return_empty ctx) body
in
( vc_body_expr,
List.fold_left
(fun acc (var, ty) -> Var.Map.add var ty acc)
vc_body_ty
(List.map2 (fun x y -> x, y) (Array.to_list vars) typs) )
snd
@@ List.fold_left
(fun (i, acc) ty -> i + 1, Var.Map.add vars.(i) ty acc)
(0, vc_body_ty) typs )
| EApp (f, args) ->
(* We assume here that function calls never return empty error, which implies
all functions have been checked never to return empty errors. *)
@ -199,8 +200,8 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed marked_expr) :
[b] such that if [b] is true, then [e] will never return a conflict error.
It also returns a map of all the types of locally free variables inside the
expression. *)
let rec generate_vs_must_not_return_confict (ctx : ctx) (e : typed marked_expr)
: vc_return =
let rec generate_vs_must_not_return_confict (ctx : ctx) (e : typed expr) :
vc_return =
let out =
(* See the code of [generate_vc_must_not_return_empty] for a list of invariants on which this
function relies on. *)
@ -282,17 +283,17 @@ let rec generate_vs_must_not_return_confict (ctx : ctx) (e : typed marked_expr)
type verification_condition_kind = NoEmptyError | NoOverlappingExceptions
type verification_condition = {
vc_guard : typed marked_expr;
vc_guard : typed expr;
(* should have type bool *)
vc_kind : verification_condition_kind;
vc_scope : ScopeName.t;
vc_variable : typed var Marked.pos;
vc_free_vars_typ : (typed expr, typ Marked.pos) Var.Map.t;
vc_variable : typed expr Var.t Marked.pos;
vc_free_vars_typ : (typed expr, typ) Var.Map.t;
}
let rec generate_verification_conditions_scope_body_expr
(ctx : ctx)
(scope_body_expr : ('m expr, 'm) scope_body_expr) :
(scope_body_expr : 'm expr scope_body_expr) :
ctx * verification_condition list =
match scope_body_expr with
| Result _ -> ctx, []
@ -310,7 +311,9 @@ let rec generate_verification_conditions_scope_body_expr
what we're really doing is adding exceptions to something defined in
the subscope so we just ought to verify only that the exceptions
overlap. *)
let e = Bindlib.unbox (remove_logging_calls scope_let.scope_let_expr) in
let e =
Bindlib.unbox (Expr.remove_logging_calls scope_let.scope_let_expr)
in
let e = match_and_ignore_outer_reentrant_default ctx e in
let vc_confl, vc_confl_typs =
generate_vs_must_not_return_confict ctx e
@ -375,15 +378,14 @@ let rec generate_verification_conditions_scope_body_expr
let rec generate_verification_conditions_scopes
(decl_ctx : decl_ctx)
(scopes : ('m expr, 'm) scopes)
(scopes : 'm expr scopes)
(s : ScopeName.t option) : verification_condition list =
match scopes with
| Nil -> []
| ScopeDef scope_def ->
let is_selected_scope =
match s with
| Some s when Dcalc.Ast.ScopeName.compare s scope_def.scope_name = 0 ->
true
| Some s when ScopeName.compare s scope_def.scope_name = 0 -> true
| None -> true
| _ -> false
in
@ -414,9 +416,8 @@ let rec generate_verification_conditions_scopes
let _scope_var, next = Bindlib.unbind scope_def.scope_next in
generate_verification_conditions_scopes decl_ctx next s @ vcs
let generate_verification_conditions
(p : 'm program)
(s : Dcalc.Ast.ScopeName.t option) : verification_condition list =
let generate_verification_conditions (p : 'm program) (s : ScopeName.t option) :
verification_condition list =
let vcs = generate_verification_conditions_scopes p.decl_ctx p.scopes s in
(* We sort this list by scope name and then variable name to ensure consistent
output for testing*)

14
compiler/verification/conditions.mli
View File

@ -18,6 +18,7 @@
(** Generates verification conditions from scope definitions *)
open Utils
open Shared_ast
type verification_condition_kind =
| NoEmptyError
@ -28,22 +29,19 @@ type verification_condition_kind =
a conflict error *)
type verification_condition = {
vc_guard : Dcalc.Ast.typed Dcalc.Ast.marked_expr;
vc_guard : typed Dcalc.Ast.expr;
(** This expression should have type [bool]*)
vc_kind : verification_condition_kind;
vc_scope : Dcalc.Ast.ScopeName.t;
vc_variable : Astgen.typed Dcalc.Ast.var Marked.pos;
vc_free_vars_typ :
(Astgen.typed Dcalc.Ast.expr, Dcalc.Ast.typ Marked.pos) Var.Map.t;
vc_scope : ScopeName.t;
vc_variable : typed Dcalc.Ast.expr Var.t Marked.pos;
vc_free_vars_typ : (typed Dcalc.Ast.expr, typ) Var.Map.t;
(** Types of the locally free variables in [vc_guard]. The types of other
free variables linked to scope variables can be obtained with
[Dcalc.Ast.variable_types]. *)
}
val generate_verification_conditions :
Dcalc.Ast.typed Dcalc.Ast.program ->
Dcalc.Ast.ScopeName.t option ->
verification_condition list
typed Dcalc.Ast.program -> ScopeName.t option -> verification_condition list
(** [generate_verification_conditions p None] will generate the verification
conditions for all the variables of all the scopes of the program [p], while
[generate_verification_conditions p (Some s)] will focus only on the

24
compiler/verification/io.ml
View File

@ -16,6 +16,7 @@
the License. *)
open Utils
open Shared_ast
open Dcalc.Ast
module type Backend = sig
@ -23,8 +24,7 @@ module type Backend = sig
type backend_context
val make_context :
decl_ctx -> (typed expr, typ Marked.pos) Var.Map.t -> backend_context
val make_context : decl_ctx -> (typed expr, typ) Var.Map.t -> backend_context
type vc_encoding
@ -38,9 +38,7 @@ module type Backend = sig
val is_model_empty : model -> bool
val translate_expr :
backend_context ->
Astgen.typed Dcalc.Ast.marked_expr ->
backend_context * vc_encoding
backend_context -> typed Dcalc.Ast.expr -> backend_context * vc_encoding
end
module type BackendIO = sig
@ -48,15 +46,12 @@ module type BackendIO = sig
type backend_context
val make_context :
decl_ctx -> (Astgen.typed expr, typ Marked.pos) Var.Map.t -> backend_context
val make_context : decl_ctx -> (typed expr, typ) Var.Map.t -> backend_context
type vc_encoding
val translate_expr :
backend_context ->
Astgen.typed Dcalc.Ast.marked_expr ->
backend_context * vc_encoding
backend_context -> typed Dcalc.Ast.expr -> backend_context * vc_encoding
type model
@ -73,9 +68,7 @@ module type BackendIO = sig
string
val encode_and_check_vc :
Dcalc.Ast.decl_ctx ->
Conditions.verification_condition * vc_encoding_result ->
unit
decl_ctx -> Conditions.verification_condition * vc_encoding_result -> unit
end
module MakeBackendIO (B : Backend) = struct
@ -161,15 +154,14 @@ module MakeBackendIO (B : Backend) = struct
let vc, z3_vc = vc in
Cli.debug_print "For this variable:\n%s\n"
(Pos.retrieve_loc_text (pos vc.Conditions.vc_guard));
(Pos.retrieve_loc_text (Expr.pos vc.Conditions.vc_guard));
Cli.debug_format "This verification condition was generated for %a:@\n%a"
(Cli.format_with_style [ANSITerminal.yellow])
(match vc.vc_kind with
| Conditions.NoEmptyError ->
"the variable definition never to return an empty error"
| NoOverlappingExceptions -> "no two exceptions to ever overlap")
(Dcalc.Print.format_expr decl_ctx)
vc.vc_guard;
(Expr.format decl_ctx) vc.vc_guard;
match z3_vc with
| Success (encoding, backend_ctx) -> (

22
compiler/verification/io.mli
View File

@ -17,7 +17,7 @@
(** Common code for handling the IO of all proof backends supported *)
open Utils
open Shared_ast
module type Backend = sig
val init_backend : unit -> unit
@ -25,9 +25,7 @@ module type Backend = sig
type backend_context
val make_context :
Dcalc.Ast.decl_ctx ->
(Astgen.typed Dcalc.Ast.expr, Dcalc.Ast.typ Utils.Marked.pos) Var.Map.t ->
backend_context
decl_ctx -> (typed Dcalc.Ast.expr, typ) Var.Map.t -> backend_context
type vc_encoding
@ -41,9 +39,7 @@ module type Backend = sig
val is_model_empty : model -> bool
val translate_expr :
backend_context ->
Astgen.typed Dcalc.Ast.marked_expr ->
backend_context * vc_encoding
backend_context -> typed Dcalc.Ast.expr -> backend_context * vc_encoding
end
module type BackendIO = sig
@ -52,16 +48,12 @@ module type BackendIO = sig
type backend_context
val make_context :
Dcalc.Ast.decl_ctx ->
(Astgen.typed Dcalc.Ast.expr, Dcalc.Ast.typ Utils.Marked.pos) Var.Map.t ->
backend_context
decl_ctx -> (typed Dcalc.Ast.expr, typ) Var.Map.t -> backend_context
type vc_encoding
val translate_expr :
backend_context ->
Astgen.typed Dcalc.Ast.marked_expr ->
backend_context * vc_encoding
backend_context -> typed Dcalc.Ast.expr -> backend_context * vc_encoding
type model
@ -78,9 +70,7 @@ module type BackendIO = sig
string
val encode_and_check_vc :
Dcalc.Ast.decl_ctx ->
Conditions.verification_condition * vc_encoding_result ->
unit
decl_ctx -> Conditions.verification_condition * vc_encoding_result -> unit
end
module MakeBackendIO : functor (B : Backend) ->

4
compiler/verification/solver.ml
View File

@ -14,13 +14,11 @@
License for the specific language governing permissions and limitations under
the License. *)
open Dcalc.Ast
(** [solve_vc] is the main entry point of this module. It takes a list of
expressions [vcs] corresponding to verification conditions that must be
discharged by Z3, and attempts to solve them **)
let solve_vc
(decl_ctx : decl_ctx)
(decl_ctx : Shared_ast.decl_ctx)
(vcs : Conditions.verification_condition list) : unit =
(* Right now we only use the Z3 backend but the functorial interface should
make it easy to mix and match different proof backends. *)

2
compiler/verification/solver.mli
View File

@ -17,4 +17,4 @@
(** Solves verification conditions using various proof backends *)
val solve_vc :
Dcalc.Ast.decl_ctx -> Conditions.verification_condition list -> unit
Shared_ast.decl_ctx -> Conditions.verification_condition list -> unit

74
compiler/verification/z3backend.real.ml
View File

@ -15,6 +15,7 @@
the License. *)
open Utils
open Shared_ast
open Dcalc
open Ast
open Z3
@ -27,13 +28,13 @@ type context = {
ctx_decl : decl_ctx;
(* The declaration context from the Catala program, containing information to
precisely pretty print Catala expressions *)
ctx_var : (typed expr, typ Marked.pos) Var.Map.t;
ctx_var : (typed expr, typ) Var.Map.t;
(* A map from Catala variables to their types, needed to create Z3 expressions
of the right sort *)
ctx_funcdecl : (typed expr, FuncDecl.func_decl) Var.Map.t;
(* A map from Catala function names (represented as variables) to Z3 function
declarations, used to only define once functions in Z3 queries *)
ctx_z3vars : typed var StringMap.t;
ctx_z3vars : typed expr Var.t StringMap.t;
(* A map from strings, corresponding to Z3 symbol names, to the Catala
variable they represent. Used when to pretty-print Z3 models when a
counterexample is generated *)
@ -65,13 +66,15 @@ type context = {
(** [add_funcdecl] adds the mapping between the Catala variable [v] and the Z3
function declaration [fd] to the context **)
let add_funcdecl (v : typed var) (fd : FuncDecl.func_decl) (ctx : context) :
context =
let add_funcdecl
(v : typed expr Var.t)
(fd : FuncDecl.func_decl)
(ctx : context) : context =
{ ctx with ctx_funcdecl = Var.Map.add v fd ctx.ctx_funcdecl }
(** [add_z3var] adds the mapping between [name] and the Catala variable [v] to
the context **)
let add_z3var (name : string) (v : typed var) (ctx : context) : context =
let add_z3var (name : string) (v : typed expr Var.t) (ctx : context) : context =
{ ctx with ctx_z3vars = StringMap.add name v ctx.ctx_z3vars }
(** [add_z3enum] adds the mapping between the Catala enumeration [enum] and the
@ -82,7 +85,8 @@ let add_z3enum (enum : EnumName.t) (sort : Sort.sort) (ctx : context) : context
(** [add_z3var] adds the mapping between temporary variable [v] and the Z3
expression [e] representing an accessor application to the context **)
let add_z3matchsubst (v : typed var) (e : Expr.expr) (ctx : context) : context =
let add_z3matchsubst (v : typed expr Var.t) (e : Expr.expr) (ctx : context) :
context =
{ ctx with ctx_z3matchsubsts = Var.Map.add v e ctx.ctx_z3matchsubsts }
(** [add_z3struct] adds the mapping between the Catala struct [s] and the
@ -100,7 +104,7 @@ let base_day = Runtime.date_of_numbers 1900 1 1
(** [unique_name] returns the full, unique name corresponding to variable [v],
as given by Bindlib **)
let unique_name (v : 'm var) : string =
let unique_name (v : 'e Var.t) : string =
Format.asprintf "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
(** [date_to_int] translates [date] to an integer corresponding to the number of
@ -125,8 +129,7 @@ let nb_days_to_date (nb : int) : string =
(** [print_z3model_expr] pretty-prints the value [e] given by a Z3 model
according to the Catala type [ty], corresponding to [e] **)
let rec print_z3model_expr (ctx : context) (ty : typ Marked.pos) (e : Expr.expr)
: string =
let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
let print_lit (ty : typ_lit) =
match ty with
(* TODO: Print boolean according to current language *)
@ -158,7 +161,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ Marked.pos) (e : Expr.expr)
match Marked.unmark ty with
| TLit ty -> print_lit ty
| TTuple (_, Some name) ->
| TStruct name ->
let s = StructMap.find name ctx.ctx_decl.ctx_structs in
let get_fieldname (fn : StructFieldName.t) : string =
Marked.unmark (StructFieldName.get_info fn)
@ -176,9 +179,9 @@ let rec print_z3model_expr (ctx : context) (ty : typ Marked.pos) (e : Expr.expr)
Format.asprintf "%s { %s }"
(Marked.unmark (StructName.get_info name))
fields_str
| TTuple (_, None) ->
| TTuple _ ->
failwith "[Z3 model]: Pretty-printing of unnamed structs not supported"
| TEnum (_tys, name) ->
| TEnum name ->
(* The value associated to the enum is a single argument *)
let e' = List.hd (Expr.get_args e) in
let fd = Expr.get_func_decl e in
@ -193,6 +196,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ Marked.pos) (e : Expr.expr)
in
Format.asprintf "%s (%s)" fd_name (print_z3model_expr ctx (snd case) e')
| TOption _ -> failwith "[Z3 model]: Pretty-printing of options not supported"
| TArrow _ -> failwith "[Z3 model]: Pretty-printing of arrows not supported"
| TArray _ ->
(* For now, only the length of arrays is modeled *)
@ -258,13 +262,13 @@ let translate_typ_lit (ctx : context) (t : typ_lit) : Sort.sort =
| TDuration -> Arithmetic.Integer.mk_sort ctx.ctx_z3
(** [translate_typ] returns the Z3 sort correponding to the Catala type [t] **)
let rec translate_typ (ctx : context) (t : typ) : context * Sort.sort =
let rec translate_typ (ctx : context) (t : naked_typ) : context * Sort.sort =
match t with
| TLit t -> ctx, translate_typ_lit ctx t
| TTuple (_, Some name) -> find_or_create_struct ctx name
| TTuple (_, None) ->
failwith "[Z3 encoding] TTuple type of unnamed struct not supported"
| TEnum (_, e) -> find_or_create_enum ctx e
| TStruct name -> find_or_create_struct ctx name
| TTuple _ -> failwith "[Z3 encoding] TTuple type not supported"
| TEnum e -> find_or_create_enum ctx e
| TOption _ -> failwith "[Z3 encoding] TOption type not supported"
| TArrow _ -> failwith "[Z3 encoding] TArrow type not supported"
| TArray _ ->
(* For now, we are only encoding the (symbolic) length of an array.
@ -279,9 +283,7 @@ let rec translate_typ (ctx : context) (t : typ) : context * Sort.sort =
and find_or_create_enum (ctx : context) (enum : EnumName.t) :
context * Sort.sort =
(* Creates a Z3 constructor corresponding to the Catala constructor [c] *)
let create_constructor
(ctx : context)
(c : EnumConstructor.t * typ Marked.pos) :
let create_constructor (ctx : context) (c : EnumConstructor.t * typ) :
context * Datatype.Constructor.constructor =
let name, ty = c in
let name = Marked.unmark (EnumConstructor.get_info name) in
@ -385,7 +387,7 @@ let translate_lit (ctx : context) (l : lit) : Expr.expr =
corresponding to the variable [v]. If no such function declaration exists
yet, we construct it and add it to the context, thus requiring to return a
new context *)
let find_or_create_funcdecl (ctx : context) (v : typed var) :
let find_or_create_funcdecl (ctx : context) (v : typed expr Var.t) :
context * FuncDecl.func_decl =
match Var.Map.find_opt v ctx.ctx_funcdecl with
| Some fd -> ctx, fd
@ -415,10 +417,8 @@ let is_leap_year (n : int) = failwith "Unimplemented!"
(** [translate_op] returns the Z3 expression corresponding to the application of
[op] to the arguments [args] **)
let rec translate_op
(ctx : context)
(op : operator)
(args : 'm marked_expr list) : context * Expr.expr =
let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
context * Expr.expr =
match op with
| Ternop _top ->
let _e1, _e2, _e3 =
@ -428,10 +428,12 @@ let rec translate_op
failwith
(Format.asprintf
"[Z3 encoding] Ill-formed ternary operator application: %a"
(Print.format_expr ctx.ctx_decl)
(Shared_ast.Expr.format ctx.ctx_decl)
( EApp
( (EOp op, Untyped { pos = Pos.no_pos }),
List.map (fun arg -> Bindlib.unbox (untype_expr arg)) args ),
List.map
(fun arg -> Bindlib.unbox (Shared_ast.Expr.untype arg))
args ),
Untyped { pos = Pos.no_pos } ))
in
@ -519,11 +521,12 @@ let rec translate_op
failwith
(Format.asprintf
"[Z3 encoding] Ill-formed binary operator application: %a"
(Print.format_expr ctx.ctx_decl)
(Shared_ast.Expr.format ctx.ctx_decl)
( EApp
( (EOp op, Untyped { pos = Pos.no_pos }),
List.map
(fun arg -> arg |> untype_expr |> Bindlib.unbox)
(fun arg ->
arg |> Shared_ast.Expr.untype |> Bindlib.unbox)
args ),
Untyped { pos = Pos.no_pos } ))
in
@ -571,11 +574,11 @@ let rec translate_op
failwith
(Format.asprintf
"[Z3 encoding] Ill-formed unary operator application: %a"
(Print.format_expr ctx.ctx_decl)
(Shared_ast.Expr.format ctx.ctx_decl)
( EApp
( (EOp op, Untyped { pos = Pos.no_pos }),
List.map
(fun arg -> arg |> untype_expr |> Bindlib.unbox)
(fun arg -> arg |> Shared_ast.Expr.untype |> Bindlib.unbox)
args ),
Untyped { pos = Pos.no_pos } ))
in
@ -623,11 +626,11 @@ let rec translate_op
(** [translate_expr] translate the expression [vc] to its corresponding Z3
expression **)
and translate_expr (ctx : context) (vc : 'm marked_expr) : context * Expr.expr =
and translate_expr (ctx : context) (vc : 'm expr) : context * Expr.expr =
let translate_match_arm
(head : Expr.expr)
(ctx : context)
(e : 'm marked_expr * FuncDecl.func_decl list) : context * Expr.expr =
(e : 'm expr * FuncDecl.func_decl list) : context * Expr.expr =
let e, accessors = e in
match Marked.unmark e with
| EAbs (e, _) ->
@ -797,7 +800,7 @@ module Backend = struct
let is_model_empty (m : model) : bool = List.length (Z3.Model.get_decls m) = 0
let translate_expr (ctx : backend_context) (e : 'm marked_expr) =
let translate_expr (ctx : backend_context) (e : 'm expr) =
translate_expr ctx e
let init_backend () =
@ -805,8 +808,7 @@ module Backend = struct
let make_context
(decl_ctx : decl_ctx)
(free_vars_typ : (typed expr, typ Marked.pos) Var.Map.t) : backend_context
=
(free_vars_typ : (typed expr, typ) Var.Map.t) : backend_context =
let cfg =
(if !Cli.disable_counterexamples then [] else ["model", "true"])
@ ["proof", "false"]

2
dune-project
View File

@ -1,4 +1,4 @@
(lang dune 2.8)
(lang dune 3.0)
(name catala)

16
examples/Makefile
View File

@ -8,16 +8,18 @@ CLERK=_build/default/build_system/clerk.exe --exe "_build/default/compiler/catal
# Running legislation unit tests
################################
pass_all_tests:
@cd ..;OCAMLRUNPARAM= $(CLERK) examples
reset_all_tests: CLERK_OPTS+=--reset
reset_all_tests:
@cd ..;OCAMLRUNPARAM= $(CLERK) examples
%.catala_en %.catala_fr %.catala_pl: .FORCE
# Here we cd to the root of the Catala repository such that the paths \
# displayed in error messages start with `examples/` uniformly.
@cd ..;$(CLERK) examples/$@
TEST_FILES?=$(wildcard */*.catala*)
pass_tests: $(TEST_FILES)
reset_tests: CLERK_OPTS+=--reset
reset_tests: $(TEST_FILES)
@cd ..;OCAMLRUNPARAM= $(CLERK) examples/$@
.FORCE:
.PHONY: pass_all_tests reset_all_tests

13
examples/README.md
View File

@ -10,11 +10,13 @@ of the Catala programming language development.
## List of examples
- `allocations_familiales/`: computation of the French family benefits, based
on the _Code de la sécurité sociale_. This case study is the biggest and
on the _Code de la sécurité sociale_.
- `aides_logement`: computation of the French housing benefits, based on the
_Code de la construction et de l'habitation_. This case study is the biggest and
most ambitious for Catala so far.
- `code_general_impots/`: computation of the French income tax, based on the
_Code général des impôts_. Currently, there are only stubs of program.
- `tutorial/`: Catala language tutorial for developers of tech-savvy lawyers.
- `tutorial_<en/fr>/`: Catala language tutorial for developers of tech-savvy lawyers.
The tutorial is written like a piece of legislation that gets annotated by
Catala snippets.
- `us_tax_code/`: contains the Catala formalization of several sections of the
@ -74,9 +76,12 @@ compilation of the whole program using the standard expected by `clerk test`:
enter `make help_clerk` from the root of the Catala repository to know more.
Once your tests are written, then will automatically be added to the regression
suite executed using
suite executed using:
make -C examples tests
# From the root of the Catala repository
make test_examples
# From the examples/ folder
make pass_all_tests
You can isolate a part of the regression suite by invoking:

6
examples/aides_logement/arrete_2019-09-27.catala_fr
View File

@ -393,7 +393,7 @@ TL est exprimé en pourcentage et arrondi à la troisième décimale.
Le tableau suivant traduit cette formule :
Si $\textrm{RL}<45\%$ Si $45\% < \textrm{RL} < 75\%$ Si $\textrm{RL} >75 \%$
------------------- ------------------------------------------ -----------------------------------------------------------
--------------------- --------------------------------------------- ---------------------------------------------------------------
$\textrm{TL}=0 \%$ $\textrm{TL}=0,45 \%\times (\textrm{RL}-45\%)$ $\textrm{TL}=0,45\%\times30 \%+0,68 \%\times(\textrm{RL}-75\%)$
```catala
@ -2518,8 +2518,8 @@ dispositions sont applicables pour les prestations dues à compter
du 1er octobre 2021.
```catala
champ d'application CalculAidePersonnaliséeLogementAccessionPropriété sous condition
date_courante >=@ |2021-10-01|:
champ d'application CalculAidePersonnaliséeLogementAccessionPropriété
sous condition date_courante >=@ |2021-10-01|:
étiquette base définition montant_forfaitaire_charges_d832_10 égal à
54,22 € +€ 12,29 € *€ (entier_vers_décimal de nombre_personnes_à_charge)

3
examples/aides_logement/autres_sources.catala_fr
View File

@ -243,7 +243,8 @@ champ d'application CalculetteAidesAuLogementGardeAlternée:
sinon
# On retire la part des allocations logement dues aux enfants
# en garde alternée à hauteur des coefficients prenant en compte la
# période cumulée pendant laquelle le ménage accueille l'enfant à domicile.
# période cumulée pendant laquelle le ménage accueille l'enfant
# à domicile.
(calculette.aide_finale_formule -€
calculette_sans_garde_alternée.aide_finale_formule) *€
((somme décimal pour coeff dans

16
examples/aides_logement/code_construction_legislatif.catala_fr
View File

@ -313,7 +313,8 @@ contrat de travail autre qu'un contrat à durée indéterminée.
```catala
# Information donnée par le bureau DGALN/DHUP/FE4 le 25/05/2022:
# "Historiquement, cet article avait été créé pour déroger (pour les moins
# de 25 ans) au dispositif « d’évaluation forfaitaire » appliqué, avant réforme,
# de 25 ans) au dispositif « d’évaluation forfaitaire » appliqué,
# avant réforme,
# pour les ménages présentant un revenu moindre en N-2 mais ayant une activité
# professionnelle lors de la demande ou du recalcul du droit (anciens articles
# R. 822-18 à 20 du CCH abrogés en 2020). Cet article n’a de fait plus lieu
@ -712,7 +713,8 @@ champ d'application ÉligibilitéAidePersonnaliséeLogement:
étiquette l831_2_base règle condition_logement_prêt rempli
# Cas de base implicite
étiquette l831_2_1 exception l831_2_base règle condition_logement_prêt sous condition
étiquette l831_2_1 exception l831_2_base règle condition_logement_prêt
sous condition
selon ménage.logement.mode_occupation sous forme
-- LocationAccession de propriété:
propriété.prêt.date_signature >=@ |2017-12-31|
@ -799,7 +801,9 @@ est fixée par voie réglementaire.
```catala
champ d'application CalculAidePersonnaliséeLogementLocatif:
définition traitement_aide_finale de aide_finale état réduction_loyer_solidarité égal à
définition traitement_aide_finale de aide_finale
état réduction_loyer_solidarité
égal à
soit aide_finale égal à traitement_aide_finale de aide_finale dans
si
aide_finale -€ réduction_loyer_solidarité *€ fraction_l832_3 >=€ 0€
@ -896,7 +900,8 @@ champ d'application ÉligibilitéAllocationLogement:
-- a_déjà_ouvert_droit_aux_allocations_familiales:
enfant.EnfantÀCharge.a_déjà_ouvert_droit_aux_allocations_familiales
-- bénéficie_titre_personnel_aide_personnelle_logement:
enfant.EnfantÀCharge.bénéficie_titre_personnel_aide_personnelle_logement
enfant.EnfantÀCharge.
bénéficie_titre_personnel_aide_personnelle_logement
}
)
)) = 1
@ -927,7 +932,8 @@ champ d'application ÉligibilitéAllocationLogement:
-- a_déjà_ouvert_droit_aux_allocations_familiales:
enfant.EnfantÀCharge.a_déjà_ouvert_droit_aux_allocations_familiales
-- bénéficie_titre_personnel_aide_personnelle_logement:
enfant.EnfantÀCharge.bénéficie_titre_personnel_aide_personnelle_logement
enfant.EnfantÀCharge.
bénéficie_titre_personnel_aide_personnelle_logement
}
)
)) = 0 et

29
examples/aides_logement/code_construction_reglementaire.catala_fr
View File

@ -1118,8 +1118,8 @@ peuvent être remises en cause par les parents qu'au bout d'un an, sauf
modification, avant cette échéance, des modalités de résidence de l'enfant.
```catala
# Pas pertinent pour le calcul du montant: il s'agit de s'assurer que les parents
# ne changent pas les modalités de résidence tous les quatre matins.
# Pas pertinent pour le calcul du montant: il s'agit de s'assurer que les
# parents ne changent pas les modalités de résidence tous les quatre matins.
```
####### Article R823-4 | LEGIARTI000038878933
@ -1947,8 +1947,8 @@ d'ouverture du droit sont réunies ;
d'être réunies.
```catala
# Cet article met en place des délais qu'il n'est pas nécessaire de codifier pour
# le moment.
# Cet article met en place des délais qu'il n'est pas nécessaire de codifier
# pour le moment.
```
######## Article D823-15 | LEGIARTI000038878909
@ -2002,7 +2002,8 @@ dans le cas où le logement occupé est une chambre, de la composition familiale
```catala
champ d'application CalculAidePersonnaliséeLogementLocatif:
définition loyer_éligible égal à
si loyer_principal >€ plafond_loyer_d823_16_2 alors plafond_loyer_d823_16_2
si loyer_principal >€ plafond_loyer_d823_16_2
alors plafond_loyer_d823_16_2
sinon loyer_principal
```
@ -2046,7 +2047,9 @@ champ d'application CalculAidePersonnaliséeLogementLocatif:
# a bien cette expression.
sinon aide_finale)
exception définition traitement_aide_finale de aide_finale état diminué sous condition
exception définition traitement_aide_finale de aide_finale
état diminué
sous condition
bénéficiaire_aide_adulte_ou_enfant_handicapés
conséquence égal à aide_finale
@ -2057,7 +2060,9 @@ Le résultat ainsi obtenu est minoré d'un montant fixé forfaitairement par arr
```catala
champ d'application CalculAidePersonnaliséeLogementLocatif:
définition traitement_aide_finale de aide_finale état minoration_forfaitaire égal à
définition traitement_aide_finale de aide_finale
état minoration_forfaitaire
égal à
soit aide_finale égal à traitement_aide_finale de aide_finale dans
si
aide_finale -€ montant_forfaitaire_d823_16 >=€ 0€
@ -3422,8 +3427,8 @@ II du présent livre et arrondies à la centaine d'euros supérieure ;
# est en effet une reprise peut-être maladroite et perfectible de l’ancien
# article (avant recodification, abrogé depuis) R. 351-19 qui est plus clair
# sur cette notion d’intervalle :
# « Le coefficient K, au plus égal à 0,95, est déterminé pour chaque intervalle
# de ressources de 100 euros en appliquant la formule suivante :
# « Le coefficient K, au plus égal à 0,95, est déterminé pour chaque
# intervalle de ressources de 100 euros en appliquant la formule suivante :
# K = 0,95-R/ CM x N
# dans laquelle :
# R représente la limite supérieure de l'intervalle dans lequel se situent
@ -4383,9 +4388,9 @@ au calcul de l'allocation de logement versée en secteur locatif, sous réserve
des articles D. 842-2 et D. 842-4.
```catala
# Rien à formaliser ici, voir le prologue sur la déclaration du champ d'application
# de calcul des allocations logement qui appelle directement le champ d'application
# de calcul de l'APL en secteur locatif.
# Rien à formaliser ici, voir le prologue sur la déclaration du
# champ d'application de calcul des allocations logement qui appelle
# directement le champ d'application de calcul de l'APL en secteur locatif.
```
####### Article D842-2 | LEGIARTI000038878685

93
examples/allocations_familiales/decrets_divers.catala_fr
View File

@ -246,7 +246,8 @@ A compter de 2021 57,28 € 5,88 % 32 %
champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
# Premier enfant
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2011-01-01| et date_courante <=@ |2011-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -254,7 +255,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 14,50 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2012-01-01| et date_courante <=@ |2012-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -262,7 +264,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 13,93 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2013-01-01| et date_courante <=@ |2013-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -270,7 +273,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 13,35 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2014-01-01| et date_courante <=@ |2014-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -278,7 +282,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 12,78 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2015-01-01| et date_courante <=@ |2015-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -286,7 +291,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 12,20 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2016-01-01| et date_courante <=@ |2016-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -294,7 +300,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 11,63 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2017-01-01| et date_courante <=@ |2017-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -302,7 +309,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 11,05 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2018-01-01| et date_courante <=@ |2018-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -310,7 +318,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 9,76 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2019-01-01| et date_courante <=@ |2019-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -318,7 +327,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 8,47 %
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
date_courante >=@ |2020-01-01| et date_courante <=@ |2020-12-31| et
non avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
@ -326,7 +336,8 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
alors bmaf.montant *€ 7,17%
sinon 0 €
exception mayotte définition montant_initial_base_premier_enfant sous condition
exception mayotte définition montant_initial_base_premier_enfant
sous condition
avait_enfant_à_charge_avant_1er_janvier_2012
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 0
@ -334,70 +345,80 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
sinon 0 €
# Deuxième enfant
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2011-01-01| et date_courante <=@ |2011-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 23,2 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2012-01-01| et date_courante <=@ |2012-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 23,79 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2013-01-01| et date_courante <=@ |2013-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 24,37 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2014-01-01| et date_courante <=@ |2014-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 24,96 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2015-01-01| et date_courante <=@ |2015-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 25,55 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2016-01-01| et date_courante <=@ |2016-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 26,13 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2017-01-01| et date_courante <=@ |2017-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 26,72 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2018-01-01| et date_courante <=@ |2018-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 28,04 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2019-01-01| et date_courante <=@ |2019-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
alors bmaf.montant *€ 29,36 %
sinon 0 €
exception mayotte définition montant_initial_base_deuxième_enfant sous condition
exception mayotte définition montant_initial_base_deuxième_enfant
sous condition
date_courante >=@ |2020-01-01| et date_courante <=@ |2020-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 1
@ -405,70 +426,80 @@ champ d'application AllocationsFamiliales sous condition résidence = Mayotte:
sinon 0 €
# Troisième enfant
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2011-01-01| et date_courante <=@ |2011-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 4,63 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2012-01-01| et date_courante <=@ |2012-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 5,39 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2013-01-01| et date_courante <=@ |2013-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 6,15 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2014-01-01| et date_courante <=@ |2014-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 6,90 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2015-01-01| et date_courante <=@ |2015-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 7,66 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2016-01-01| et date_courante <=@ |2016-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 8,42 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2017-01-01| et date_courante <=@ |2017-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 9,18 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2018-01-01| et date_courante <=@ |2018-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 10,89 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2019-01-01| et date_courante <=@ |2019-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2
alors bmaf.montant *€ 12,59 %
sinon 0 €
exception définition montant_initial_base_troisième_enfant_mayotte sous condition
exception définition montant_initial_base_troisième_enfant_mayotte
sous condition
date_courante >=@ |2020-01-01| et date_courante <=@ |2020-12-31|
conséquence égal à
si nombre de enfants_à_charge_droit_ouvert_prestation_familiale > 2

14
examples/allocations_familiales/securite_sociale_D.catala_fr
View File

@ -165,7 +165,8 @@ champ d'application AllocationsFamiliales :
(ressources_ménage >€ plafond_I_d521_3) et
(ressources_ménage <=€ plafond_I_d521_3 +€ allocation *€ 12,0 )
conséquence égal à
(plafond_I_d521_3 +€ allocation *€ 12,0 -€ ressources_ménage) *€ (1,0 /. 12,0)
(plafond_I_d521_3 +€ allocation *€ 12,0 -€ ressources_ménage) *€
(1,0 /. 12,0)
exception
définition complément_dégressif de allocation
@ -173,7 +174,8 @@ champ d'application AllocationsFamiliales :
(ressources_ménage >€ plafond_II_d521_3) et
(ressources_ménage <=€ plafond_II_d521_3 +€ allocation *€ 12,0)
conséquence égal à
(plafond_II_d521_3 +€ allocation *€ 12,0 -€ ressources_ménage) *€ (1,0 /. 12,0)
(plafond_II_d521_3 +€ allocation *€ 12,0 -€ ressources_ménage) *€
(1,0 /. 12,0)
# Dans les autres cas, le dépassement est nul
définition complément_dégressif de allocations égal à 0 €
@ -210,8 +212,8 @@ de calcul des allocations familiales par enfant ;
```catala
# TODO Liane: la syntaxe de la phrase est très ambiguë, on a l'impression que
# c'est la BMAF qui est "par enfant" et pas le montant de l'allocation forfaitaire
# Erreur de rédaction ? Problème juridique ?
# c'est la BMAF qui est "par enfant" et pas le montant de l'allocation
# forfaitaire. Erreur de rédaction ? Problème juridique ?
champ d'application AllocationsFamiliales :
définition montant_versé_forfaitaire_par_enfant sous condition
@ -320,8 +322,8 @@ l'année civile de référence, par arrêté des ministres chargés de la sécur
sociale, du budget et de l'agriculture.
```catala
# Nota : ces montants sont en réalités remis à jour chaque année par des décrets,
# voir decrets_divers.catala_fr
# Nota : ces montants sont en réalités remis à jour chaque année par des
# décrets, voir decrets_divers.catala_fr
```
#### Livre 7 : Régimes divers - Dispositions diverses

6
examples/allocations_familiales/securite_sociale_L.catala_fr
View File

@ -397,9 +397,9 @@ Les allocations familiales sont dues, pour tout enfant, à la personne qui a
effectivement la charge de celui-ci.
```catala
# TODO Liane: Angle mort, ici c'est marqué "effectivement la charge" mais dans l'article de
# L521-2 il faut charge effective ET permanente. Pourquoi cette différence ?
# Quelles conséquences pratiques ?
# TODO Liane: Angle mort, ici c'est marqué "effectivement la charge" mais dans
# l'article de L521-2 il faut charge effective ET permanente. Pourquoi
# cette différence ? Quelles conséquences pratiques ?
# Apparemment en 1987 il y avait encore des exceptions pour certains agents
# publics d'outre-mer

9
examples/allocations_familiales/securite_sociale_R.catala_fr
View File

@ -13,9 +13,9 @@ ans sous réserve que leur rémunération n'excède pas le plafond fixé au deux
alinéa du présent article.
```catala
# Attention: ici la condition de ressources au dessous du plafond est une répétition
# par rapport au texte de L512-3. On ne remet donc pas le code ici correspondant
# à cette limitation.
# Attention: ici la condition de ressources au dessous du plafond est une
# répétition par rapport au texte de L512-3. On ne remet donc pas le code ici
# correspondant à cette limitation.
champ d'application PrestationsFamiliales :
définition âge_l512_3_2 égal à 20 an
@ -173,7 +173,8 @@ alinéa de l'article R. 521-3.
```catala
# Le renvoi ci-dessus ne fait qu'annoncer qu'on va appliquer un système
# de décote pour garde alternée au système de majorations.
# Ce renvoi signifie que notre liste enfants_à_charge_droit_ouvert_prestation_familiale
# Ce renvoi signifie que notre liste
# enfants_à_charge_droit_ouvert_prestation_familiale
# qui était utilisée pour la prestation de base est la même que la liste
# d'enfant utilisée pour le calcul des majorations
```

3
examples/polish_taxes/podatek_od_czynnosci_cywilnoprawnych/rozdzial_3.catala_pl
View File

@ -91,7 +91,8 @@ deklaracja zakres PozyczkaLubDepozytNieprawidlowy:
zakres PozyczkaLubDepozytNieprawidlowy:
definicja podatek wynosi
kwota *$ stawka_podatku # TODO: extract somehow? this exists in every declaration
kwota *$ stawka_podatku # TODO: extract somehow?
# this exists in every declaration
zakres PozyczkaLubDepozytNieprawidlowy:
definicja stawka_podatku wynosi 0.5%

6
examples/prestations_familiales/sécurité_sociale_L.catala_fr
View File

@ -56,7 +56,8 @@ tout enfant dont la rémunération éventuelle n'excède pas un plafond.
champ d'application ÉligibilitéPrestationsFamiliales :
étiquette cas_base règle droit_ouvert de enfant sous condition
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Après et
(enfant.EnfantPrestationsFamiliales.rémuneration_mensuelle <=€ plafond_l512_3_2) et
(enfant.EnfantPrestationsFamiliales.rémuneration_mensuelle <=€
plafond_l512_3_2) et
(enfant.EnfantPrestationsFamiliales.date_de_naissance +@ âge_l512_3_2 >@
date_courante)
conséquence rempli
@ -67,7 +68,8 @@ champ d'application ÉligibilitéPrestationsFamiliales :
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Avant ou
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Pendant ou
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Après et
(enfant.EnfantPrestationsFamiliales.rémuneration_mensuelle <=€ plafond_l512_3_2)
(enfant.EnfantPrestationsFamiliales.rémuneration_mensuelle <=€
plafond_l512_3_2)
conséquence rempli
```

6
examples/prestations_familiales/sécurité_sociale_R.catala_fr
View File

@ -13,9 +13,9 @@ ans sous réserve que leur rémunération n'excède pas le plafond fixé au deux
alinéa du présent article.
```catala
# Attention: ici la condition de ressources au dessous du plafond est une répétition
# par rapport au texte de L512-3. On ne remet donc pas le code ici correspondant
# à cette limitation.
# Attention: ici la condition de ressources au dessous du plafond est une
# répétition par rapport au texte de L512-3. On ne remet donc pas le code
# ici correspondant à cette limitation.
champ d'application ÉligibilitéPrestationsFamiliales :
définition âge_l512_3_2 égal à 20 an

6
examples/tutorial_en/tutorial_en.catala_en
View File

@ -600,9 +600,9 @@ scope BasisForFineDetermination :
# But then, how to account for the provision of the law that reverts the
# mechanism canceling taxes for individuals earning less than $10,000 dollars?
# This is where the "context" concept comes into play. Indeed, we had annotated
# the "income_tax" variable of "NewIncomeTaxComputationFixed" with the
# "context" attribute. "context" is a variant of "input" that exposes the
# This is where the "context" concept comes into play. Indeed, we had
# annotated the "income_tax" variable of "NewIncomeTaxComputationFixed" with
# the "context" attribute. "context" is a variant of "input" that exposes the
# variable as an input of the scope. However, it is more permissive than
# "input" because it lets you re-define the "context" variable inside its
# own scope. Then, you're faced with a choice for the value of "income_tax":

6
examples/us_tax_code/section_121.catala_en
View File

@ -205,7 +205,8 @@ scope Section121SinglePerson:
else $0
scope Section121TwoPersons:
definition section121a_requirements_met equals section121Person1.requirements_met
definition section121a_requirements_met equals
section121Person1.requirements_met
definition income_excluded_from_gross_income_uncapped equals
section121Person1.income_excluded_from_gross_income_uncapped
@ -379,7 +380,8 @@ scope Section121TwoPasses under condition
definition first_pass.date_of_sale_or_exchange equals
match return_type with pattern
-- SingleReturnSurvivingSpouse of single_data: single_data.date_of_spouse_death
-- SingleReturnSurvivingSpouse of single_data:
single_data.date_of_spouse_death
-- SingleReturn of return: date_of_sale_or_exchange # does not happen
-- JointReturn of return: date_of_sale_or_exchange # does not happen

114
french_law/js/french_law.js generated
View File

File diff suppressed because one or more lines are too long

2
french_law/ocaml/bench.ml
View File

@ -115,7 +115,7 @@ let run_test () =
exit (-1)
| Runtime.AssertionFailed _ -> ()
let bench =
let _bench =
Random.init (int_of_float (Unix.time ()));
let num_iter = 10000 in
let _ =

2
french_law/ocaml/dune
View File

@ -12,7 +12,7 @@
(preprocess
(pps js_of_ocaml-ppx))
(js_of_ocaml
(flags --disable=shortvar --opt 3))
(flags :standard --disable=shortvar --opt 3))
; We need to disable shortvar because
; otherwise Webpack wrongly minifies
; the library and it gives bugs.

657
french_law/ocaml/law_source/aides_logement.ml generated
View File

File diff suppressed because it is too large Load Diff

309
french_law/ocaml/law_source/allocations_familiales.ml generated
View File

@ -940,8 +940,8 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_R.catala_fr";
start_line=216; start_column=18;
end_line=216; end_column=41;
start_line=217; start_column=18;
end_line=217; end_column=41;
law_headings=["Article R755-0-2";
"Chapitre 5 : Prestations familiales et prestations assimilées";
"Titre 5 : Départements d'outre-mer";
@ -1566,7 +1566,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=291; start_column=14; end_line=291; end_column=35;
start_line=293; start_column=14; end_line=293; end_column=35;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -1982,7 +1982,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(fun (_: _) -> false) (fun (_: _) -> raise EmptyError))|])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=311; start_column=14; end_line=311; end_column=31;
start_line=313; start_column=14; end_line=313; end_column=31;
law_headings=["Article D521-3";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -2116,7 +2116,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(fun (_: _) -> false) (fun (_: _) -> raise EmptyError))|])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=301; start_column=14; end_line=301; end_column=30;
start_line=303; start_column=14; end_line=303; end_column=30;
law_headings=["Article D521-3";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -2344,8 +2344,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=409; start_column=5;
end_line=409; end_column=69;
start_line=431; start_column=5;
end_line=431; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2372,8 +2372,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=416; start_column=5;
end_line=416; end_column=69;
start_line=439; start_column=5;
end_line=439; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2400,8 +2400,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=423; start_column=5;
end_line=423; end_column=69;
start_line=447; start_column=5;
end_line=447; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2428,8 +2428,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=430; start_column=5;
end_line=430; end_column=69;
start_line=455; start_column=5;
end_line=455; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2456,8 +2456,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=437; start_column=5;
end_line=437; end_column=69;
start_line=463; start_column=5;
end_line=463; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2484,8 +2484,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=444; start_column=5;
end_line=444; end_column=69;
start_line=471; start_column=5;
end_line=471; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2512,8 +2512,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=451; start_column=5;
end_line=451; end_column=69;
start_line=479; start_column=5;
end_line=479; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2540,8 +2540,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=458; start_column=5;
end_line=458; end_column=69;
start_line=487; start_column=5;
end_line=487; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2568,8 +2568,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=465; start_column=5;
end_line=465; end_column=69;
start_line=495; start_column=5;
end_line=495; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2596,8 +2596,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=472; start_column=5;
end_line=472; end_column=69;
start_line=503; start_column=5;
end_line=503; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2738,8 +2738,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=250; start_column=5;
end_line=251; end_column=53;
start_line=251; start_column=5;
end_line=252; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2771,8 +2771,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=258; start_column=5;
end_line=259; end_column=53;
start_line=260; start_column=5;
end_line=261; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2804,8 +2804,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=266; start_column=5;
end_line=267; end_column=53;
start_line=269; start_column=5;
end_line=270; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2837,8 +2837,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=274; start_column=5;
end_line=275; end_column=53;
start_line=278; start_column=5;
end_line=279; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2870,8 +2870,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=282; start_column=5;
end_line=283; end_column=53;
start_line=287; start_column=5;
end_line=288; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2903,8 +2903,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=290; start_column=5;
end_line=291; end_column=53;
start_line=296; start_column=5;
end_line=297; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2936,8 +2936,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=298; start_column=5;
end_line=299; end_column=53;
start_line=305; start_column=5;
end_line=306; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -2969,8 +2969,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=306; start_column=5;
end_line=307; end_column=53;
start_line=314; start_column=5;
end_line=315; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3002,8 +3002,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=314; start_column=5;
end_line=315; end_column=53;
start_line=323; start_column=5;
end_line=324; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3035,8 +3035,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=322; start_column=5;
end_line=323; end_column=53;
start_line=332; start_column=5;
end_line=333; end_column=53;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3068,8 +3068,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=330; start_column=5;
end_line=330; end_column=49;
start_line=341; start_column=5;
end_line=341; end_column=49;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3110,8 +3110,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=362; start_column=5;
end_line=363; end_column=71;
start_line=364; start_column=5;
end_line=365; end_column=71;
law_headings=["Article D755-5";
"Chapitre 5 : Prestations familiales et prestations assimilées";
"Titre 5 : Départements d'outre-mer";
@ -3126,7 +3126,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
bmaf_dot_montant_ *$ (decimal_of_string "0.0588")))|])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=359; start_column=29; end_line=359; end_column=64;
start_line=361; start_column=29; end_line=361; end_column=64;
law_headings=["Article D755-5";
"Chapitre 5 : Prestations familiales et prestations assimilées";
"Titre 5 : Départements d'outre-mer";
@ -3375,39 +3375,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
end_line=134; end_column=31;
law_headings=["Allocations familiales";
"Champs d'applications";
"Prologue"]}
([|(fun (_: _) ->
handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
start_line=134; start_column=11;
end_line=134; end_column=31;
law_headings=["Allocations familiales";
"Champs d'applications";
"Prologue"]} (
[||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=173; start_column=5;
end_line=174; end_column=68;
law_headings=["Article D521-1";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie réglementaire - Décrets simples";
"Code de la sécurité sociale"]}
((ressources_menage_ >$
plafond__i_i_d521_3_) &&
(ressources_menage_ <=$
(plafond__i_i_d521_3_ +$
(param_ *$
(decimal_of_string "12.")))))))
(fun (_: _) ->
((plafond__i_i_d521_3_ +$
(param_ *$
(decimal_of_string "12.")))
-$ ressources_menage_) *$
((decimal_of_string "1.") /&
(decimal_of_string "12."))))|])
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=165; start_column=5;
@ -3428,13 +3396,43 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
((plafond__i_d521_3_ +$
(param_ *$ (decimal_of_string "12.")))
-$ ressources_menage_) *$
((decimal_of_string "1.") /&
(decimal_of_string "12."))));
(fun (_: _) ->
handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
start_line=134; start_column=11;
end_line=134; end_column=31;
law_headings=["Allocations familiales";
"Champs d'applications";
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=174; start_column=5;
end_line=175; end_column=68;
law_headings=["Article D521-1";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie réglementaire - Décrets simples";
"Code de la sécurité sociale"]}
((ressources_menage_ >$ plafond__i_i_d521_3_)
&&
(ressources_menage_ <=$
(plafond__i_i_d521_3_ +$
(param_ *$
(decimal_of_string "12.")))))))
(fun (_: _) ->
((plafond__i_i_d521_3_ +$
(param_ *$ (decimal_of_string "12.")))
-$ ressources_menage_) *$
((decimal_of_string "1.") /&
(decimal_of_string "12."))))|])
(fun (_: _) -> false) (fun (_: _) -> raise EmptyError))|])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=179; start_column=14;
end_line=179; end_column=34;
start_line=181; start_column=14;
end_line=181; end_column=34;
law_headings=["Article D521-1";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -3473,8 +3471,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=218; start_column=5;
end_line=218; end_column=43;
start_line=220; start_column=5;
end_line=220; end_column=43;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -3494,8 +3492,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=232; start_column=5;
end_line=233; end_column=46;
start_line=234; start_column=5;
end_line=235; end_column=46;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -3516,8 +3514,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=246; start_column=5;
end_line=246; end_column=43;
start_line=248; start_column=5;
end_line=248; end_column=43;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -3675,8 +3673,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=338; start_column=5;
end_line=338; end_column=69;
start_line=350; start_column=5;
end_line=350; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3705,8 +3703,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=345; start_column=5;
end_line=345; end_column=69;
start_line=358; start_column=5;
end_line=358; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3735,8 +3733,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=352; start_column=5;
end_line=352; end_column=69;
start_line=366; start_column=5;
end_line=366; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3765,8 +3763,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=359; start_column=5;
end_line=359; end_column=69;
start_line=374; start_column=5;
end_line=374; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3795,8 +3793,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=366; start_column=5;
end_line=366; end_column=69;
start_line=382; start_column=5;
end_line=382; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3825,8 +3823,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=373; start_column=5;
end_line=373; end_column=69;
start_line=390; start_column=5;
end_line=390; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3855,8 +3853,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=380; start_column=5;
end_line=380; end_column=69;
start_line=398; start_column=5;
end_line=398; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3885,8 +3883,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=387; start_column=5;
end_line=387; end_column=69;
start_line=406; start_column=5;
end_line=406; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3915,8 +3913,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=394; start_column=5;
end_line=394; end_column=69;
start_line=414; start_column=5;
end_line=414; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -3945,8 +3943,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/decrets_divers.catala_fr";
start_line=401; start_column=5;
end_line=401; end_column=69;
start_line=422; start_column=5;
end_line=422; end_column=69;
law_headings=["Annexe";
"Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales à Mayotte";
"Dispositions spéciales relatives à Mayotte"]}
@ -4270,7 +4268,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=197; start_column=14; end_line=197; end_column=39;
start_line=199; start_column=14; end_line=199; end_column=39;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -4330,8 +4328,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=353; start_column=5;
end_line=354; end_column=69;
start_line=355; start_column=5;
end_line=356; end_column=69;
law_headings=["Article D755-5";
"Chapitre 5 : Prestations familiales et prestations assimilées";
"Titre 5 : Départements d'outre-mer";
@ -4412,8 +4410,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=376; start_column=5;
end_line=380; end_column=57;
start_line=378; start_column=5;
end_line=382; end_column=57;
law_headings=["Article D755-5";
"Chapitre 5 : Prestations familiales et prestations assimilées";
"Titre 5 : Départements d'outre-mer";
@ -4460,8 +4458,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=386; start_column=5;
end_line=389; end_column=58;
start_line=388; start_column=5;
end_line=391; end_column=58;
law_headings=["Article D755-5";
"Chapitre 5 : Prestations familiales et prestations assimilées";
"Titre 5 : Départements d'outre-mer";
@ -4547,14 +4545,6 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
end_line=136; end_column=52;
law_headings=["Allocations familiales";
"Champs d'applications"; "Prologue"]}
([|(fun (_: _) ->
handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
start_line=136; start_column=11;
end_line=136; end_column=52;
law_headings=["Allocations familiales";
"Champs d'applications";
"Prologue"]}
([|(fun (_: _) ->
handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -4565,31 +4555,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=275; start_column=5;
end_line=277; end_column=41;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie réglementaire - Décrets simples";
"Code de la sécurité sociale"]}
((ressources_menage_ >$
plafond__i_i_d521_3_) &&
(ressources_menage_ <=$
(plafond__i_i_d521_3_ +$
(montant_verse_forfaitaire_ *$
(decimal_of_string "12.")))))))
(fun (_: _) ->
((plafond__i_i_d521_3_ +$
(montant_verse_forfaitaire_ *$
(decimal_of_string "12."))) -$
ressources_menage_) *$
((decimal_of_string "1.") /&
(decimal_of_string "12."))))|])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=265; start_column=5;
end_line=267; end_column=42;
start_line=267; start_column=5;
end_line=269; end_column=42;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -4606,12 +4573,42 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(montant_verse_forfaitaire_ *$
(decimal_of_string "12."))) -$
ressources_menage_) *$
((decimal_of_string "1.") /&
(decimal_of_string "12."))));
(fun (_: _) ->
handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
start_line=136; start_column=11;
end_line=136; end_column=52;
law_headings=["Allocations familiales";
"Champs d'applications";
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=277; start_column=5;
end_line=279; end_column=41;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie réglementaire - Décrets simples";
"Code de la sécurité sociale"]}
((ressources_menage_ >$ plafond__i_i_d521_3_) &&
(ressources_menage_ <=$
(plafond__i_i_d521_3_ +$
(montant_verse_forfaitaire_ *$
(decimal_of_string "12.")))))))
(fun (_: _) ->
((plafond__i_i_d521_3_ +$
(montant_verse_forfaitaire_ *$
(decimal_of_string "12."))) -$
ressources_menage_) *$
((decimal_of_string "1.") /&
(decimal_of_string "12."))))|])
(fun (_: _) -> false) (fun (_: _) -> raise EmptyError))|])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=283; start_column=14; end_line=283; end_column=55;
start_line=285; start_column=14; end_line=285; end_column=55;
law_headings=["Article D521-2";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -4664,8 +4661,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
[||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_R.catala_fr";
start_line=187; start_column=5;
end_line=187; end_column=43;
start_line=188; start_column=5;
end_line=188; end_column=43;
law_headings=["Article R521-4";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -4776,7 +4773,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=187; start_column=14; end_line=187; end_column=61;
start_line=189; start_column=14; end_line=189; end_column=61;
law_headings=["Article D521-1";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";
@ -4801,7 +4798,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Prologue"]} ([||])
(fun (_: _) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_D.catala_fr";
start_line=181; start_column=14; end_line=181; end_column=62;
start_line=183; start_column=14; end_line=183; end_column=62;
law_headings=["Article D521-1";
"Chapitre 1er : Allocations familiales";
"Titre 2 : Prestations générales d'entretien";

Some files were not shown because too many files have changed in this diff Show More