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

Make desugared and scopelang use the 'a mark type for AST annotations

Browse Source 
This gives further uniformity in their interfaces and allows more common
handling.

The next step will be for all the `Expr.make_*` functions to work on expressions
annotated with the `'a mark` type, correctly propagating type information when
it is present. Then we could even imagine early propagation of type
information (without complete inference), which could for example be used for
overloaded operator disambiguation.
This commit is contained in:
Louis Gesbert 2022-08-26 15:21:47 +02:00 committed by Denis Merigoux
parent 5bda9e98d0
commit 84c78a234f
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
10 changed files with 152 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
compiler/desugared/ast.ml
View File

@ -94,8 +94,7 @@ Set.Make (struct
let compare = Expr.compare_location
end)
type naked_expr = (desugared, Pos.t) naked_gexpr
type expr = naked_expr Marked.pos
type expr = (desugared, untyped mark) gexpr
module ExprMap = Map.Make (struct
type t = expr
@ -156,8 +155,8 @@ end
let empty_rule (pos : Pos.t) (have_parameter : typ option) : rule =
{
rule_just = Bindlib.box (ELit (LBool false), pos);
rule_cons = Bindlib.box (ELit 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)
@ -169,8 +168,8 @@ let empty_rule (pos : Pos.t) (have_parameter : typ option) : rule =
let always_false_rule (pos : Pos.t) (have_parameter : typ option) : rule =
{
rule_just = Bindlib.box (ELit (LBool true), pos);
rule_cons = Bindlib.box (ELit (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)
@ -213,7 +212,7 @@ type program = {
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

4
compiler/desugared/ast.mli
View File

@ -49,11 +49,9 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t
(** {2 Expressions} *)
type naked_expr = (desugared, Pos.t) naked_gexpr
type expr = (desugared, untyped mark) gexpr
(** See {!type:Shared_ast.naked_gexpr} for the complete definition *)
and expr = naked_expr Marked.pos
type location = desugared glocation
module LocationSet : Set.S with type elt = location Marked.pos

24
compiler/desugared/desugared_to_scope.ml
View File

@ -187,6 +187,7 @@ let rec rule_tree_to_expr
(def_pos : Pos.t)
(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
@ -254,11 +255,10 @@ let rec rule_tree_to_expr
(* 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 PosRecordIfTrueBool [])
base_cons def_pos)
base_cons emark)
base_just_list base_cons_list)
(ELit (LBool false), def_pos)
(ELit LEmptyError, def_pos)
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
@ -271,9 +271,8 @@ let rec rule_tree_to_expr
let default =
Bindlib.box_apply2
(fun exceptions default_containing_base_cases ->
Expr.make_default exceptions
(ELit (LBool true), def_pos)
default_containing_base_cases def_pos)
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
@ -284,13 +283,12 @@ 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.naked_expr * Pos.t) ->
ErrorOnEmpty default, def_pos)
(fun (default : Scopelang.Ast.expr) -> ErrorOnEmpty default, emark)
default
in
Expr.make_abs
[| Var.Map.find new_param ctx.var_mapping |]
default [typ] def_pos
default [typ] emark
else default
| _ -> (* should not happen *) assert false
@ -332,12 +330,12 @@ let translate_def
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
@ -387,7 +385,7 @@ 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

5
compiler/scopelang/ast.ml
View File

@ -36,8 +36,7 @@ Set.Make (struct
let compare = Expr.compare_location
end)
type expr = (scopelang, Pos.t) gexpr
type naked_expr = (scopelang, Pos.t) naked_gexpr
type expr = (scopelang, untyped mark) gexpr
module ExprMap = Map.Make (struct
type t = expr
@ -47,7 +46,7 @@ end)
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

3
compiler/scopelang/ast.mli
View File

@ -41,8 +41,7 @@ module LocationSet : Set.S with type elt = location Marked.pos
(** {1 Abstract syntax tree} *)
type naked_expr = (scopelang, Pos.t) naked_gexpr
type expr = (scopelang, Pos.t) gexpr
type expr = (scopelang, untyped mark) gexpr
module ExprMap : Map.S with type key = expr

26
compiler/scopelang/scope_to_dcalc.ml
View File

@ -135,7 +135,7 @@ let collapse_similar_outcomes (excepts : Ast.expr list) : Ast.expr list =
let rec translate_expr (ctx : ctx) (e : Ast.expr) :
untyped Dcalc.Ast.expr Bindlib.box =
Bindlib.box_apply (fun x -> Marked.mark (pos_mark_as e) x)
Bindlib.box_apply (fun x -> Marked.same_mark_as x e)
@@
match Marked.unmark e with
| EVar v -> Bindlib.box_var (Var.Map.find v ctx.local_vars)
@ -154,7 +154,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
struct_sig ([], e_fields)
in
if StructFieldMap.cardinal remaining_e_fields > 0 then
Errors.raise_spanned_error (Marked.get_mark e)
Errors.raise_spanned_error (Expr.pos e)
"The fields \"%a\" do not belong to the structure %a"
StructName.format_t struct_name
(Format.pp_print_list
@ -172,7 +172,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
try
List.assoc field_name (List.mapi (fun i (x, y) -> x, (y, i)) struct_sig)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark e)
Errors.raise_spanned_error (Expr.pos e)
"The field \"%a\" does not belong to the structure %a"
StructFieldName.format_t field_name StructName.format_t struct_name
in
@ -187,7 +187,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
try
List.assoc constructor (List.mapi (fun i (x, y) -> x, (y, i)) enum_sig)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark e)
Errors.raise_spanned_error (Expr.pos e)
"The constructor \"%a\" does not belong to the enum %a"
EnumConstructor.format_t constructor EnumName.format_t enum_name
in
@ -203,7 +203,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
let case_e =
try EnumConstructorMap.find constructor e_cases
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark e)
Errors.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \
matching"
EnumConstructor.format_t constructor EnumName.format_t enum_name
@ -213,7 +213,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
enum_sig ([], cases)
in
if EnumConstructorMap.cardinal remaining_e_cases > 0 then
Errors.raise_spanned_error (Marked.get_mark e)
Errors.raise_spanned_error (Expr.pos e)
"Patter matching is incomplete for enum %a: missing cases %a"
EnumName.format_t enum_name
(Format.pp_print_list
@ -269,13 +269,13 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
| ELocation l, [new_arg] ->
[
tag_with_log_entry new_arg (VarDef input_typ)
(markings l @ [Marked.same_mark_as "input" e]);
(markings l @ [Marked.mark (Expr.pos e) "input"]);
]
| _ -> new_args
in
let new_e =
Bindlib.box_apply2
(fun e' u -> EApp (e', u), pos_mark_as e)
(fun e' u -> Marked.same_mark_as (EApp (e', u)) e)
e1_func
(Bindlib.box_list new_args)
in
@ -284,7 +284,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
| ELocation l ->
tag_with_log_entry
(tag_with_log_entry new_e (VarDef output_typ)
(markings l @ [Marked.same_mark_as "output" e]))
(markings l @ [Marked.mark (Expr.pos e) "output"]))
EndCall (markings l)
| _ -> new_e
in
@ -325,7 +325,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
with Not_found ->
Errors.raise_multispanned_error
[
Some "Incriminated variable usage:", Marked.get_mark e;
Some "Incriminated variable usage:", Expr.pos e;
( Some "Incriminated subscope variable declaration:",
Marked.get_mark (ScopeVar.get_info (Marked.unmark a)) );
( Some "Incriminated subscope declaration:",
@ -616,13 +616,13 @@ let translate_rule
ScopeLet
{
scope_let_next = next;
scope_let_pos = Marked.get_mark e;
scope_let_typ = TLit TUnit, Marked.get_mark e;
scope_let_pos = Expr.pos e;
scope_let_typ = TLit TUnit, Expr.pos e;
scope_let_expr =
(* To ensure that we throw an error if the value is not
defined, we add an check "ErrorOnEmpty" here. *)
Marked.same_mark_as
(EAssert (ErrorOnEmpty new_e, pos_mark_as e))
(EAssert (Marked.same_mark_as (ErrorOnEmpty new_e) e))
new_e;
scope_let_kind = Assertion;
})

8
compiler/shared_ast/definitions.ml
View File

@ -147,7 +147,6 @@ type desugared = [ `Desugared ]
type scopelang = [ `Scopelang ]
type dcalc = [ `Dcalc ]
type lcalc = [ `Lcalc ]
type 'a any = [< desugared | scopelang | dcalc | lcalc ] as 'a
(** Literals are the same throughout compilation except for the [LEmptyError]
@ -192,9 +191,7 @@ and ('a, '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
| EVar : ('a, 't) naked_gexpr Bindlib.var -> ('a any, 't) naked_gexpr
| EAbs :
(('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder * typ list
-> ('a any, 't) naked_gexpr
@ -251,6 +248,9 @@ type ('e, 'b) binder = (('a, 't) naked_gexpr, 'b) Bindlib.binder
(** 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]

3
compiler/shared_ast/expr.ml
View File

@ -229,9 +229,6 @@ let empty_thunked_term mark =
Marked.mark pos (TArrow (Marked.mark pos (TLit TUnit), ty)))
mark))
let make_let_in_raw x tau e1 e2 mark =
make_app (make_abs [| x |] e2 [tau] mark) [e1] 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

9
compiler/shared_ast/expr.mli
View File

@ -184,15 +184,6 @@ val make_let_in :
Utils.Pos.t ->
('a, 'm mark) gexpr box
val make_let_in_raw :
('a, 't) gexpr Var.t ->
typ ->
('a, 't) gexpr box ->
('a, 't) gexpr box ->
't ->
('a, 't) gexpr box
(** Version with any mark; to be removed once we use the [mark] type everywhere. *)
val make_multiple_let_in :
('a, 'm mark) gexpr Var.vars ->
typ list ->

227
compiler/surface/desugaring.ml
View File

@ -124,11 +124,12 @@ let rec translate_expr
(scope : ScopeName.t)
(inside_definition_of : Desugared.Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
((naked_expr, pos) : Ast.expression Marked.pos) :
Desugared.Ast.expr Bindlib.box =
(expr : Ast.expression Marked.pos) : Desugared.Ast.expr Bindlib.box =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
let rec_helper = translate_expr scope inside_definition_of ctxt in
match naked_expr with
let pos = Marked.get_mark expr in
let emark = Untyped { pos } in
match Marked.unmark expr with
| Binop
( (Ast.And, _pos_op),
( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)),
@ -146,35 +147,35 @@ let rec translate_expr
let nop_var = Var.make "_" in
Bindlib.unbox
(Expr.make_abs [| nop_var |]
(Bindlib.box (ELit (LBool false), pos))
[tau] pos)
(Bindlib.box (ELit (LBool false), emark))
[tau] emark)
else
let ctxt, binding_var =
Name_resolution.add_def_local_var ctxt (Marked.unmark binding)
in
let e2 = translate_expr scope inside_definition_of ctxt e2 in
Bindlib.unbox (Expr.make_abs [| binding_var |] e2 [tau] pos))
Bindlib.unbox (Expr.make_abs [| binding_var |] e2 [tau] emark))
(EnumMap.find enum_uid ctxt.enums)
in
Bindlib.box_apply
(fun e1_sub -> EMatchS (e1_sub, enum_uid, cases), pos)
(fun e1_sub -> EMatchS (e1_sub, enum_uid, cases), emark)
(translate_expr scope inside_definition_of ctxt e1_sub)
| IfThenElse (e_if, e_then, e_else) ->
Bindlib.box_apply3
(fun e_if e_then e_else -> EIfThenElse (e_if, e_then, e_else), pos)
(fun e_if e_then e_else -> EIfThenElse (e_if, e_then, e_else), emark)
(rec_helper e_if) (rec_helper e_then) (rec_helper e_else)
| Binop (op, e1, e2) ->
| Binop ((op, pos), e1, e2) ->
let op_term =
Marked.same_mark_as (EOp (Binop (translate_binop (Marked.unmark op)))) op
Marked.mark (Untyped { pos }) (EOp (Binop (translate_binop op)))
in
Bindlib.box_apply2
(fun e1 e2 -> EApp (op_term, [e1; e2]), pos)
(fun e1 e2 -> EApp (op_term, [e1; e2]), emark)
(rec_helper e1) (rec_helper e2)
| Unop (op, e) ->
| Unop ((op, pos), e) ->
let op_term =
Marked.same_mark_as (EOp (Unop (translate_unop (Marked.unmark op)))) op
Marked.mark (Untyped { pos }) (EOp (Unop (translate_unop op)))
in
Bindlib.box_apply (fun e -> EApp (op_term, [e]), pos) (rec_helper e)
Bindlib.box_apply (fun e -> EApp (op_term, [e]), emark) (rec_helper e)
| Literal l ->
let untyped_term =
match l with
@ -222,7 +223,7 @@ let rec translate_expr
"There is an error in this date, it does not correspond to a \
correct calendar day"))
in
Bindlib.box (untyped_term, pos)
Bindlib.box (untyped_term, emark)
| Ident x -> (
(* first we check whether this is a local var, then we resort to scope-wide
variables *)
@ -268,12 +269,12 @@ let rec translate_expr
(* we take the last state in the chain *)
Some (List.hd (List.rev states)))
in
Bindlib.box (ELocation (DesugaredScopeVar ((uid, pos), x_state)), pos)
Bindlib.box (ELocation (DesugaredScopeVar ((uid, pos), x_state)), emark)
| None ->
Name_resolution.raise_unknown_identifier
"for a local or scope-wide variable" (x, pos))
| Some uid ->
Expr.make_var (uid, pos)
Expr.make_var (uid, emark)
(* the whole box thing is to accomodate for this case *))
| Dotted (e, c, x) -> (
match Marked.unmark e with
@ -292,7 +293,7 @@ let rec translate_expr
( ELocation
(SubScopeVar
(subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos))),
pos )
emark )
| _ -> (
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope inside_definition_of ctxt e in
@ -316,7 +317,7 @@ let rec translate_expr
(StructMap.bindings x_possible_structs)
else
let s_uid, f_uid = StructMap.choose x_possible_structs in
Bindlib.box_apply (fun e -> EStructAccess (e, f_uid, s_uid), pos) e
Bindlib.box_apply (fun e -> EStructAccess (e, f_uid, s_uid), emark) e
| Some c_name -> (
try
let c_uid =
@ -324,7 +325,9 @@ let rec translate_expr
in
try
let f_uid = StructMap.find c_uid x_possible_structs in
Bindlib.box_apply (fun e -> EStructAccess (e, f_uid, c_uid), pos) e
Bindlib.box_apply
(fun e -> EStructAccess (e, f_uid, c_uid), emark)
e
with Not_found ->
Errors.raise_spanned_error pos "Struct %s does not contain field %s"
(Marked.unmark c_name) (Marked.unmark x)
@ -333,7 +336,7 @@ let rec translate_expr
"Struct %s has not been defined before" (Marked.unmark c_name))))
| FunCall (f, arg) ->
Bindlib.box_apply2
(fun f arg -> EApp (f, [arg]), pos)
(fun f arg -> EApp (f, [arg]), emark)
(rec_helper f) (rec_helper arg)
| LetIn (x, e1, e2) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt (Marked.unmark x) in
@ -341,9 +344,11 @@ let rec translate_expr
let fn =
Expr.make_abs [| v |]
(translate_expr scope inside_definition_of ctxt e2)
[tau] pos
[tau] emark
in
Bindlib.box_apply2 (fun fn arg -> EApp (fn, [arg]), pos) fn (rec_helper e1)
Bindlib.box_apply2
(fun fn arg -> EApp (fn, [arg]), emark)
fn (rec_helper e1)
| StructLit (s_name, fields) ->
let s_uid =
try Desugared.Ast.IdentMap.find (Marked.unmark s_name) ctxt.struct_idmap
@ -370,8 +375,7 @@ let rec translate_expr
| Some e_field ->
Errors.raise_multispanned_error
[
None, Marked.get_mark f_e;
None, Marked.get_mark (Bindlib.unbox e_field);
None, Marked.get_mark f_e; None, Expr.pos (Bindlib.unbox e_field);
]
"The field %a has been defined twice:" StructFieldName.format_t
f_uid);
@ -389,20 +393,17 @@ let rec translate_expr
expected_s_fields;
Bindlib.box_apply
(fun s_fields -> EStruct (s_uid, s_fields), pos)
(fun s_fields -> EStruct (s_uid, s_fields), emark)
(LiftStructFieldMap.lift_box s_fields)
| EnumInject (enum, constructor, payload) -> (
| EnumInject (enum, (constructor, pos_constructor), payload) -> (
let possible_c_uids =
try
Desugared.Ast.IdentMap.find
(Marked.unmark constructor)
ctxt.constructor_idmap
try Desugared.Ast.IdentMap.find constructor ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
(Marked.get_mark constructor)
Errors.raise_spanned_error pos_constructor
"The name of this constructor has not been defined before, maybe it \
is a typo?"
in
let mark_constructor = Untyped { pos = pos_constructor } in
match enum with
| None ->
@ -410,8 +411,7 @@ let rec translate_expr
(* No constructor name was specified *)
EnumMap.cardinal possible_c_uids > 1
then
Errors.raise_spanned_error
(Marked.get_mark constructor)
Errors.raise_spanned_error pos_constructor
"This constructor name is ambiguous, it can belong to %a. \
Desambiguate it by prefixing it with the enum name."
(Format.pp_print_list
@ -429,10 +429,10 @@ let rec translate_expr
( EEnumInj
( (match payload with
| Some e' -> e'
| None -> ELit LUnit, Marked.get_mark constructor),
| None -> ELit LUnit, mark_constructor),
c_uid,
e_uid ),
pos ))
emark ))
(Bindlib.box_opt payload)
| Some enum -> (
try
@ -450,15 +450,14 @@ let rec translate_expr
( EEnumInj
( (match payload with
| Some e' -> e'
| None -> ELit LUnit, Marked.get_mark constructor),
| None -> ELit LUnit, mark_constructor),
c_uid,
e_uid ),
pos ))
emark ))
(Bindlib.box_opt payload)
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
(Marked.unmark enum)
(Marked.unmark constructor)
(Marked.unmark enum) constructor
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum)))
@ -469,7 +468,7 @@ let rec translate_expr
cases
in
Bindlib.box_apply2
(fun e1 cases_d -> EMatchS (e1, e_uid, cases_d), pos)
(fun e1 cases_d -> EMatchS (e1, e_uid, cases_d), emark)
e1
(LiftEnumConstructorMap.lift_box cases_d)
| TestMatchCase (e1, pattern) ->
@ -490,16 +489,17 @@ let rec translate_expr
Bindlib.unbox
(Expr.make_abs [| nop_var |]
(Bindlib.box
(ELit (LBool (EnumConstructor.compare c_uid c_uid' = 0)), pos))
[tau] pos))
( ELit (LBool (EnumConstructor.compare c_uid c_uid' = 0)),
emark ))
[tau] emark))
(EnumMap.find enum_uid ctxt.enums)
in
Bindlib.box_apply
(fun e -> EMatchS (e, enum_uid, cases), pos)
(fun e -> EMatchS (e, enum_uid, cases), emark)
(translate_expr scope inside_definition_of ctxt e1)
| ArrayLit es ->
Bindlib.box_apply
(fun es -> EArray es, pos)
(fun es -> EArray es, emark)
(Bindlib.box_list (List.map rec_helper es))
| CollectionOp
( (((Ast.Filter | Ast.Map) as op'), _pos_op'),
@ -514,7 +514,7 @@ let rec translate_expr
Expr.make_abs [| param |]
(translate_expr scope inside_definition_of ctxt predicate)
[TAny, pos]
pos
emark
in
Bindlib.box_apply2
(fun f_pred collection ->
@ -524,9 +524,9 @@ let rec translate_expr
| Ast.Map -> Binop Map
| Ast.Filter -> Binop Filter
| _ -> assert false (* should not happen *)),
pos ),
emark ),
[f_pred; collection] ),
pos ))
emark ))
f_pred collection
| CollectionOp
( ( Ast.Aggregate (Ast.AggregateArgExtremum (max_or_min, pred_typ, init)),
@ -557,12 +557,14 @@ let rec translate_expr
Expr.make_abs [| param |]
(translate_expr scope inside_definition_of ctxt predicate)
[TAny, pos]
pos
emark
in
let f_pred_var = Var.make "predicate" in
let f_pred_var_e = Expr.make_var (f_pred_var, Marked.get_mark predicate) in
let f_pred_var_e =
Expr.make_var (f_pred_var, Untyped { pos = Marked.get_mark predicate })
in
let acc_var = Var.make "acc" in
let acc_var_e = Expr.make_var (acc_var, pos) in
let acc_var_e = Expr.make_var (acc_var, emark) in
let item_var = Var.make "item" in
let item_var_e =
Expr.make_var (item_var, Marked.get_mark (Bindlib.unbox collection))
@ -572,85 +574,87 @@ let rec translate_expr
(fun acc_var_e item_var_e f_pred_var_e ->
( EIfThenElse
( ( EApp
( (EOp (Binop cmp_op), pos_op'),
( (EOp (Binop cmp_op), Untyped { pos = pos_op' }),
[
EApp (f_pred_var_e, [acc_var_e]), pos;
EApp (f_pred_var_e, [item_var_e]), pos;
EApp (f_pred_var_e, [acc_var_e]), emark;
EApp (f_pred_var_e, [item_var_e]), emark;
] ),
pos ),
emark ),
acc_var_e,
item_var_e ),
pos ))
emark ))
acc_var_e item_var_e f_pred_var_e
in
let fold_f =
Expr.make_abs [| acc_var; item_var |] fold_body [TAny, pos; TAny, pos] pos
Expr.make_abs [| acc_var; item_var |] fold_body
[TAny, pos; TAny, pos]
emark
in
let fold =
Bindlib.box_apply3
(fun fold_f collection init ->
EApp ((EOp (Ternop Fold), pos), [fold_f; init; collection]), pos)
EApp ((EOp (Ternop Fold), emark), [fold_f; init; collection]), emark)
fold_f collection init
in
Expr.make_let_in_raw f_pred_var (TAny, pos) f_pred fold pos
Expr.make_let_in f_pred_var (TAny, pos) f_pred fold pos
| CollectionOp (op', param', collection, predicate) ->
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param')
in
let collection = rec_helper collection in
let mark = Untyped { pos = Marked.get_mark op' } in
let init =
match Marked.unmark op' with
| Ast.Map | Ast.Filter | Ast.Aggregate (Ast.AggregateArgExtremum _) ->
assert false (* should not happen *)
| Ast.Exists -> Bindlib.box (ELit (LBool false), Marked.get_mark op')
| Ast.Forall -> Bindlib.box (ELit (LBool true), Marked.get_mark op')
| Ast.Exists -> Bindlib.box (ELit (LBool false), mark)
| Ast.Forall -> Bindlib.box (ELit (LBool true), mark)
| Ast.Aggregate (Ast.AggregateSum Ast.Integer) ->
Bindlib.box (ELit (LInt (Runtime.integer_of_int 0)), Marked.get_mark op')
Bindlib.box (ELit (LInt (Runtime.integer_of_int 0)), mark)
| Ast.Aggregate (Ast.AggregateSum Ast.Decimal) ->
Bindlib.box
(ELit (LRat (Runtime.decimal_of_string "0")), Marked.get_mark op')
Bindlib.box (ELit (LRat (Runtime.decimal_of_string "0")), mark)
| Ast.Aggregate (Ast.AggregateSum Ast.Money) ->
Bindlib.box
( ELit
(LMoney
(Runtime.money_of_cents_integer (Runtime.integer_of_int 0))),
Marked.get_mark op' )
mark )
| Ast.Aggregate (Ast.AggregateSum Ast.Duration) ->
Bindlib.box
( ELit (LDuration (Runtime.duration_of_numbers 0 0 0)),
Marked.get_mark op' )
Bindlib.box (ELit (LDuration (Runtime.duration_of_numbers 0 0 0)), mark)
| Ast.Aggregate (Ast.AggregateSum t) ->
Errors.raise_spanned_error pos
"It is impossible to sum two values of type %a together"
SurfacePrint.format_primitive_typ t
| Ast.Aggregate (Ast.AggregateExtremum (_, _, init)) -> rec_helper init
| Ast.Aggregate Ast.AggregateCount ->
Bindlib.box (ELit (LInt (Runtime.integer_of_int 0)), Marked.get_mark op')
Bindlib.box (ELit (LInt (Runtime.integer_of_int 0)), mark)
in
let acc_var = Var.make "acc" in
let acc = Expr.make_var (acc_var, Marked.get_mark param') in
let acc =
Expr.make_var (acc_var, Untyped { pos = Marked.get_mark param' })
in
let f_body =
let make_body (op : binop) =
Bindlib.box_apply2
(fun predicate acc ->
EApp ((EOp (Binop op), Marked.get_mark op'), [acc; predicate]), pos)
EApp ((EOp (Binop op), mark), [acc; predicate]), emark)
(translate_expr scope inside_definition_of ctxt predicate)
acc
in
let make_extr_body (cmp_op : binop) (t : typ) =
let tmp_var = Var.make "tmp" in
let tmp = Expr.make_var (tmp_var, Marked.get_mark param') in
Expr.make_let_in_raw tmp_var t
let tmp =
Expr.make_var (tmp_var, Untyped { pos = Marked.get_mark param' })
in
Expr.make_let_in tmp_var t
(translate_expr scope inside_definition_of ctxt predicate)
(Bindlib.box_apply2
(fun acc tmp ->
( EIfThenElse
( ( EApp
((EOp (Binop cmp_op), Marked.get_mark op'), [acc; tmp]),
pos ),
( (EApp ((EOp (Binop cmp_op), mark), [acc; tmp]), emark),
acc,
tmp ),
pos ))
emark ))
acc tmp)
pos
in
@ -688,15 +692,15 @@ let rec translate_expr
( EIfThenElse
( predicate,
( EApp
( (EOp (Binop (Add KInt)), Marked.get_mark op'),
( (EOp (Binop (Add KInt)), mark),
[
acc;
( ELit (LInt (Runtime.integer_of_int 1)),
Marked.get_mark predicate );
] ),
pos ),
emark ),
acc ),
pos ))
emark ))
(translate_expr scope inside_definition_of ctxt predicate)
acc
in
@ -713,7 +717,7 @@ let rec translate_expr
arrays is not always the type of the accumulator; for
instance in AggregateCount. *);
] ),
pos ))
emark ))
(Bindlib.bind_mvar [| acc_var; param |] f_body)
in
match Marked.unmark op' with
@ -740,45 +744,45 @@ let rec translate_expr
in
Bindlib.box_apply3
(fun f collection init ->
EApp ((EOp (Ternop Fold), pos), [f; init; collection]), pos)
EApp ((EOp (Ternop Fold), emark), [f; init; collection]), emark)
f collection init
| MemCollection (member, collection) ->
let param_var = Var.make "collection_member" in
let param = Expr.make_var (param_var, pos) in
let param = Expr.make_var (param_var, emark) in
let collection = rec_helper collection in
let init = Bindlib.box (ELit (LBool false), pos) in
let init = Bindlib.box (ELit (LBool false), emark) in
let acc_var = Var.make "acc" in
let acc = Expr.make_var (acc_var, pos) in
let acc = Expr.make_var (acc_var, emark) in
let f_body =
Bindlib.box_apply3
(fun member acc param ->
( EApp
( (EOp (Binop Or), pos),
[EApp ((EOp (Binop Eq), pos), [member; param]), pos; acc] ),
pos ))
( (EOp (Binop Or), emark),
[EApp ((EOp (Binop Eq), emark), [member; param]), emark; acc] ),
emark ))
(translate_expr scope inside_definition_of ctxt member)
acc param
in
let f =
Bindlib.box_apply
(fun binder -> EAbs (binder, [TLit TBool, pos; TAny, pos]), pos)
(fun binder -> EAbs (binder, [TLit TBool, pos; TAny, pos]), emark)
(Bindlib.bind_mvar [| acc_var; param_var |] f_body)
in
Bindlib.box_apply3
(fun f collection init ->
EApp ((EOp (Ternop Fold), pos), [f; init; collection]), pos)
EApp ((EOp (Ternop Fold), emark), [f; init; collection]), emark)
f collection init
| Builtin IntToDec -> Bindlib.box (EOp (Unop IntToRat), pos)
| Builtin MoneyToDec -> Bindlib.box (EOp (Unop MoneyToRat), pos)
| Builtin DecToMoney -> Bindlib.box (EOp (Unop RatToMoney), pos)
| Builtin Cardinal -> Bindlib.box (EOp (Unop Length), pos)
| Builtin GetDay -> Bindlib.box (EOp (Unop GetDay), pos)
| Builtin GetMonth -> Bindlib.box (EOp (Unop GetMonth), pos)
| Builtin GetYear -> Bindlib.box (EOp (Unop GetYear), pos)
| Builtin FirstDayOfMonth -> Bindlib.box (EOp (Unop FirstDayOfMonth), pos)
| Builtin LastDayOfMonth -> Bindlib.box (EOp (Unop LastDayOfMonth), pos)
| Builtin RoundMoney -> Bindlib.box (EOp (Unop RoundMoney), pos)
| Builtin RoundDecimal -> Bindlib.box (EOp (Unop RoundDecimal), pos)
| Builtin IntToDec -> Bindlib.box (EOp (Unop IntToRat), emark)
| Builtin MoneyToDec -> Bindlib.box (EOp (Unop MoneyToRat), emark)
| Builtin DecToMoney -> Bindlib.box (EOp (Unop RatToMoney), emark)
| Builtin Cardinal -> Bindlib.box (EOp (Unop Length), emark)
| Builtin GetDay -> Bindlib.box (EOp (Unop GetDay), emark)
| Builtin GetMonth -> Bindlib.box (EOp (Unop GetMonth), emark)
| Builtin GetYear -> Bindlib.box (EOp (Unop GetYear), emark)
| Builtin FirstDayOfMonth -> Bindlib.box (EOp (Unop FirstDayOfMonth), emark)
| Builtin LastDayOfMonth -> Bindlib.box (EOp (Unop LastDayOfMonth), emark)
| Builtin RoundMoney -> Bindlib.box (EOp (Unop RoundMoney), emark)
| Builtin RoundDecimal -> Bindlib.box (EOp (Unop RoundDecimal), emark)
and disambiguate_match_and_build_expression
(scope : ScopeName.t)
@ -796,12 +800,9 @@ and disambiguate_match_and_build_expression
(c_uid : EnumConstructor.t)
(e_uid : EnumName.t)
(ctxt : Name_resolution.context)
(case_body : ('a * Pos.t) Bindlib.box)
(e_binder :
( Desugared.Ast.naked_expr,
Desugared.Ast.naked_expr * Pos.t )
Bindlib.mbinder
Bindlib.box) : 'c Bindlib.box =
(case_body : ('a * untyped mark) Bindlib.box)
(e_binder : (Desugared.Ast.expr, Desugared.Ast.expr) mbinder box) :
'c Bindlib.box =
Bindlib.box_apply2
(fun e_binder case_body ->
Marked.same_mark_as
@ -840,7 +841,7 @@ and disambiguate_match_and_build_expression
Errors.raise_multispanned_error
[
None, Marked.get_mark case.match_case_expr;
None, Marked.get_mark (Bindlib.unbox e_case);
None, Expr.pos (Bindlib.unbox e_case);
]
"The constructor %a has been matched twice:" EnumConstructor.format_t
c_uid);
@ -937,10 +938,10 @@ let merge_conditions
precond cond
| Some precond, None ->
Bindlib.box_apply
(fun precond -> Marked.unmark precond, default_pos)
(fun precond -> Marked.unmark precond, Untyped { pos = default_pos })
precond
| None, Some cond -> cond
| None, None -> Bindlib.box (ELit (LBool true), default_pos)
| None, None -> Bindlib.box (ELit (LBool true), Untyped { pos = default_pos })
(** Translates a surface definition into condition into a desugared {!type:
Desugared.Ast.rule} *)
@ -973,11 +974,11 @@ let process_default
| TArrow (t_in, _), Some param_uid -> Some (Marked.unmark param_uid, t_in)
| TArrow _, None ->
Errors.raise_spanned_error
(Marked.get_mark (Bindlib.unbox cons))
(Expr.pos (Bindlib.unbox cons))
"This definition has a function type but the parameter is missing"
| _, Some _ ->
Errors.raise_spanned_error
(Marked.get_mark (Bindlib.unbox cons))
(Expr.pos (Bindlib.unbox cons))
"This definition has a parameter but its type is not a function"
| _ -> None);
rule_exception = exception_situation;