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

Add type annotations on all AST nodes (first pass)

Browse Source
This commit is contained in:
Louis Gesbert 2022-05-31 18:38:14 +02:00
parent 513647cd32
commit 67179a793c
21 changed files with 1040 additions and 912 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

596
compiler/dcalc/ast.ml
View File

@ -42,12 +42,14 @@ type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type struct_name = StructName.t
type enum_name = EnumName.t
type typ =
type marked_typ = typ Marked.pos
and typ =
| TLit of typ_lit
| TTuple of typ Marked.pos list * struct_name option
| TEnum of typ Marked.pos list * enum_name
| TArrow of typ Marked.pos * typ Marked.pos
| TArray of typ Marked.pos
| 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
| TAny
type date = Runtime.date
@ -103,28 +105,76 @@ type unop =
type operator = Ternop of ternop | Binop of binop | Unop of unop
type marked_expr = expr Marked.pos
(** Some structures used for type inference *)
module Infer = struct
module Any =
Utils.Uid.Make
(struct
type info = unit
and expr =
| EVar of expr Bindlib.var
| ETuple of marked_expr list * struct_name option
| ETupleAccess of marked_expr * int * struct_name option * typ Marked.pos list
| EInj of marked_expr * int * enum_name * typ Marked.pos list
| EMatch of marked_expr * marked_expr list * enum_name
| EArray of marked_expr list
let format_info fmt () = Format.fprintf fmt "any"
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
captured by the type sytem. *)
and typ =
| TLit of typ_lit
| TArrow of unionfind_typ * unionfind_typ
| TTuple of unionfind_typ list * StructName.t option
| TEnum of unionfind_typ list * EnumName.t
| TArray of unionfind_typ
| TAny of Any.t
let rec typ_to_ast (ty : unionfind_typ) : marked_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
end
type untyped = { pos : Pos.t } [@@ocaml.unboxed]
type typed = { pos : Pos.t; ty : Infer.unionfind_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 *)
type _ mark = Untyped : untyped -> untyped mark | Typed : typed -> typed mark
type ('a, 'm) marked = ('a, 'm mark) Marked.t
type 'm marked_expr = ('m expr, 'm) marked
and 'm expr =
| EVar of 'm expr Bindlib.var
| ETuple of 'm marked_expr list * StructName.t option
| ETupleAccess of
'm marked_expr * int * StructName.t option * typ Marked.pos list
| EInj of 'm marked_expr * int * EnumName.t * typ Marked.pos list
| EMatch of 'm marked_expr * 'm marked_expr list * EnumName.t
| EArray of 'm marked_expr list
| ELit of lit
| EAbs of (expr, marked_expr) Bindlib.mbinder * typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EAssert of marked_expr
| EAbs of
(('m expr, 'm marked_expr) Bindlib.mbinder[@opaque]) * typ Marked.pos list
| EApp of 'm marked_expr * 'm marked_expr list
| EAssert of 'm marked_expr
| EOp of operator
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| ErrorOnEmpty of marked_expr
| EDefault of 'm marked_expr list * 'm marked_expr * 'm marked_expr
| EIfThenElse of 'm marked_expr * 'm marked_expr * 'm marked_expr
| ErrorOnEmpty of 'm marked_expr
type typed_expr = typed marked_expr
type struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
type binder = (expr, expr Marked.pos) Bindlib.binder
type 'm binder = ('m expr, 'm marked_expr) Bindlib.binder
type scope_let_kind =
| DestructuringInputStruct
@ -134,120 +184,104 @@ type scope_let_kind =
| DestructuringSubScopeResults
| Assertion
type 'expr scope_let = {
type ('expr, 'm) scope_let = {
scope_let_kind : scope_let_kind;
scope_let_typ : typ Utils.Marked.pos;
scope_let_expr : 'expr Utils.Marked.pos;
scope_let_next : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_let_pos : Utils.Pos.t;
scope_let_typ : typ Marked.pos;
scope_let_expr : ('expr, 'm) marked;
scope_let_next : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
scope_let_pos : Pos.t;
}
and 'expr scope_body_expr =
| Result of 'expr Utils.Marked.pos
| ScopeLet of 'expr scope_let
and ('expr, 'm) scope_body_expr =
| Result of ('expr, 'm) marked
| ScopeLet of ('expr, 'm) scope_let
type 'expr scope_body = {
type ('expr, 'm) scope_body = {
scope_body_input_struct : StructName.t;
scope_body_output_struct : StructName.t;
scope_body_expr : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_body_expr : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
}
type 'expr scope_def = {
type ('expr, 'm) scope_def = {
scope_name : ScopeName.t;
scope_body : 'expr scope_body;
scope_next : ('expr, 'expr scopes) Bindlib.binder;
scope_body : ('expr, 'm) scope_body;
scope_next : ('expr, ('expr, 'm) scopes) Bindlib.binder;
}
and 'expr scopes = Nil | ScopeDef of 'expr scope_def
and ('expr, 'm) scopes = Nil | ScopeDef of ('expr, 'm) scope_def
type program = { decl_ctx : decl_ctx; scopes : expr scopes }
type 'm program = {
decl_ctx : decl_ctx;
scopes : ('m expr, 'm) scopes;
}
let evar (v : expr Bindlib.var) (pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun v' -> v', pos) (Bindlib.box_var v)
let no_mark (type m) : m mark -> m mark = function
| Untyped _ -> Untyped { pos = Pos.no_pos }
| Typed _ ->
Typed
{
pos = Pos.no_pos;
ty = UnionFind.make Infer.(TAny (Any.fresh ()), Pos.no_pos);
}
let etuple
(args : expr Marked.pos Bindlib.box list)
(s : StructName.t option)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun args -> ETuple (args, s), pos) (Bindlib.box_list args)
let mark_pos (type m) (m : m mark) : Pos.t =
match m with Untyped { pos } | Typed { pos; _ } -> pos
let etupleaccess
(e1 : expr Marked.pos Bindlib.box)
(i : int)
(s : StructName.t option)
(typs : typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), pos) e1
let pos (type m) (x : ('a, m) marked) : Pos.t = mark_pos (Marked.get_mark x)
let ty (_, Typed { ty; _ }) : typ = Marked.unmark (Infer.typ_to_ast ty)
let einj
(e1 : expr Marked.pos Bindlib.box)
(i : int)
(e_name : EnumName.t)
(typs : typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), pos) e1
let with_ty (type m) (ty : Infer.unionfind_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 ematch
(arg : expr Marked.pos Bindlib.box)
(arms : expr Marked.pos Bindlib.box list)
(e_name : EnumName.t)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
let evar v mark = Bindlib.box_apply (fun v' -> v', 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), pos)
(fun arg arms -> EMatch (arg, arms, e_name), mark)
arg (Bindlib.box_list arms)
let earray (args : expr Marked.pos Bindlib.box list) (pos : Pos.t) :
expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun args -> EArray args, pos) (Bindlib.box_list args)
let earray args mark =
Bindlib.box_apply (fun args -> EArray args, mark) (Bindlib.box_list args)
let elit (l : lit) (pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box (ELit l, pos)
let elit l mark = Bindlib.box (ELit l, mark)
let eabs
(binder : (expr, expr Marked.pos) Bindlib.mbinder Bindlib.box)
(typs : typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), pos) binder
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) binder
let eapp
(e1 : expr Marked.pos Bindlib.box)
(args : expr Marked.pos Bindlib.box list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
let eapp e1 args mark =
Bindlib.box_apply2
(fun e1 args -> EApp (e1, args), pos)
(fun e1 args -> EApp (e1, args), mark)
e1 (Bindlib.box_list args)
let eassert (e1 : expr Marked.pos Bindlib.box) (pos : Pos.t) :
expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun e1 -> EAssert e1, pos) e1
let eassert e1 mark = Bindlib.box_apply (fun e1 -> EAssert e1, mark) e1
let eop op mark = Bindlib.box (EOp op, mark)
let eop (op : operator) (pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box (EOp op, pos)
let edefault
(excepts : expr Marked.pos Bindlib.box list)
(just : expr Marked.pos Bindlib.box)
(cons : expr Marked.pos Bindlib.box)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
let edefault excepts just cons mark =
Bindlib.box_apply3
(fun excepts just cons -> EDefault (excepts, just, cons), pos)
(fun excepts just cons -> EDefault (excepts, just, cons), mark)
(Bindlib.box_list excepts) just cons
let eifthenelse
(e1 : expr Marked.pos Bindlib.box)
(e2 : expr Marked.pos Bindlib.box)
(e3 : expr Marked.pos Bindlib.box)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), pos) e1 e2 e3
let eifthenelse e1 e2 e3 mark =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), mark) e1 e2 e3
let eerroronempty (e1 : expr Marked.pos Bindlib.box) (pos : Pos.t) :
expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, pos) e1
let eerroronempty e1 mark =
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, mark) e1
let map_expr
(ctx : 'a)
~(f : 'a -> expr Marked.pos -> expr Marked.pos Bindlib.box)
(e : expr Marked.pos) : expr Marked.pos Bindlib.box =
let map_expr ctx ~f e =
match Marked.unmark e with
| EVar v -> evar v (Marked.get_mark e)
| EApp (e1, args) ->
@ -275,27 +309,23 @@ let map_expr
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) (Marked.get_mark e)
| ErrorOnEmpty e1 -> eerroronempty ((f ctx) e1) (Marked.get_mark 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 (e : expr Marked.pos) : expr Marked.pos Bindlib.box =
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
type 'expr box_expr_sig = 'expr Marked.pos -> 'expr Marked.pos Bindlib.box
let rec fold_left_scope_lets
~(f : 'a -> 'expr scope_let -> 'expr Bindlib.var -> 'a)
~(init : 'a)
(scope_body_expr : 'expr scope_body_expr) : 'a =
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 : 'expr scope_let -> 'expr Bindlib.var -> 'a -> 'a)
~(init : 'expr Marked.pos -> 'a)
(scope_body_expr : 'expr scope_body_expr) : 'a =
let rec fold_right_scope_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result result -> init result
| ScopeLet scope_let ->
@ -303,39 +333,25 @@ let rec fold_right_scope_lets
let next_result = fold_right_scope_lets ~f ~init next in
f scope_let var next_result
let map_exprs_in_scope_lets
~(f : 'expr Marked.pos -> 'expr Marked.pos Bindlib.box)
(scope_body_expr : 'expr scope_body_expr) :
'expr scope_body_expr Bindlib.box =
let map_exprs_in_scope_lets ~f ~varf scope_body_expr =
fold_right_scope_lets
~f:(fun scope_let var_next (acc : 'expr scope_body_expr Bindlib.box) ->
let new_scope_let =
Bindlib.box_apply
(fun new_expr -> { scope_let with scope_let_expr = new_expr })
(f scope_let.scope_let_expr)
in
let new_next = Bindlib.bind_var var_next acc in
Bindlib.box_apply2
(fun new_next new_scope_let ->
ScopeLet { new_scope_let with scope_let_next = new_next })
new_next new_scope_let)
~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 : 'a -> 'expr scope_def -> 'expr Bindlib.var -> 'a)
~(init : 'a)
(scopes : 'expr scopes) : 'a =
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 : 'expr scope_def -> 'expr Bindlib.var -> 'a -> 'a)
~(init : 'a)
(scopes : 'expr scopes) : 'a =
let rec fold_right_scope_defs ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
@ -343,9 +359,7 @@ let rec fold_right_scope_defs
let result_next = fold_right_scope_defs ~f ~init next in
f scope_def var_next result_next
let map_scope_defs
~(f : 'expr scope_def -> 'expr scope_def Bindlib.box)
(scopes : 'expr scopes) : 'expr scopes Bindlib.box =
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
@ -356,125 +370,177 @@ let map_scope_defs
new_scope_def new_next)
~init:(Bindlib.box Nil) scopes
let map_exprs_in_scopes
~(f : 'expr Marked.pos -> 'expr Marked.pos Bindlib.box)
(scopes : 'expr scopes) : 'expr scopes Bindlib.box =
map_scope_defs
~f:(fun scope_def ->
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 scope_lets in
let new_scope_body_expr = map_exprs_in_scope_lets ~f ~varf scope_lets in
let new_scope_body_expr =
Bindlib.bind_var scope_input_var new_scope_body_expr
Bindlib.bind_var (varf scope_input_var) new_scope_body_expr
in
Bindlib.box_apply
(fun new_scope_body_expr ->
{
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 = new_scope_body_expr;
};
scope_body = { scope_def.scope_body with scope_body_expr };
scope_next;
})
new_scope_body_expr)
new_scope_body_expr
new_next)
~init:(Bindlib.box Nil)
scopes
type 'm var = 'm expr Bindlib.var
let new_var s = Bindlib.new_var (fun x -> EVar x) s
module Var = struct
type t = expr Bindlib.var
type t = V : 'm var -> t
(* We use this trivial GADT to make the 'm parameter disappear under an
existential. It's fine for a use as keys only.
(bindlib defines [any_var] similarly but it's not exported)
todo: add [@@ocaml.unboxed] once it's possible through abstract types *)
let make (s : string) : t =
Bindlib.new_var (fun (x : expr Bindlib.var) : expr -> EVar x) s
let t v = V v
let compare x y = Bindlib.compare_vars x y
let make (s : string) : t = V (new_var s)
let compare (V x) (V y) = Bindlib.compare_vars x y
end
module VarMap = Map.Make (Var)
module VarSet = Set.Make (Var)
module VarMap = Map.Make (Var)
let rec free_vars_expr (e : expr Marked.pos) : VarSet.t =
match Marked.unmark e with
| EVar v -> VarSet.singleton v
| ETuple (es, _) | EArray es ->
es |> List.map free_vars_expr |> List.fold_left VarSet.union VarSet.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 VarSet.union VarSet.empty
| EDefault (es, ejust, econs) ->
ejust :: econs :: es |> List.map free_vars_expr
|> List.fold_left VarSet.union VarSet.empty
| EOp _ | ELit _ -> VarSet.empty
| EIfThenElse (e1, e2, e3) ->
[e1; e2; e3] |> List.map free_vars_expr
|> List.fold_left VarSet.union VarSet.empty
| EAbs (binder, _) ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right VarSet.remove vs (free_vars_expr body)
(* let rec free_vars_expr (e : untyped marked_expr) : VarSet.t = match
Marked.unmark e with | EVar v -> VarSet.singleton v | ETuple (es, _) | EArray
es -> es |> List.map free_vars_expr |> List.fold_left VarSet.union
VarSet.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 VarSet.union
VarSet.empty | EDefault (es, ejust, econs) -> ejust :: econs :: es |>
List.map free_vars_expr |> List.fold_left VarSet.union VarSet.empty | EOp _ |
ELit _ -> VarSet.empty | EIfThenElse (e1, e2, e3) -> [e1; e2; e3] |> List.map
free_vars_expr |> List.fold_left VarSet.union VarSet.empty | EAbs (binder, _)
-> let vs, body = Bindlib.unmbind binder in Array.fold_right VarSet.remove vs
(free_vars_expr body)
let rec free_vars_scope_body_expr (scope_lets : expr scope_body_expr) : VarSet.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
VarSet.union (free_vars_expr e)
(VarSet.remove v (free_vars_scope_body_expr body))
module VarMap = Map.Make (Var(struct type t = untyped end)) module VarSet =
Set.Make (Var(struct type t = untyped end))
let free_vars_scope_body (scope_body : expr scope_body) : VarSet.t =
let { scope_body_expr = binder; _ } = scope_body in
let v, body = Bindlib.unbind binder in
VarSet.remove v (free_vars_scope_body_expr body)
let rec free_vars_expr (e : expr) : VarSet.t = match Marked.unmark e with |
EVar (v, _) -> VarSet.singleton v | ETuple (es, _) | EArray es -> es |>
List.map free_vars_expr |> List.fold_left VarSet.union VarSet.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 VarSet.union VarSet.empty |
EDefault (es, ejust, econs) -> ejust :: econs :: es |> List.map
free_vars_expr |> List.fold_left VarSet.union VarSet.empty | EOp _ | ELit _
-> VarSet.empty | EIfThenElse (e1, e2, e3) -> [e1; e2; e3] |> List.map
free_vars_expr |> List.fold_left VarSet.union VarSet.empty | EAbs ((binder,
_), _) -> let vs, body = Bindlib.unmbind binder in Array.fold_right
VarSet.remove vs (free_vars_expr body)
let rec free_vars_scopes (scopes : expr scopes) : VarSet.t =
match scopes with
| Nil -> VarSet.empty
| ScopeDef { scope_body = body; scope_next = next; _ } ->
let v, next = Bindlib.unbind next in
VarSet.union
(VarSet.remove v (free_vars_scopes next))
(free_vars_scope_body body)
let rec free_vars_scope_body_expr (scope_lets : expr scope_body_expr) :
VarSet.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 VarSet.union (free_vars_expr e) (VarSet.remove v
(free_vars_scope_body_expr body))
type vars = expr Bindlib.mvar
let free_vars_scope_body (scope_body : expr scope_body) : VarSet.t = let {
scope_body_expr = binder; _ } = scope_body in let v, body = Bindlib.unbind
binder in VarSet.remove v (free_vars_scope_body_expr body)
let make_var ((x, pos) : Var.t Marked.pos) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun x -> x, pos) (Bindlib.box_var x)
let rec free_vars_scopes (scopes : expr scopes) : VarSet.t = match scopes
with | Nil -> VarSet.empty | ScopeDef { scope_body = body; scope_next = next;
_ } -> let v, next = Bindlib.unbind next in VarSet.union (VarSet.remove v
(free_vars_scopes next)) (free_vars_scope_body body) (* type vars = expr
Bindlib.mvar *) *)
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_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)
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)
(* 'm expr → 'e 'm marked_expr = ('m expr, 'm) marked → ('e, 'm) marked
let make_let_in
(x : Var.t)
(tau : typ Marked.pos)
(e1 : expr Marked.pos Bindlib.box)
(e2 : expr Marked.pos Bindlib.box)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
make_app (make_abs (Array.of_list [x]) e2 [tau] pos) [e1] pos
('e, 'x) marked = ('e, 'x mark) Marked.t = ('e * 'x mark)
let empty_thunked_term : expr Marked.pos =
let silent = Var.make "_" in
'e Bindlib.mvar -> ('e, 'm) Marked.t Bindlib.box -> typ Marked.pos list -> 'm
-> ('e, 'm) Marked.t Bindlib.box *)
(* 'e = 'm expr ('e, 'm) marked = ('e, 'm mark) Marked.t = ('m expr, 'm mark)
Marked.t *)
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 empty_thunked_term : untyped marked_expr =
let silent = new_var "_" in
Bindlib.unbox
(make_abs (Array.of_list [silent])
(Bindlib.box (ELit LEmptyError, Pos.no_pos))
(make_abs [| silent |]
(Bindlib.box
(ELit LEmptyError, Untyped { pos = Pos.no_pos }
: (untyped expr, untyped) marked))
[TLit TUnit, Pos.no_pos]
Pos.no_pos)
(Untyped { pos = Pos.no_pos }))
let is_value (e : expr Marked.pos) : bool =
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 : Infer.unionfind_typ -> Infer.unionfind_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 -> Infer.unionfind_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 (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 -> UnionFind.make (Infer.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 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 =
@ -514,7 +580,7 @@ let equal_ops (op1 : operator) (op2 : operator) : bool =
| Unop op1, Unop op2 -> equal_unops op1 op2
| _, _ -> false
let rec equal_exprs (e1 : expr Marked.pos) (e2 : expr Marked.pos) : bool =
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
@ -542,33 +608,18 @@ let rec equal_exprs (e1 : expr Marked.pos) (e2 : expr Marked.pos) : bool =
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal_exprs e1 e2
| _, _ -> false
and equal_exprs_list (es1 : expr Marked.pos list) (es2 : expr Marked.pos list) :
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)
type 'expr make_let_in_sig =
'expr Bindlib.var ->
typ Marked.pos ->
'expr Marked.pos Bindlib.box ->
'expr Marked.pos Bindlib.box ->
Pos.t ->
'expr Marked.pos Bindlib.box
type 'expr make_abs_sig =
'expr Bindlib.mvar ->
'expr Marked.pos Bindlib.box ->
typ Marked.pos list ->
Pos.t ->
'expr Marked.pos Bindlib.box
let rec unfold_scope_body_expr
~(box_expr : 'expr box_expr_sig)
~(make_let_in : 'expr make_let_in_sig)
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(scope_let : 'expr scope_body_expr) : 'expr Marked.pos Bindlib.box =
(scope_let : ('expr, 'm) scope_body_expr) : ('expr, 'm) marked Bindlib.box =
match scope_let with
| Result e -> box_expr e
| ScopeLet
@ -585,12 +636,12 @@ let rec unfold_scope_body_expr
scope_let_pos
let build_whole_scope_expr
~(box_expr : 'expr box_expr_sig)
~(make_abs : 'expr make_abs_sig)
~(make_let_in : 'expr make_let_in_sig)
~(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 scope_body)
(pos_scope : Pos.t) : 'expr Marked.pos Bindlib.box =
(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
@ -599,9 +650,9 @@ let build_whole_scope_expr
( List.map snd
(StructMap.find body.scope_body_input_struct ctx.ctx_structs),
Some body.scope_body_input_struct ),
pos_scope );
mark_pos mark_scope );
]
pos_scope
mark_scope
let build_scope_typ_from_sig
(ctx : decl_ctx)
@ -624,22 +675,28 @@ 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 box_expr_sig)
~(make_abs : 'expr make_abs_sig)
~(make_let_in : 'expr make_let_in_sig)
~(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 scopes)
(main_scope : 'expr scope_name_or_var) : 'expr Marked.pos Bindlib.box =
(s : ('expr, 'm) scopes)
(mark_witness : '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, Pos.no_pos) (Bindlib.box_var v)
Bindlib.box_apply (fun v -> v, no_mark mark_witness) (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
@ -651,15 +708,16 @@ let rec unfold_scopes
(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_pos)
(unfold_scopes ~box_expr ~make_abs ~make_let_in ctx scope_next main_scope)
scope_body_mark)
(unfold_scopes ~box_expr ~make_abs ~make_let_in ctx scope_next
mark_witness main_scope)
scope_pos
let build_whole_program_expr (p : program) (main_scope : ScopeName.t) =
let build_whole_program_expr (p : 'm program) (main_scope : ScopeName.t) =
unfold_scopes ~box_expr ~make_abs ~make_let_in p.decl_ctx p.scopes
(ScopeName main_scope)
p.mark_witness (ScopeName main_scope)
let rec expr_size (e : expr Marked.pos) : int =
let rec expr_size (e : 'm marked_expr) : int =
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) | EArray args ->
@ -681,7 +739,7 @@ let rec expr_size (e : expr Marked.pos) : int =
(1 + expr_size just + expr_size cons)
exceptions
let remove_logging_calls (e : expr Marked.pos) : expr Marked.pos Bindlib.box =
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

366
compiler/dcalc/ast.mli
View File

@ -32,12 +32,13 @@ module EnumMap : Map.S with type key = EnumName.t
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type typ =
type marked_typ = typ Marked.pos
and typ =
| TLit of typ_lit
| TTuple of typ Marked.pos list * StructName.t option
| TEnum of typ Marked.pos list * EnumName.t
| TArrow of typ Marked.pos * typ Marked.pos
| TArray of typ Marked.pos
| 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
| TAny
type date = Runtime.date
@ -102,35 +103,72 @@ type unop =
type operator = Ternop of ternop | Binop of binop | Unop of unop
type marked_expr = expr Marked.pos
(** Contains some structures used for type inference *)
module Infer: sig
module Any: Utils.Uid.Id with type info = unit
(** We do not reuse {!type: 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. *)
type unionfind_typ = typ Marked.pos UnionFind.elem
and typ =
| TLit of typ_lit
| TArrow of unionfind_typ * unionfind_typ
| TTuple of unionfind_typ list * StructName.t option
| TEnum of unionfind_typ list * EnumName.t
| TArray of unionfind_typ
| TAny of Any.t
val typ_to_ast : unionfind_typ -> marked_typ
end
type untyped = { pos : Pos.t } [@@unboxed]
type typed = { pos : Pos.t; ty : Infer.unionfind_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 *)
type _ mark =
| Untyped: untyped -> untyped mark
| Typed: typed -> typed mark
type ('a, 'm) marked = ('a, 'm mark) Marked.t
type 'm marked_expr = ('m expr, 'm) marked
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
and expr =
| EVar of expr Bindlib.var
| ETuple of marked_expr list * StructName.t option
and 'm expr =
| EVar of 'm expr Bindlib.var
| ETuple of 'm marked_expr list * StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of
marked_expr * int * StructName.t option * typ Marked.pos list
'm marked_expr * int * StructName.t option * marked_typ list
(** The [MarkedString.info] is the former struct field name *)
| EInj of marked_expr * int * EnumName.t * typ Marked.pos list
| EInj of 'm marked_expr * int * EnumName.t * marked_typ list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of marked_expr * marked_expr list * EnumName.t
| EMatch of 'm marked_expr * 'm marked_expr list * EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of marked_expr list
| EArray of 'm marked_expr list
| ELit of lit
| EAbs of ((expr, marked_expr) Bindlib.mbinder[@opaque]) * typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EAssert of marked_expr
| EAbs of
(('m expr, 'm marked_expr) Bindlib.mbinder[@opaque]) * marked_typ list
| EApp of 'm marked_expr * 'm marked_expr list
| EAssert of 'm marked_expr
| EOp of operator
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| ErrorOnEmpty of marked_expr
| EDefault of 'm marked_expr list * 'm marked_expr * 'm marked_expr
| EIfThenElse of 'm marked_expr * 'm marked_expr * 'm marked_expr
| ErrorOnEmpty of 'm marked_expr
type struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
(** {3 Expression annotations ([Marked.t])} *)
type typed_expr = typed marked_expr
type struct_ctx = (StructFieldName.t * marked_typ) list StructMap.t
type enum_ctx = (EnumConstructor.t * marked_typ) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
type binder = (expr, expr Marked.pos) Bindlib.binder
type 'm binder = ('m expr, 'm marked_expr) Bindlib.binder
(** This kind annotation signals that the let-binding respects a structural
invariant. These invariants concern the shape of the expression in the
@ -145,12 +183,12 @@ type scope_let_kind =
| DestructuringSubScopeResults (** [let s.x = result.x ]**)
| Assertion (** [let _ = assert e]*)
type 'expr scope_let = {
type ('expr, 'm) scope_let = {
scope_let_kind : scope_let_kind;
scope_let_typ : typ Utils.Marked.pos;
scope_let_expr : 'expr Utils.Marked.pos;
scope_let_next : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_let_pos : Utils.Pos.t;
scope_let_typ : marked_typ;
scope_let_expr : ('expr, 'm) marked;
scope_let_next : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
scope_let_pos : Pos.t;
}
(** This type is parametrized by the expression type so it can be reused in
later intermediate representations. *)
@ -158,109 +196,116 @@ type 'expr scope_let = {
(** 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 scope_body_expr =
| Result of 'expr Utils.Marked.pos
| ScopeLet of 'expr scope_let
and ('expr, 'm) scope_body_expr =
| Result of ('expr, 'm) marked
| ScopeLet of ('expr, 'm) scope_let
type 'expr scope_body = {
type ('expr, 'm) scope_body = {
scope_body_input_struct : StructName.t;
scope_body_output_struct : StructName.t;
scope_body_expr : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_body_expr : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
}
(** 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 scope_def = {
type ('expr, 'm) scope_def = {
scope_name : ScopeName.t;
scope_body : 'expr scope_body;
scope_next : ('expr, 'expr scopes) Bindlib.binder;
scope_body : ('expr, 'm) scope_body;
scope_next : ('expr, ('expr, 'm) scopes) Bindlib.binder;
}
(** 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 'a scopes = Nil | ScopeDef of 'a scope_def
and ('expr, 'm) scopes = Nil | ScopeDef of ('expr, 'm) scope_def
type program = { decl_ctx : decl_ctx; scopes : expr scopes }
type 'm program = { decl_ctx : decl_ctx; scopes : ('m expr, 'm) scopes }
(** {1 Helpers} *)
(** {2 Boxed constructors}*)
(** {2 Manipulation of marks} *)
val evar : expr Bindlib.var -> Pos.t -> expr Marked.pos Bindlib.box
val no_mark: 'm mark -> 'm mark
val pos: ('a, 'm) marked -> Pos.t
val ty: ('a, typed) marked -> typ
val with_ty: Infer.unionfind_typ -> ('a, 'm) marked -> ('a, typed) marked
val map_mark: (Pos.t -> Pos.t) -> (Infer.unionfind_typ -> Infer.unionfind_typ) -> 'm mark -> 'm mark
val map_mark2: (Pos.t -> Pos.t -> Pos.t) -> (typed -> typed -> Infer.unionfind_typ) -> 'm mark -> 'm mark -> 'm mark
val get_scope_body_mark: ('expr, 'm) scope_body -> 'm mark
(** {2 Boxed constructors} *)
val evar : 'm expr Bindlib.var -> 'm mark -> 'm marked_expr Bindlib.box
val etuple :
expr Marked.pos Bindlib.box list ->
'm marked_expr Bindlib.box list ->
StructName.t option ->
Pos.t ->
expr Marked.pos Bindlib.box
'm mark ->
'm marked_expr Bindlib.box
val etupleaccess :
expr Marked.pos Bindlib.box ->
'm marked_expr Bindlib.box ->
int ->
StructName.t option ->
typ Marked.pos list ->
Pos.t ->
expr Marked.pos Bindlib.box
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val einj :
expr Marked.pos Bindlib.box ->
'm marked_expr Bindlib.box ->
int ->
EnumName.t ->
typ Marked.pos list ->
Pos.t ->
expr Marked.pos Bindlib.box
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val ematch :
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
EnumName.t ->
Pos.t ->
expr Marked.pos Bindlib.box
'm mark ->
'm marked_expr Bindlib.box
val earray :
expr Marked.pos Bindlib.box list -> Pos.t -> expr Marked.pos Bindlib.box
val elit : lit -> Pos.t -> expr Marked.pos 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 :
(expr, expr Marked.pos) Bindlib.mbinder Bindlib.box ->
typ Marked.pos list ->
Pos.t ->
expr Marked.pos Bindlib.box
('m expr, 'm marked_expr) Bindlib.mbinder Bindlib.box ->
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val eapp :
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
Pos.t ->
expr Marked.pos Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val eassert :
expr Marked.pos Bindlib.box -> Pos.t -> expr Marked.pos Bindlib.box
val eop : operator -> Pos.t -> expr Marked.pos 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 :
expr Marked.pos Bindlib.box list ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
Pos.t ->
expr Marked.pos Bindlib.box
'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 :
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
Pos.t ->
expr Marked.pos Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eerroronempty :
expr Marked.pos Bindlib.box -> Pos.t -> expr Marked.pos Bindlib.box
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
val box_expr : expr Marked.pos -> expr Marked.pos Bindlib.box
type ('expr, 'm) box_expr_sig =
('expr, 'm) marked -> ('expr, 'm) marked Bindlib.box
type 'expr box_expr_sig = 'expr Marked.pos -> 'expr Marked.pos Bindlib.box
val box_expr : ('m expr, 'm) box_expr_sig
(**{2 Program traversal}*)
@ -269,9 +314,9 @@ type 'expr box_expr_sig = 'expr Marked.pos -> 'expr Marked.pos Bindlib.box
val map_expr :
'a ->
f:('a -> expr Marked.pos -> expr Marked.pos Bindlib.box) ->
expr Marked.pos ->
expr Marked.pos Bindlib.box
f:('a -> 'm marked_expr -> 'm marked_expr Bindlib.box) ->
'm marked_expr ->
'm 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
@ -290,9 +335,9 @@ val map_expr :
around during your map traversal. *)
val fold_left_scope_lets :
f:('a -> 'expr scope_let -> 'expr Bindlib.var -> 'a) ->
f:('a -> ('expr, 'm) scope_let -> 'expr Bindlib.var -> 'a) ->
init:'a ->
'expr scope_body_expr ->
('expr, 'm) scope_body_expr ->
'a
(** Usage:
[fold_left_scope_lets ~f:(fun acc scope_let scope_let_var -> ...) ~init scope_lets],
@ -300,9 +345,9 @@ val fold_left_scope_lets :
scope lets to be examined. *)
val fold_right_scope_lets :
f:('expr scope_let -> 'expr Bindlib.var -> 'a -> 'a) ->
init:('expr Marked.pos -> 'a) ->
'expr scope_body_expr ->
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],
@ -310,14 +355,15 @@ val fold_right_scope_lets :
scope lets to be examined (which are before in the program order). *)
val map_exprs_in_scope_lets :
f:('expr Marked.pos -> 'expr Marked.pos Bindlib.box) ->
'expr scope_body_expr ->
'expr scope_body_expr Bindlib.box
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 -> 'expr scope_def -> 'expr Bindlib.var -> 'a) ->
f:('a -> ('expr1, 'm1) scope_def -> 'expr1 Bindlib.var -> 'a) ->
init:'a ->
'expr scopes ->
('expr1, 'm1) scopes ->
'a
(** Usage:
[fold_left_scope_defs ~f:(fun acc scope_def scope_var -> ...) ~init scope_def],
@ -325,9 +371,9 @@ val fold_left_scope_defs :
be examined. *)
val fold_right_scope_defs :
f:('expr scope_def -> 'expr Bindlib.var -> 'a -> 'a) ->
f:(('expr1, 'm1) scope_def -> 'expr1 Bindlib.var -> 'a -> 'a) ->
init:'a ->
'expr scopes ->
('expr1, 'm1) scopes ->
'a
(** Usage:
[fold_right_scope_defs ~f:(fun scope_def scope_var acc -> ...) ~init scope_def],
@ -335,22 +381,29 @@ val fold_right_scope_defs :
be examined (which are before in the program order). *)
val map_scope_defs :
f:('expr scope_def -> 'expr scope_def Bindlib.box) ->
'expr scopes ->
'expr scopes Bindlib.box
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:('expr Marked.pos -> 'expr Marked.pos Bindlib.box) ->
'expr scopes ->
'expr scopes Bindlib.box
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. *)
(** {2 Variables}*)
(** {2 Variables} *)
type 'm var = 'm expr Bindlib.var
val new_var: string -> 'm var
(** {2 Boxed term constructors} *)
module Var : sig
type t = expr Bindlib.var
type t
val t: 'm var -> t
val make : string -> t
val compare : t -> t -> int
end
@ -358,71 +411,59 @@ end
module VarMap : Map.S with type key = Var.t
module VarSet : Set.S with type elt = Var.t
val free_vars_expr : expr Marked.pos -> VarSet.t
val free_vars_scope_body_expr : expr scope_body_expr -> VarSet.t
val free_vars_scope_body : expr scope_body -> VarSet.t
val free_vars_scopes : expr scopes -> VarSet.t
(* val free_vars_expr : expr Marked.pos -> VarSet.t val
* free_vars_scope_body_expr : expr scope_body_expr -> VarSet.t val
* free_vars_scope_body : expr scope_body -> VarSet.t val free_vars_scopes :
* expr scopes -> VarSet.t *)
type vars = expr Bindlib.mvar
(* type vars = expr Bindlib.mvar *)
(** {2 Boxed term constructors}*)
val make_var : ('m expr Bindlib.var, 'm) marked -> 'm marked_expr Bindlib.box
val make_var : Var.t Marked.pos -> expr Marked.pos Bindlib.box
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 :
vars ->
expr Marked.pos Bindlib.box ->
typ Marked.pos list ->
Pos.t ->
expr Marked.pos Bindlib.box
val make_abs : ('m expr, 'm) make_abs_sig
val make_app :
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
Pos.t ->
expr Marked.pos Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val make_let_in :
Var.t ->
typ Marked.pos ->
expr Marked.pos Bindlib.box ->
expr Marked.pos 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 Marked.pos Bindlib.box
('expr, 'm) marked Bindlib.box
val make_let_in : ('m expr, 'm) make_let_in_sig
(**{2 Other}*)
val empty_thunked_term : expr Marked.pos
val is_value : expr Marked.pos -> bool
val empty_thunked_term : untyped marked_expr
val is_value : 'm marked_expr -> bool
val equal_exprs : expr Marked.pos -> expr Marked.pos -> 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}*)
type 'expr make_let_in_sig =
'expr Bindlib.var ->
typ Marked.pos ->
'expr Marked.pos Bindlib.box ->
'expr Marked.pos Bindlib.box ->
Pos.t ->
'expr Marked.pos Bindlib.box
type 'expr make_abs_sig =
'expr Bindlib.mvar ->
'expr Marked.pos Bindlib.box ->
typ Marked.pos list ->
Pos.t ->
'expr Marked.pos Bindlib.box
val build_whole_scope_expr :
box_expr:'expr box_expr_sig ->
make_abs:'expr make_abs_sig ->
make_let_in:'expr make_let_in_sig ->
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 scope_body ->
Pos.t ->
'expr Marked.pos Bindlib.box
('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. *)
@ -432,23 +473,24 @@ type 'expr scope_name_or_var =
| ScopeVar of 'expr Bindlib.var
val unfold_scopes :
box_expr:'expr box_expr_sig ->
make_abs:'expr make_abs_sig ->
make_let_in:'expr make_let_in_sig ->
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 scopes ->
('expr, 'm) scopes ->
'm mark ->
'expr scope_name_or_var ->
'expr Marked.pos Bindlib.box
('expr, 'm) marked Bindlib.box
val build_whole_program_expr :
program -> ScopeName.t -> expr Marked.pos Bindlib.box
'm program -> ScopeName.t -> 'm marked_expr 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 : expr Marked.pos -> int
val expr_size : 'm marked_expr -> int
(** Used by the optimizer to know when to stop *)
val remove_logging_calls : expr Marked.pos -> expr Marked.pos Bindlib.box
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. *)

24
compiler/dcalc/interpreter.ml
View File

@ -21,7 +21,7 @@ module A = Ast
(** {1 Helpers} *)
let is_empty_error (e : A.expr Marked.pos) : bool =
let is_empty_error (e : 'm A.marked_expr) : bool =
match Marked.unmark e with ELit LEmptyError -> true | _ -> false
let log_indent = ref 0
@ -31,32 +31,32 @@ let log_indent = ref 0
let rec evaluate_operator
(ctx : Ast.decl_ctx)
(op : A.operator Marked.pos)
(args : A.expr Marked.pos list) : A.expr Marked.pos =
(args : 'm A.marked_expr list) : 'm A.marked_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 -> A.expr) (op : A.operator Marked.pos)
: A.expr =
let apply_div_or_raise_err (div : unit -> 'm A.expr) (op : A.operator Marked.pos)
: 'm A.expr =
try div ()
with Division_by_zero ->
Errors.raise_multispanned_error
[
Some "The division operator:", Marked.get_mark op;
Some "The null denominator:", Marked.get_mark (List.nth args 1);
Some "The null denominator:", Ast.pos (List.nth args 1);
]
"division by zero at runtime"
in
let get_binop_args_pos (args : (A.expr * Pos.t) list) :
let get_binop_args_pos (arg0::arg1::_ : ('m A.expr * 'm) list) :
(string option * Pos.t) list =
[
None, Marked.get_mark (List.nth args 0);
None, Marked.get_mark (List.nth args 1);
None, Ast.pos arg0;
None, Ast.pos arg1;
]
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 -> A.expr)
(args : (A.expr * Pos.t) list) : A.expr =
(cmp : unit -> 'm A.expr)
(args : 'm A.marked_expr list) : 'm A.expr =
try cmp ()
with Runtime.UncomparableDurations ->
Errors.raise_multispanned_error (get_binop_args_pos args)
@ -329,8 +329,8 @@ let rec evaluate_operator
(should not happen if the term was well-typed)")
op
and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Marked.pos) :
A.expr Marked.pos =
and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) :
'm A.marked_expr =
match Marked.unmark e with
| EVar _ ->
Errors.raise_spanned_error (Marked.get_mark e)

6
compiler/dcalc/interpreter.mli
View File

@ -18,13 +18,13 @@
open Utils
val evaluate_expr : Ast.decl_ctx -> Ast.expr Marked.pos -> Ast.expr Marked.pos
val evaluate_expr : Ast.decl_ctx -> 'm Ast.marked_expr -> 'm Ast.marked_expr
(** Evaluates an expression according to the semantics of the default calculus. *)
val interpret_program :
Ast.decl_ctx ->
Ast.expr Marked.pos ->
(Uid.MarkedString.info * Ast.expr Marked.pos) list
'm Ast.marked_expr ->
(Uid.MarkedString.info * 'm Ast.marked_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

22
compiler/dcalc/optimizations.ml
View File

@ -18,12 +18,12 @@ open Utils
open Ast
type partial_evaluation_ctx = {
var_values : expr Marked.pos Ast.VarMap.t;
var_values : typed marked_expr Ast.VarMap.t;
decl_ctx : decl_ctx;
}
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Marked.pos)
: expr Marked.pos Bindlib.box =
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr)
: 'm marked_expr Bindlib.box =
let pos = Marked.get_mark e in
let rec_helper = partial_evaluation ctx in
match Marked.unmark e with
@ -183,13 +183,13 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Marked.pos)
| ErrorOnEmpty e1 ->
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, pos) (rec_helper e1)
let optimize_expr (decl_ctx : decl_ctx) (e : expr Marked.pos) =
let optimize_expr (decl_ctx : decl_ctx) (e : 'm marked_expr) =
partial_evaluation { var_values = VarMap.empty; decl_ctx } e
let rec scope_lets_map
(t : 'a -> expr Marked.pos -> expr Marked.pos Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(scope_body_expr : expr scope_body_expr) : expr scope_body_expr Bindlib.box
(scope_body_expr : ('m expr, 'm) scope_body_expr) : ('m expr, 'm) scope_body_expr Bindlib.box
=
match scope_body_expr with
| Result e -> Bindlib.box_apply (fun e' -> Result e') (t ctx e)
@ -209,9 +209,9 @@ let rec scope_lets_map
new_scope_let_expr new_next
let rec scopes_map
(t : 'a -> expr Marked.pos -> expr Marked.pos Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(scopes : expr scopes) : expr scopes Bindlib.box =
(scopes : ('m expr, 'm) scopes) : ('m expr, 'm) scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box Nil
| ScopeDef scope_def ->
@ -240,14 +240,14 @@ let rec scopes_map
new_scope_body_expr new_scope_next
let program_map
(t : 'a -> expr Marked.pos -> expr Marked.pos Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(p : program) : program Bindlib.box =
(p : 'm program) : 'm program Bindlib.box =
Bindlib.box_apply
(fun new_scopes -> { p with scopes = new_scopes })
(scopes_map t ctx p.scopes)
let optimize_program (p : program) : program =
let optimize_program (p : 'm program) : 'm program =
Bindlib.unbox
(program_map partial_evaluation
{ var_values = VarMap.empty; decl_ctx = p.decl_ctx }

5
compiler/dcalc/optimizations.mli
View File

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

71
compiler/dcalc/print.ml
View File

@ -17,8 +17,8 @@
open Utils
open Ast
let typ_needs_parens (e : typ Marked.pos) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
let typ_needs_parens (e : typ) : bool =
match e with TArrow _ | TArray _ -> true | _ -> false
let is_uppercase (x : CamomileLibraryDefault.Camomile.UChar.t) : bool =
try
@ -82,20 +82,20 @@ let format_enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) :
let rec format_typ
(ctx : Ast.decl_ctx)
(fmt : Format.formatter)
(typ : typ Marked.pos) : unit =
(typ : typ) : unit =
let format_typ = format_typ ctx in
let format_typ_with_parens (fmt : Format.formatter) (t : 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
match Marked.unmark typ with
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))
ts
(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 "{"
@ -106,7 +106,7 @@ let rec format_typ
Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\""
StructFieldName.format_t field format_punctuation "\""
format_punctuation ":" format_typ typ))
(StructMap.find s ctx.ctx_structs)
(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
@ -117,19 +117,19 @@ let rec format_typ
(fun fmt (case, typ) ->
Format.fprintf fmt "%a%a@ %a" format_enum_constructor case
format_punctuation ":" format_typ typ))
(EnumMap.find e ctx.ctx_enums)
(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 t1
format_operator "→" format_typ 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
t1
(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 Marked.pos) : unit =
match Marked.unmark l with
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 "∅ "
@ -158,9 +158,9 @@ let format_op_kind (fmt : Format.formatter) (k : op_kind) =
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
let format_binop (fmt : Format.formatter) (op : binop) : unit =
format_operator fmt
(match Marked.unmark op with
(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
@ -178,8 +178,8 @@ let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
| Map -> "map"
| Filter -> "filter")
let format_ternop (fmt : Format.formatter) (op : ternop Marked.pos) : unit =
match Marked.unmark op with Fold -> format_keyword fmt "fold"
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"
@ -189,9 +189,9 @@ let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
| EndCall -> Utils.Cli.with_style [ANSITerminal.yellow] "← "
| PosRecordIfTrueBool -> Utils.Cli.with_style [ANSITerminal.green] "☛ ")
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
let format_unop (fmt : Format.formatter) (op : unop) : unit =
Format.fprintf fmt "%s"
(match Marked.unmark op with
(match op with
| Minus _ -> "-"
| Not -> "~"
| Log (entry, infos) ->
@ -208,19 +208,19 @@ let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
| RoundMoney -> "round_money"
| RoundDecimal -> "round_decimal")
let needs_parens (e : expr Marked.pos) : bool =
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 : Var.t) : unit =
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 : expr Marked.pos) : unit =
(e : 'm marked_expr) : unit =
let format_expr = format_expr ~debug ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Marked.pos) =
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 ")"
@ -274,10 +274,10 @@ let rec format_expr
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 (Marked.same_mark_as l e)
| 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, tau) (Array.to_list xs) taus 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
@ -290,7 +290,7 @@ let rec format_expr
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
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
@ -300,15 +300,15 @@ let rec format_expr
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, Pos.no_pos)
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, Pos.no_pos) format_with_parens arg2
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, Pos.no_pos)
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
@ -320,9 +320,9 @@ let rec format_expr
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, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| 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 "⟨"
@ -348,10 +348,13 @@ let format_scope
?(debug : bool = false)
(ctx : decl_ctx)
(fmt : Format.formatter)
((n, s) : Ast.ScopeName.t * Ast.expr scope_body) =
((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
(Marked.get_mark (Ast.ScopeName.get_info n))))
(Ast.map_mark
(fun _ -> Marked.get_mark (Ast.ScopeName.get_info n))
(fun ty -> ty)
(Ast.get_scope_body_mark s))))

16
compiler/dcalc/print.mli
View File

@ -36,25 +36,25 @@ val format_lit_style : Format.formatter -> string -> unit
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 Marked.pos -> unit
val format_lit : Format.formatter -> Ast.lit Marked.pos -> 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 Marked.pos -> unit
val format_ternop : Format.formatter -> Ast.ternop Marked.pos -> 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 Marked.pos -> unit
val format_var : Format.formatter -> Ast.Var.t -> 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 ->
Ast.expr Marked.pos ->
'm Ast.marked_expr ->
unit
val format_scope :
?debug:bool (** [true] for debug printing *) ->
Ast.decl_ctx ->
Format.formatter ->
Ast.ScopeName.t * Ast.expr Ast.scope_body ->
Ast.ScopeName.t * ('m Ast.expr, 'm) Ast.scope_body ->
unit

653
compiler/dcalc/typing.ml
View File

@ -19,29 +19,10 @@
open Utils
module A = Ast
open A.Infer
(** {1 Types and unification} *)
module Any =
Utils.Uid.Make
(struct
type info = unit
let format_info fmt () = Format.fprintf fmt "any"
end)
()
(** 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
captured by the type sytem. *)
type typ =
| TLit of A.typ_lit
| TArrow of typ Marked.pos UnionFind.elem * typ Marked.pos UnionFind.elem
| TTuple of typ Marked.pos UnionFind.elem list * Ast.StructName.t option
| TEnum of typ Marked.pos UnionFind.elem list * Ast.EnumName.t
| TArray of typ Marked.pos UnionFind.elem
| TAny of Any.t
let typ_needs_parens (t : typ Marked.pos UnionFind.elem) : bool =
let t = UnionFind.get (UnionFind.find t) in
match Marked.unmark t with TArrow _ | TArray _ -> true | _ -> false
@ -226,371 +207,403 @@ let rec ast_to_typ (ty : A.typ) : typ =
| A.TArray t -> TArray (UnionFind.make (Marked.map_under_mark ast_to_typ t))
| A.TAny -> TAny (Any.fresh ())
let rec typ_to_ast (ty : typ Marked.pos UnionFind.elem) : A.typ Marked.pos =
Marked.map_under_mark
(fun ty ->
match ty with
| TLit l -> A.TLit l
| TTuple (ts, s) -> A.TTuple (List.map typ_to_ast ts, s)
| TEnum (ts, e) -> A.TEnum (List.map typ_to_ast ts, e)
| TArrow (t1, t2) -> A.TArrow (typ_to_ast t1, typ_to_ast t2)
| TAny _ -> A.TAny
| TArray t1 -> A.TArray (typ_to_ast t1))
(UnionFind.get (UnionFind.find ty))
(** {1 Double-directed typing} *)
type env = typ Marked.pos UnionFind.elem A.VarMap.t
let add_pos e ty = Marked.mark (A.pos e) ty
let ty (_, A.Typed { ty; _ }) = ty
(** used to convert an [untyped expr var] into a [typed expr var] *)
let translate_var v = Bindlib.copy_var v (fun x -> A.EVar x) (Bindlib.name_of v)
(** Infers the most permissive type from an expression *)
let rec typecheck_expr_bottom_up
let rec typecheck_expr_bottom_up: 'm .
Ast.decl_ctx ->
env ->
'm A.marked_expr -> A.typed_expr = fun
(ctx : Ast.decl_ctx)
(env : env)
(e : A.expr Marked.pos) : typ Marked.pos UnionFind.elem =
(e : 'm A.marked_expr) : A.typed_expr ->
(* (ctx : Ast.decl_ctx)
* (env : env)
* (e : 'm A.marked_expr) : A.typed_expr = *)
(* Cli.debug_print (Format.asprintf "Looking for type of %a"
(Print.format_expr ctx) e); *)
try
let out =
match Marked.unmark e with
| EVar v -> (
match A.VarMap.find_opt v env with
| Some t -> t
| None ->
Errors.raise_spanned_error (Marked.get_mark e)
"Variable not found in the current context")
| ELit (LBool _) -> UnionFind.make (Marked.same_mark_as (TLit TBool) e)
| ELit (LInt _) -> UnionFind.make (Marked.same_mark_as (TLit TInt) e)
| ELit (LRat _) -> UnionFind.make (Marked.same_mark_as (TLit TRat) e)
| ELit (LMoney _) -> UnionFind.make (Marked.same_mark_as (TLit TMoney) e)
| ELit (LDate _) -> UnionFind.make (Marked.same_mark_as (TLit TDate) e)
| ELit (LDuration _) ->
UnionFind.make (Marked.same_mark_as (TLit TDuration) e)
| ELit LUnit -> UnionFind.make (Marked.same_mark_as (TLit TUnit) e)
| ELit LEmptyError ->
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e)
| ETuple (es, s) ->
let ts = List.map (typecheck_expr_bottom_up ctx env) es in
UnionFind.make (Marked.same_mark_as (TTuple (ts, s)) e)
| ETupleAccess (e1, n, s, typs) -> (
let typs =
List.map
(fun typ -> UnionFind.make (Marked.map_under_mark ast_to_typ typ))
typs
in
typecheck_expr_top_down ctx env e1
(UnionFind.make (TTuple (typs, s), Marked.get_mark e));
match List.nth_opt typs n with
| Some t' -> t'
| None ->
Errors.raise_spanned_error (Marked.get_mark e1)
"Expression should have a tuple type with at least %d elements but \
only has %d"
n (List.length typs))
| EInj (e1, n, e_name, ts) ->
let ts =
List.map
(fun t -> UnionFind.make (Marked.map_under_mark ast_to_typ t))
ts
in
let ts_n =
match List.nth_opt ts n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error (Marked.get_mark e)
"Expression should have a sum type with at least %d cases but \
only has %d"
n (List.length ts)
in
typecheck_expr_top_down ctx env e1 ts_n;
UnionFind.make (Marked.same_mark_as (TEnum (ts, e_name)) e)
| EMatch (e1, es, e_name) ->
let enum_cases =
List.map
(fun e' ->
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e'))
es
in
let t_e1 =
UnionFind.make (Marked.same_mark_as (TEnum (enum_cases, e_name)) e1)
in
typecheck_expr_top_down ctx env e1 t_e1;
let t_ret =
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e)
in
List.iteri
(fun i es' ->
let enum_t = List.nth enum_cases i in
let t_es' =
UnionFind.make (Marked.same_mark_as (TArrow (enum_t, t_ret)) es')
in
typecheck_expr_top_down ctx env es' t_es')
es;
t_ret
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let pos_binder = Marked.get_mark e in
if Array.length xs = List.length taus then
let xstaus =
List.map2
(fun x tau ->
( x,
UnionFind.make
(ast_to_typ (Marked.unmark tau), Marked.get_mark tau) ))
(Array.to_list xs) taus
in
let env =
List.fold_left
(fun env (x, tau) -> A.VarMap.add x tau env)
env xstaus
in
List.fold_right
(fun (_, t_arg) (acc : typ Marked.pos UnionFind.elem) ->
UnionFind.make (TArrow (t_arg, acc), pos_binder))
xstaus
(typecheck_expr_bottom_up ctx env body)
else
Errors.raise_spanned_error pos_binder
"function has %d variables but was supplied %d types"
(Array.length xs) (List.length taus)
| EApp (e1, args) ->
let t_args = List.map (typecheck_expr_bottom_up ctx env) args in
let t_ret =
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e)
in
let t_app =
List.fold_right
(fun t_arg acc ->
UnionFind.make (Marked.same_mark_as (TArrow (t_arg, acc)) e))
t_args t_ret
in
typecheck_expr_top_down ctx env e1 t_app;
t_ret
| EOp op -> op_type (Marked.same_mark_as op e)
| EDefault (excepts, just, cons) ->
typecheck_expr_top_down ctx env just
(UnionFind.make (Marked.same_mark_as (TLit TBool) just));
let tcons = typecheck_expr_bottom_up ctx env cons in
List.iter
(fun except -> typecheck_expr_top_down ctx env except tcons)
excepts;
tcons
| EIfThenElse (cond, et, ef) ->
typecheck_expr_top_down ctx env cond
(UnionFind.make (Marked.same_mark_as (TLit TBool) cond));
let tt = typecheck_expr_bottom_up ctx env et in
typecheck_expr_top_down ctx env ef tt;
tt
| EAssert e' ->
typecheck_expr_top_down ctx env e'
(UnionFind.make (Marked.same_mark_as (TLit TBool) e'));
UnionFind.make (Marked.same_mark_as (TLit TUnit) e')
| ErrorOnEmpty e' -> typecheck_expr_bottom_up ctx env e'
| EArray es ->
let cell_type =
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e)
in
List.iter
(fun e' ->
let t_e' = typecheck_expr_bottom_up ctx env e' in
unify ctx cell_type t_e')
es;
UnionFind.make (Marked.same_mark_as (TArray cell_type) e)
let pos_e = A.pos e in
let mark (e : A.typed A.expr) ty =
Marked.mark (A.Typed { ty; pos = pos_e }) e
in
(* Cli.debug_print (Format.asprintf "Found type of %a: %a"
(Print.format_expr ctx) e (format_typ ctx) out); *)
out
with Errors.StructuredError (msg, err_pos) when List.length err_pos = 2 ->
raise
(Errors.StructuredError
( msg,
( Some "Error coming from typechecking the following expression:",
Marked.get_mark e )
:: err_pos ))
(** Checks whether the expression can be typed with the provided type *)
and typecheck_expr_top_down
(ctx : Ast.decl_ctx)
(env : env)
(e : A.expr Marked.pos)
(tau : typ Marked.pos UnionFind.elem) : unit =
(* Cli.debug_print (Format.asprintf "Typechecking %a : %a" (Print.format_expr
ctx) e (format_typ ctx) tau); *)
try
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
| EVar v -> (
match A.VarMap.find_opt v env with
| Some tau' -> ignore (unify ctx tau tau')
| A.EVar v -> begin
match A.VarMap.find_opt (A.Var.t v) env with
| Some t ->
mark (EVar (translate_var v)) t
| None ->
Errors.raise_spanned_error (Marked.get_mark e)
"Variable not found in the current context")
| ELit (LBool _) ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TBool) e))
| ELit (LInt _) ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TInt) e))
| ELit (LRat _) ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TRat) e))
| ELit (LMoney _) ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TMoney) e))
| ELit (LDate _) ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TDate) e))
| ELit (LDuration _) ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TDuration) e))
| ELit LUnit ->
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TUnit) e))
| ELit LEmptyError ->
unify ctx tau
(UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e))
| ETuple (es, s) ->
let t_es =
UnionFind.make
(Marked.same_mark_as
(TTuple (List.map (typecheck_expr_bottom_up ctx env) es, s))
e)
in
unify ctx tau t_es
| ETupleAccess (e1, n, s, typs) -> (
let typs =
Errors.raise_spanned_error (A.pos e)
"Variable not found in the current context"
end
| A.ELit (LBool _) as e1 -> mark_with_uf e1 (TLit TBool)
| A.ELit (LInt _) as e1 -> mark_with_uf e1 (TLit TInt)
| A.ELit (LRat _) as e1 -> mark_with_uf e1 (TLit TRat)
| A.ELit (LMoney _) as e1 -> mark_with_uf e1 (TLit TMoney)
| A.ELit (LDate _) as e1 -> mark_with_uf e1 (TLit TDate)
| A.ELit (LDuration _) as e1 -> mark_with_uf e1 (TLit TDuration)
| A.ELit LUnit as e1 -> mark_with_uf e1 (TLit TUnit)
| A.ELit LEmptyError as e1 -> mark_with_uf e1 (TAny (Any.fresh ()))
| A.ETuple (es, s) ->
let es = List.map (typecheck_expr_bottom_up ctx env) es in
mark_with_uf (ETuple (es, s)) (TTuple (List.map ty es, s))
| A.ETupleAccess (e1, n, s, typs) -> begin
let utyps =
List.map
(fun typ -> UnionFind.make (Marked.map_under_mark ast_to_typ typ))
typs
in
typecheck_expr_top_down ctx env e1
(UnionFind.make (TTuple (typs, s), Marked.get_mark e));
match List.nth_opt typs n with
| Some t1n -> unify ctx t1n tau
let e1 =
typecheck_expr_top_down ctx env e1 (unionfind_make (TTuple (utyps, s)))
in
match List.nth_opt utyps n with
| Some t' -> mark (ETupleAccess (e1, n, s, typs)) t'
| None ->
Errors.raise_spanned_error (Marked.get_mark e1)
Errors.raise_spanned_error (A.pos e1)
"Expression should have a tuple type with at least %d elements but \
only has %d"
n (List.length typs))
| EInj (e1, n, e_name, ts) ->
let ts =
n (List.length typs)
end
| A.EInj (e1, n, e_name, ts) ->
let ts' =
List.map
(fun t -> UnionFind.make (Marked.map_under_mark ast_to_typ t))
ts
in
let ts_n =
match List.nth_opt ts n with
match List.nth_opt ts' n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error (Marked.get_mark e)
Errors.raise_spanned_error (A.pos e)
"Expression should have a sum type with at least %d cases but only \
has %d"
n (List.length ts)
n (List.length ts')
in
typecheck_expr_top_down ctx env e1 ts_n;
unify ctx
(UnionFind.make (Marked.same_mark_as (TEnum (ts, e_name)) e))
tau
| EMatch (e1, es, e_name) ->
let e1' = typecheck_expr_top_down ctx env e1 ts_n in
mark_with_uf (A.EInj (e1', n, e_name, ts)) (TEnum (ts', e_name))
| A.EMatch (e1, es, e_name) ->
let enum_cases =
List.map
(fun e' ->
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e'))
(fun e' -> unionfind_make ~pos:e' (TAny (Any.fresh ())))
es
in
let t_e1 =
UnionFind.make (Marked.same_mark_as (TEnum (enum_cases, e_name)) e1)
in
typecheck_expr_top_down ctx env e1 t_e1;
let t_e1 = UnionFind.make (add_pos e1 (TEnum (enum_cases, e_name))) in
let e1' = typecheck_expr_top_down ctx env e1 t_e1 in
let t_ret =
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e)
unionfind_make ~pos:e (TAny (Any.fresh ()))
in
List.iteri
(fun i es' ->
let enum_t = List.nth enum_cases i in
let t_es' =
UnionFind.make (Marked.same_mark_as (TArrow (enum_t, t_ret)) es')
in
typecheck_expr_top_down ctx env es' t_es')
es;
unify ctx tau t_ret
| EAbs (binder, t_args) ->
let es' = List.map2 (fun es' enum_t ->
typecheck_expr_top_down ctx env es'
(unionfind_make ~pos:es' (TArrow (enum_t, t_ret))))
es enum_cases
in
mark (EMatch (e1', es', e_name)) t_ret
| A.EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let pos_binder = Marked.get_mark e in
if Array.length xs = List.length t_args then
if Array.length xs <> List.length taus then
Errors.raise_spanned_error (A.pos e)
"function has %d variables but was supplied %d types"
(Array.length xs) (List.length taus)
else
let xs' = Array.map translate_var xs in
let xstaus =
List.map2
(fun x t_arg ->
x, UnionFind.make (Marked.map_under_mark ast_to_typ t_arg))
(Array.to_list xs) t_args
(fun x tau ->
x,
UnionFind.make
(Marked.map_under_mark ast_to_typ tau))
(Array.to_list xs) taus
in
let env =
List.fold_left
(fun env (x, t_arg) -> A.VarMap.add x t_arg env)
env xstaus
List.fold_left (fun env (x, tau) -> A.VarMap.add (A.Var.t x) tau env) env xstaus
in
let t_out = typecheck_expr_bottom_up ctx env body in
let body' = typecheck_expr_bottom_up ctx env body in
let t_func =
List.fold_right
(fun (_, t_arg) acc ->
UnionFind.make (Marked.same_mark_as (TArrow (t_arg, acc)) e))
xstaus t_out
unionfind_make (TArrow (t_arg, acc)))
xstaus
(ty body')
in
unify ctx t_func tau
else
Errors.raise_spanned_error pos_binder
"function has %d variables but was supplied %d types"
(Array.length xs) (List.length t_args)
| EApp (e1, args) ->
let t_args = List.map (typecheck_expr_bottom_up ctx env) args in
let te1 = typecheck_expr_bottom_up ctx env e1 in
(* TODO: check this use of binders *)
let binder' = Bindlib.unbox (Bindlib.bind_mvar xs' (Bindlib.box body')) in
mark (EAbs (binder', taus)) t_func
| A.EApp (e1, args) ->
let args' = List.map (typecheck_expr_bottom_up ctx env) args in
let t_ret = unionfind_make (TAny (Any.fresh ())) in
let t_func =
List.fold_right
(fun t_arg acc ->
UnionFind.make (Marked.same_mark_as (TArrow (t_arg, acc)) e))
t_args tau
(fun arg acc -> unionfind_make (TArrow (ty arg, acc)))
args' t_ret
in
unify ctx te1 t_func
| EOp op ->
let op_typ = op_type (Marked.same_mark_as op e) in
unify ctx op_typ tau
| EDefault (excepts, just, cons) ->
typecheck_expr_top_down ctx env just
(UnionFind.make (Marked.same_mark_as (TLit TBool) just));
typecheck_expr_top_down ctx env cons tau;
List.iter
(fun except -> typecheck_expr_top_down ctx env except tau)
let e1' = typecheck_expr_top_down ctx env e1 t_func in
mark (EApp (e1', args')) t_ret
| A.EOp op as e1 -> mark e1 (op_type (Marked.mark pos_e op))
| A.EDefault (excepts, just, cons) ->
let just' = typecheck_expr_top_down ctx env just
(unionfind_make ~pos:just (TLit TBool)) in
let cons' = typecheck_expr_bottom_up ctx env cons in
let tau = ty cons' in
let excepts' =
List.map
(fun except -> typecheck_expr_top_down ctx env except tau)
excepts
| EIfThenElse (cond, et, ef) ->
typecheck_expr_top_down ctx env cond
(UnionFind.make (Marked.same_mark_as (TLit TBool) cond));
typecheck_expr_top_down ctx env et tau;
typecheck_expr_top_down ctx env ef tau
| EAssert e' ->
typecheck_expr_top_down ctx env e'
(UnionFind.make (Marked.same_mark_as (TLit TBool) e'));
unify ctx tau (UnionFind.make (Marked.same_mark_as (TLit TUnit) e'))
| ErrorOnEmpty e' -> typecheck_expr_top_down ctx env e' tau
| EArray es ->
let cell_type =
UnionFind.make (Marked.same_mark_as (TAny (Any.fresh ())) e)
in
List.iter
(fun e' ->
let t_e' = typecheck_expr_bottom_up ctx env e' in
unify ctx cell_type t_e')
es;
unify ctx tau (UnionFind.make (Marked.same_mark_as (TArray cell_type) e))
mark (A.EDefault (excepts', just', cons')) tau
| A.EIfThenElse (cond, et, ef) ->
let cond' = typecheck_expr_top_down ctx env cond
(unionfind_make ~pos:cond (TLit TBool)) in
let et' = typecheck_expr_bottom_up ctx env et in
let tau = ty et' in
let ef' = typecheck_expr_top_down ctx env ef tau in
mark (A.EIfThenElse (cond', et', ef')) tau
| A.EAssert e1 ->
let e1' =
typecheck_expr_top_down ctx env e1
(unionfind_make ~pos:e1 (TLit TBool)) in
mark_with_uf (A.EAssert e1') ~pos:e1 (TLit TUnit)
| A.ErrorOnEmpty e1 ->
let e1' = typecheck_expr_bottom_up ctx env e1 in
mark (A.ErrorOnEmpty e1') (ty e1')
| A.EArray es ->
let cell_type = unionfind_make (TAny (Any.fresh ())) in
let es' =
List.map
(fun e1 ->
let e1' = typecheck_expr_bottom_up ctx env e1 in
unify ctx cell_type (ty e1');
e1')
es
in
mark_with_uf (A.EArray es') (TArray cell_type)
with Errors.StructuredError (msg, err_pos) when List.length err_pos = 2 ->
raise
(Errors.StructuredError
( msg,
( Some "Error coming from typechecking the following expression:",
Marked.get_mark e )
A.pos e )
:: err_pos ))
(** Checks whether the expression can be typed with the provided type *)
and typecheck_expr_top_down
: 'm .
Ast.decl_ctx ->
env ->
'm A.marked_expr -> typ Marked.pos UnionFind.elem -> A.typed_expr = fun (ctx : Ast.decl_ctx)
(env : env)
(e : 'm A.marked_expr)
(tau : typ Marked.pos UnionFind.elem) :
A.typed_expr ->
(* Cli.debug_print (Format.asprintf "Typechecking %a : %a" (Print.format_expr
ctx) e (format_typ ctx) tau); *)
try
let pos_e = A.pos e in
let mark e =
Marked.mark (A.Typed { ty = tau; pos = pos_e }) e
in
let unify_and_mark (e : A.typed A.expr) tau' =
unify ctx tau tau';
Marked.mark (A.Typed { ty = tau'; pos = pos_e }) e
in
let unionfind_make ?(pos=e) t = UnionFind.make (add_pos pos t) in
let unionfind_of_typ typ =
UnionFind.make (Marked.map_under_mark ast_to_typ typ)
in
match Marked.unmark e with
| A.EVar v -> begin
match A.VarMap.find_opt (A.Var.t v) env with
| Some tau' -> unify_and_mark (A.EVar (translate_var v)) tau'
| None ->
Errors.raise_spanned_error (A.pos e)
"Variable not found in the current context"
end
| A.ELit (LBool _) as e1 -> unify_and_mark e1 (unionfind_make (TLit TBool))
| A.ELit (LInt _) as e1 -> unify_and_mark e1 (unionfind_make (TLit TInt))
| A.ELit (LRat _) as e1 -> unify_and_mark e1 (unionfind_make (TLit TRat))
| A.ELit (LMoney _) as e1 ->
unify_and_mark e1 (unionfind_make (TLit TMoney))
| A.ELit (LDate _) as e1 -> unify_and_mark e1 (unionfind_make (TLit TDate))
| A.ELit (LDuration _) as e1 ->
unify_and_mark e1 (unionfind_make (TLit TDuration))
| A.ELit LUnit as e1 -> unify_and_mark e1 (unionfind_make (TLit TUnit))
| A.ELit LEmptyError as e1 ->
unify_and_mark e1 (unionfind_make (TAny (Any.fresh ())))
| A.ETuple (es, s) ->
let es' = List.map (typecheck_expr_bottom_up ctx env) es in
unify_and_mark (A.ETuple (es', s))
(unionfind_make (TTuple (List.map ty es', s)))
| A.ETupleAccess (e1, n, s, typs) -> begin
let typs' = List.map unionfind_of_typ typs in
let e1' =
typecheck_expr_top_down ctx env e1
(unionfind_make (TTuple (typs', s)))
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)
"Expression should have a tuple type with at least %d elements but \
only has %d"
n (List.length typs)
end
| A.EInj (e1, n, e_name, ts) ->
let ts' =
List.map unionfind_of_typ ts
in
let ts_n =
match List.nth_opt ts' n with
| Some ts_n -> ts_n
| None ->
Errors.raise_spanned_error (A.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 e1 ts_n in
unify_and_mark (A.EInj (e1', n, e_name, ts))
(unionfind_make (TEnum (ts', 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 e1
(unionfind_make ~pos:e1 (TEnum (enum_cases, e_name)))
in
let t_ret = unionfind_make ~pos:e (TAny (Any.fresh ())) in
let es' =
List.map2 (fun es' enum_t ->
typecheck_expr_top_down ctx env es'
(unionfind_make ~pos:es' (TArrow (enum_t, t_ret))))
es enum_cases
in
unify_and_mark (EMatch (e1', es', e_name)) t_ret
| A.EAbs (binder, t_args) ->
(* Bindlib.box binder |> Bindlib.mbind_apply *)
let xs, body = Bindlib.unmbind binder in
if Array.length xs <> List.length t_args then
Errors.raise_spanned_error (A.pos e)
"function has %d variables but was supplied %d types"
(Array.length xs) (List.length t_args)
else
let xs' = Array.map translate_var xs in
let xstaus =
List.map2
(fun x t_arg ->
x, UnionFind.make (Marked.map_under_mark ast_to_typ t_arg))
(Array.to_list xs) t_args
in
let env =
List.fold_left
(fun env (x, t_arg) -> A.VarMap.add (A.Var.t x) t_arg env)
env xstaus
in
let body' = typecheck_expr_bottom_up ctx env body in
let t_func =
List.fold_right
(fun (_, t_arg) acc ->
unionfind_make (TArrow (t_arg, acc)))
xstaus (ty body')
in
(* TODO: check this use of binders *)
let binder' = Bindlib.unbox (Bindlib.bind_mvar xs' (Bindlib.box body')) in
unify_and_mark (EAbs (binder', t_args)) t_func
| A.EApp (e1, args) ->
let args' = List.map (typecheck_expr_bottom_up ctx env) args in
let e1' = typecheck_expr_bottom_up ctx env e1 in
let t_func =
List.fold_right
(fun arg acc -> unionfind_make (TArrow (ty arg, acc)))
args' tau
in
unify_and_mark (EApp (e1', args')) t_func
| A.EOp op as e1 ->
let op_typ = op_type (add_pos e op) in
unify_and_mark e1 op_typ
| A.EDefault (excepts, just, cons) ->
let just' = typecheck_expr_top_down ctx env just (unionfind_make ~pos:just (TLit TBool)) in
let cons' = typecheck_expr_top_down ctx env cons tau in
let excepts' =
List.map (fun except -> typecheck_expr_top_down ctx env except tau)
excepts
in
mark (A.EDefault (excepts', just', cons'))
| A.EIfThenElse (cond, et, ef) ->
let cond' = typecheck_expr_top_down ctx env cond
(unionfind_make ~pos:cond (TLit TBool)) in
let et' = typecheck_expr_top_down ctx env et tau in
let ef' = typecheck_expr_top_down ctx env ef tau in
mark (A.EIfThenElse (cond', et', ef'))
| A.EAssert e1 ->
let e1' = typecheck_expr_top_down ctx env e1
(unionfind_make ~pos:e1 (TLit TBool)) in
unify_and_mark (EAssert e1') (unionfind_make ~pos:e1 (TLit TUnit))
| A.ErrorOnEmpty e1 ->
let e1' = typecheck_expr_top_down ctx env e1 tau in
mark (A.ErrorOnEmpty e1')
| A.EArray es ->
let cell_type = unionfind_make (TAny (Any.fresh ())) in
let es' =
List.map
(fun e1 ->
let e1' = typecheck_expr_bottom_up ctx env e1 in
unify ctx cell_type (ty e1');
e1')
es
in
unify_and_mark (A.EArray es') (unionfind_make (TArray cell_type))
with Errors.StructuredError (msg, err_pos) when List.length err_pos = 2 ->
raise
(Errors.StructuredError
( msg,
( Some "Error coming from typechecking the following expression:",
A.pos e )
:: err_pos ))
(** {1 API} *)
(* Infer the type of an expression *)
let infer_type (ctx : Ast.decl_ctx) (e : A.expr Marked.pos) : A.typ Marked.pos =
let ty = typecheck_expr_bottom_up ctx A.VarMap.empty e in
typ_to_ast ty
let infer_types (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : Ast.typed Ast.marked_expr
=
typecheck_expr_bottom_up ctx A.VarMap.empty e
let infer_type (type m) ctx (e: m A.marked_expr) =
match Marked.get_mark e with
| A.Typed {ty; _} -> typ_to_ast ty
| A.Untyped _ -> typ_to_ast (ty (infer_types ctx e))
(** Typechecks an expression given an expected type *)
let check_type
(ctx : Ast.decl_ctx)
(e : A.expr Marked.pos)
(e : 'm A.marked_expr)
(tau : A.typ Marked.pos) =
(* todo: consider using the already inferred type if ['m] = [typed] *)
ignore @@
typecheck_expr_top_down ctx A.VarMap.empty e
(UnionFind.make (Marked.map_under_mark ast_to_typ tau))
let infer_types_program prg =
let scopes =
Bindlib.unbox @@
A.map_exprs_in_scopes
~f:(fun e -> Bindlib.box (typecheck_expr_bottom_up prg.A.decl_ctx A.VarMap.empty e))
~varf:translate_var
prg.A.scopes
in
{A.
decl_ctx = prg.A.decl_ctx;
scopes;
}

14
compiler/dcalc/typing.mli
View File

@ -17,8 +17,16 @@
(** 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_type :
Ast.decl_ctx -> Ast.expr Utils.Marked.pos -> Ast.typ Utils.Marked.pos
val infer_types :
Ast.decl_ctx -> Ast.untyped Ast.marked_expr -> Ast.typed Ast.marked_expr
(** 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
(** Gets the outer type of the given expression, using either the existing
annotations or inference *)
val check_type :
Ast.decl_ctx -> Ast.expr Utils.Marked.pos -> Ast.typ Utils.Marked.pos -> unit
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

11
compiler/driver.ml
View File

@ -196,9 +196,6 @@ let driver source_file (options : Cli.options) : int =
end
else prgm
in
let prgrm_dcalc_expr =
Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid)
in
match backend with
| `Dcalc ->
let _output_file, with_output = get_output_format () in
@ -218,13 +215,16 @@ let driver source_file (options : Cli.options) : int =
else acc)
prgm.scopes) )
else
let prgrm_dcalc_expr =
Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid)
in
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
prgrm_dcalc_expr
| ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc
| `Proof | `Plugin _ ) as backend -> (
Cli.debug_print "Typechecking...";
let _typ = Dcalc.Typing.infer_type prgm.decl_ctx prgrm_dcalc_expr in
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); *)
match backend with
@ -242,6 +242,9 @@ let driver source_file (options : Cli.options) : int =
Verification.Solver.solve_vc prgm.decl_ctx vcs
| `Interpret ->
Cli.debug_print "Starting interpretation...";
let prgrm_dcalc_expr =
Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid)
in
let results =
Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr
in

2
compiler/lcalc/ast.mli
View File

@ -61,7 +61,7 @@ and expr =
| ERaise of except
| ECatch of marked_expr * except * marked_expr
type program = { decl_ctx : Dcalc.Ast.decl_ctx; scopes : expr Dcalc.Ast.scopes }
type program = { decl_ctx : Dcalc.Ast.decl_ctx; scopes : (expr, Dcalc.Ast.untyped) Dcalc.Ast.scopes }
(** {1 Variable helpers} *)

2
compiler/lcalc/compile_with_exceptions.mli
View File

@ -17,4 +17,4 @@
(** Translation from the default calculus to the lambda calculus. This
translation uses exceptions handle empty default terms. *)
val translate_program : Dcalc.Ast.program -> Ast.program
val translate_program : Dcalc.Ast.typed Dcalc.Ast.program -> Ast.program

2
compiler/lcalc/compile_without_exceptions.mli
View File

@ -19,4 +19,4 @@
transformation is one piece to permit to compile toward legacy languages
that does not contains exceptions. *)
val translate_program : Dcalc.Ast.program -> Ast.program
val translate_program : Dcalc.Ast.typed Dcalc.Ast.program -> Ast.program

12
compiler/scopelang/print.ml
View File

@ -66,7 +66,7 @@ let rec format_expr
| 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 (Marked.same_mark_as l e)
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 "{"
@ -126,11 +126,11 @@ let rec format_expr
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, Pos.no_pos) format_with_parens arg2
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, Pos.no_pos)
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
@ -143,11 +143,11 @@ let rec format_expr
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, Pos.no_pos)
Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos)
Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos)
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 "⟨"

129
compiler/scopelang/scope_to_dcalc.ml
View File

@ -24,8 +24,8 @@ type scope_var_ctx = {
type scope_sig_ctx = {
scope_sig_local_vars : scope_var_ctx list; (** List of scope variables *)
scope_sig_scope_var : Dcalc.Ast.Var.t; (** Var representing the scope *)
scope_sig_input_var : Dcalc.Ast.Var.t;
scope_sig_scope_var : Dcalc.Ast.untyped Dcalc.Ast.var; (** Var representing the scope *)
scope_sig_input_var : Dcalc.Ast.untyped Dcalc.Ast.var;
(** Var representing the scope input inside the scope func *)
scope_sig_input_struct : Ast.StructName.t; (** Scope input *)
scope_sig_output_struct : Ast.StructName.t; (** Scope output *)
@ -38,11 +38,11 @@ type ctx = {
enums : Ast.enum_ctx;
scope_name : Ast.ScopeName.t;
scopes_parameters : scope_sigs_ctx;
scope_vars : (Dcalc.Ast.Var.t * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t;
scope_vars : (Dcalc.Ast.untyped Dcalc.Ast.var * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t;
subscope_vars :
(Dcalc.Ast.Var.t * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t
(Dcalc.Ast.untyped Dcalc.Ast.var * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t
Ast.SubScopeMap.t;
local_vars : Dcalc.Ast.Var.t Ast.VarMap.t;
local_vars : Dcalc.Ast.untyped Dcalc.Ast.var Ast.VarMap.t;
}
let empty_ctx
@ -80,39 +80,46 @@ let rec translate_typ (ctx : ctx) (t : Ast.typ Marked.pos) :
| Ast.TAny -> Dcalc.Ast.TAny)
t
let pos_mark (pos: Pos.t) : Dcalc.Ast.untyped Dcalc.Ast.mark =
Dcalc.Ast.Untyped {pos}
let pos_mark_as e = pos_mark (Marked.get_mark e)
let merge_defaults
(caller : Dcalc.Ast.expr Marked.pos Bindlib.box)
(callee : Dcalc.Ast.expr Marked.pos Bindlib.box) :
Dcalc.Ast.expr Marked.pos Bindlib.box =
(caller : Dcalc.Ast.untyped Dcalc.Ast.marked_expr Bindlib.box)
(callee : Dcalc.Ast.untyped Dcalc.Ast.marked_expr Bindlib.box) :
Dcalc.Ast.untyped Dcalc.Ast.marked_expr Bindlib.box =
let caller =
Dcalc.Ast.make_app caller
[Bindlib.box (Dcalc.Ast.ELit Dcalc.Ast.LUnit, Pos.no_pos)]
Pos.no_pos
[Bindlib.box (Dcalc.Ast.ELit Dcalc.Ast.LUnit, (pos_mark Pos.no_pos))]
(pos_mark Pos.no_pos)
in
let body =
Bindlib.box_apply2
(fun caller callee ->
( Dcalc.Ast.EDefault
( [caller],
(Dcalc.Ast.ELit (Dcalc.Ast.LBool true), Pos.no_pos),
(Dcalc.Ast.ELit (Dcalc.Ast.LBool true), (pos_mark Pos.no_pos)),
callee ),
Pos.no_pos ))
(pos_mark Pos.no_pos) ))
caller callee
in
body
let tag_with_log_entry
(e : Dcalc.Ast.expr Marked.pos Bindlib.box)
(e : Dcalc.Ast.untyped Dcalc.Ast.marked_expr Bindlib.box)
(l : Dcalc.Ast.log_entry)
(markings : Utils.Uid.MarkedString.info list) :
Dcalc.Ast.expr Marked.pos Bindlib.box =
Dcalc.Ast.untyped Dcalc.Ast.marked_expr Bindlib.box =
Bindlib.box_apply
(fun e ->
( Dcalc.Ast.EApp
( ( Dcalc.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))),
Marked.get_mark e ),
[e] ),
Marked.get_mark e ))
Marked.same_mark_as
(Dcalc.Ast.EApp
((Marked.same_mark_as
(Dcalc.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))))
e),
[e]))
e)
e
(* In a list of exceptions, it is normally an error if more than a single one
@ -155,10 +162,10 @@ let collapse_similar_outcomes (excepts : Ast.expr Marked.pos list) :
excepts
let rec translate_expr (ctx : ctx) (e : Ast.expr Marked.pos) :
Dcalc.Ast.expr Marked.pos Bindlib.box =
Dcalc.Ast.untyped Dcalc.Ast.marked_expr Bindlib.box =
Bindlib.box_apply
(fun (x : Dcalc.Ast.expr) -> Marked.same_mark_as x e)
(match Marked.unmark e with
(fun (x : Dcalc.Ast.untyped Dcalc.Ast.expr) -> Marked.mark (pos_mark_as e) x)
@@ match Marked.unmark e with
| EVar v -> Bindlib.box_var (Ast.VarMap.find v ctx.local_vars)
| ELit l -> Bindlib.box (Dcalc.Ast.ELit l)
| EStruct (struct_name, e_fields) ->
@ -308,7 +315,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Marked.pos) :
in
let new_e =
Bindlib.box_apply2
(fun e' u -> Dcalc.Ast.EApp (e', u), Marked.get_mark e)
(fun e' u -> Dcalc.Ast.EApp (e', u), pos_mark_as e)
e1_func
(Bindlib.box_list new_args)
in
@ -325,7 +332,7 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Marked.pos) :
| EAbs (binder, typ) ->
let xs, body = Bindlib.unmbind binder in
let new_xs =
Array.map (fun x -> Dcalc.Ast.Var.make (Bindlib.name_of x)) xs
Array.map (fun x -> Dcalc.Ast.new_var (Bindlib.name_of x)) xs
in
let both_xs = Array.map2 (fun x new_x -> x, new_x) xs new_xs in
let body =
@ -385,7 +392,8 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Marked.pos) :
| EArray es ->
Bindlib.box_apply
(fun es -> Dcalc.Ast.EArray es)
(Bindlib.box_list (List.map (translate_expr ctx) es)))
(Bindlib.box_list (List.map (translate_expr ctx) es))
(** The result of a rule translation is a list of assignment, with variables and
expressions. We also return the new translation context available after the
@ -396,20 +404,20 @@ let translate_rule
(ctx : ctx)
(rule : Ast.rule)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) :
(Dcalc.Ast.expr Dcalc.Ast.scope_body_expr Bindlib.box ->
Dcalc.Ast.expr Dcalc.Ast.scope_body_expr Bindlib.box)
((Dcalc.Ast.untyped Dcalc.Ast.expr, Dcalc.Ast.untyped) Dcalc.Ast.scope_body_expr Bindlib.box ->
(Dcalc.Ast.untyped Dcalc.Ast.expr, Dcalc.Ast.untyped) Dcalc.Ast.scope_body_expr Bindlib.box)
* ctx =
match rule with
| Definition ((ScopeVar a, var_def_pos), tau, a_io, e) ->
let a_name = Ast.ScopeVar.get_info (Marked.unmark a) in
let a_var = Dcalc.Ast.Var.make (Marked.unmark a_name) in
let a_var = Dcalc.Ast.new_var (Marked.unmark a_name) in
let tau = translate_typ ctx tau in
let new_e = translate_expr ctx e in
let a_expr = Dcalc.Ast.make_var (a_var, var_def_pos) in
let a_expr = Dcalc.Ast.make_var (a_var, pos_mark var_def_pos) in
let merged_expr =
Bindlib.box_apply
(fun merged_expr ->
Dcalc.Ast.ErrorOnEmpty merged_expr, Marked.get_mark a_name)
Dcalc.Ast.ErrorOnEmpty merged_expr, pos_mark_as a_name)
(match Marked.unmark a_io.io_input with
| OnlyInput ->
failwith "should not happen"
@ -455,27 +463,27 @@ let translate_rule
^ Marked.unmark (Ast.ScopeVar.get_info (Marked.unmark subs_var)))
(Ast.SubScopeName.get_info (Marked.unmark subs_index))
in
let a_var = Dcalc.Ast.Var.make (Marked.unmark a_name) in
let a_var = Dcalc.Ast.new_var (Marked.unmark a_name) in
let tau = translate_typ ctx tau in
let new_e =
tag_with_log_entry (translate_expr ctx e)
(Dcalc.Ast.VarDef (Marked.unmark tau))
[sigma_name, pos_sigma; a_name]
in
let silent_var = Dcalc.Ast.Var.make "_" in
let silent_var = Dcalc.Ast.new_var "_" in
let thunked_or_nonempty_new_e =
match Marked.unmark a_io.io_input with
| NoInput -> failwith "should not happen"
| OnlyInput ->
Bindlib.box_apply
(fun new_e -> Dcalc.Ast.ErrorOnEmpty new_e, Marked.get_mark subs_var)
(fun new_e -> Dcalc.Ast.ErrorOnEmpty new_e, pos_mark_as subs_var)
new_e
| Reentrant ->
Dcalc.Ast.make_abs
(Array.of_list [silent_var])
new_e
[Dcalc.Ast.TLit TUnit, var_def_pos]
var_def_pos
(pos_mark var_def_pos)
in
( (fun next ->
Bindlib.box_apply2
@ -544,7 +552,7 @@ let translate_rule
List.map
(fun (subvar : scope_var_ctx) ->
if subscope_var_not_yet_defined subvar.scope_var_name then
(* This is a redundant check. Normally, all subscope varaibles
(* This is a redundant check. Normally, all subscope variables
should have been defined (even an empty definition, if they're
not defined by any rule in the source code) by the translation
from desugared to the scope language. *)
@ -553,21 +561,21 @@ let translate_rule
let a_var, _, _ =
Ast.ScopeVarMap.find subvar.scope_var_name subscope_vars_defined
in
Dcalc.Ast.make_var (a_var, pos_call))
Dcalc.Ast.make_var (a_var, pos_mark pos_call))
all_subscope_input_vars
in
let subscope_struct_arg =
Bindlib.box_apply
(fun subscope_args ->
( Dcalc.Ast.ETuple (subscope_args, Some called_scope_input_struct),
pos_call ))
pos_mark pos_call ))
(Bindlib.box_list subscope_args)
in
let all_subscope_output_vars_dcalc =
List.map
(fun (subvar : scope_var_ctx) ->
let sub_dcalc_var =
Dcalc.Ast.Var.make
Dcalc.Ast.new_var
(Marked.unmark (Ast.SubScopeName.get_info subindex)
^ "."
^ Marked.unmark (Ast.ScopeVar.get_info subvar.scope_var_name))
@ -579,7 +587,7 @@ let translate_rule
tag_with_log_entry
(Dcalc.Ast.make_var
( scope_dcalc_var,
Marked.get_mark (Ast.SubScopeName.get_info subindex) ))
pos_mark_as (Ast.SubScopeName.get_info subindex) ))
Dcalc.Ast.BeginCall
[
sigma_name, pos_sigma;
@ -590,7 +598,7 @@ let translate_rule
let call_expr =
tag_with_log_entry
(Bindlib.box_apply2
(fun e u -> Dcalc.Ast.EApp (e, [u]), Pos.no_pos)
(fun e u -> Dcalc.Ast.EApp (e, [u]), (pos_mark Pos.no_pos))
subscope_func subscope_struct_arg)
Dcalc.Ast.EndCall
[
@ -599,7 +607,7 @@ let translate_rule
Ast.ScopeName.get_info subname;
]
in
let result_tuple_var = Dcalc.Ast.Var.make "result" in
let result_tuple_var = Dcalc.Ast.new_var "result" in
let result_tuple_typ =
( Dcalc.Ast.TTuple
( List.map
@ -608,8 +616,7 @@ let translate_rule
Some called_scope_return_struct ),
pos_sigma )
in
let call_scope_let
(next : Dcalc.Ast.expr Dcalc.Ast.scope_body_expr Bindlib.box) =
let call_scope_let next =
Bindlib.box_apply2
(fun next call_expr ->
Dcalc.Ast.ScopeLet
@ -623,8 +630,7 @@ let translate_rule
(Bindlib.bind_var result_tuple_var next)
call_expr
in
let result_bindings_lets
(next : Dcalc.Ast.expr Dcalc.Ast.scope_body_expr Bindlib.box) =
let result_bindings_lets next =
List.fold_right
(fun (var_ctx, v) (next, i) ->
( Bindlib.box_apply2
@ -645,10 +651,10 @@ let translate_rule
(fun (var_ctx, _) ->
var_ctx.scope_var_typ, pos_sigma)
all_subscope_output_vars_dcalc ),
pos_sigma );
pos_mark pos_sigma );
})
(Bindlib.bind_var v next)
(Dcalc.Ast.make_var (result_tuple_var, pos_sigma)),
(Dcalc.Ast.make_var (result_tuple_var, pos_mark pos_sigma)),
i - 1 ))
all_subscope_output_vars_dcalc
(next, List.length all_subscope_output_vars_dcalc - 1)
@ -682,11 +688,11 @@ let translate_rule
defined, we add an check "ErrorOnEmpty" here. *)
Marked.same_mark_as
(Dcalc.Ast.EAssert
(Dcalc.Ast.ErrorOnEmpty new_e, Marked.get_mark e))
(Dcalc.Ast.ErrorOnEmpty new_e, pos_mark_as e))
new_e;
Dcalc.Ast.scope_let_kind = Dcalc.Ast.Assertion;
})
(Bindlib.bind_var (Dcalc.Ast.Var.make "_") next)
(Bindlib.bind_var (Dcalc.Ast.new_var "_") next)
new_e),
ctx )
@ -695,7 +701,7 @@ let translate_rules
(rules : Ast.rule list)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info)
(sigma_return_struct_name : Ast.StructName.t) :
Dcalc.Ast.expr Dcalc.Ast.scope_body_expr Bindlib.box * ctx =
(Dcalc.Ast.untyped Dcalc.Ast.expr, Dcalc.Ast.untyped) Dcalc.Ast.scope_body_expr Bindlib.box * ctx =
let scope_lets, new_ctx =
List.fold_left
(fun (scope_lets, ctx) rule ->
@ -715,11 +721,11 @@ let translate_rules
let return_exp =
Bindlib.box_apply
(fun args ->
Dcalc.Ast.ETuple (args, Some sigma_return_struct_name), pos_sigma)
Dcalc.Ast.ETuple (args, Some sigma_return_struct_name), pos_mark pos_sigma)
(Bindlib.box_list
(List.map
(fun (_, (dcalc_var, _, _)) ->
Dcalc.Ast.make_var (dcalc_var, pos_sigma))
Dcalc.Ast.make_var (dcalc_var, pos_mark pos_sigma))
scope_output_variables))
in
( scope_lets
@ -734,7 +740,7 @@ let translate_scope_decl
(sctx : scope_sigs_ctx)
(scope_name : Ast.ScopeName.t)
(sigma : Ast.scope_decl) :
Dcalc.Ast.expr Dcalc.Ast.scope_body Bindlib.box * Dcalc.Ast.struct_ctx =
(Dcalc.Ast.untyped Dcalc.Ast.expr, Dcalc.Ast.untyped) Dcalc.Ast.scope_body Bindlib.box * Dcalc.Ast.struct_ctx =
let sigma_info = Ast.ScopeName.get_info sigma.scope_decl_name in
let scope_sig = Ast.ScopeMap.find sigma.scope_decl_name sctx in
let scope_variables = scope_sig.scope_sig_local_vars in
@ -747,7 +753,7 @@ let translate_scope_decl
| OnlyInput ->
let scope_var_name = Ast.ScopeVar.get_info scope_var.scope_var_name in
let scope_var_dcalc =
Dcalc.Ast.Var.make (Marked.unmark scope_var_name)
Dcalc.Ast.new_var (Marked.unmark scope_var_name)
in
{
ctx with
@ -802,8 +808,7 @@ let translate_scope_decl
pos_sigma )
| NoInput -> failwith "should not happen"
in
let input_destructurings
(next : Dcalc.Ast.expr Dcalc.Ast.scope_body_expr Bindlib.box) =
let input_destructurings next =
fst
(List.fold_right
(fun (var_ctx, v) (next, i) ->
@ -824,10 +829,10 @@ let translate_scope_decl
List.map
(fun (var_ctx, _) -> input_var_typ var_ctx)
scope_input_variables ),
pos_sigma );
pos_mark pos_sigma );
})
(Bindlib.bind_var v next)
(Dcalc.Ast.make_var (scope_input_var, pos_sigma)),
(Dcalc.Ast.make_var (scope_input_var, pos_mark pos_sigma)),
i - 1 ))
scope_input_variables
(next, List.length scope_input_variables - 1))
@ -867,7 +872,7 @@ let translate_scope_decl
new_struct_ctx )
let translate_program (prgm : Ast.program) :
Dcalc.Ast.program * Dependency.TVertex.t list =
Dcalc.Ast.untyped Dcalc.Ast.program * Dependency.TVertex.t list =
let scope_dependencies = Dependency.build_program_dep_graph prgm in
Dependency.check_for_cycle_in_scope scope_dependencies;
let types_ordering =
@ -898,7 +903,7 @@ let translate_program (prgm : Ast.program) :
Ast.ScopeMap.mapi
(fun scope_name scope ->
let scope_dvar =
Dcalc.Ast.Var.make
Dcalc.Ast.new_var
(Marked.unmark (Ast.ScopeName.get_info scope.Ast.scope_decl_name))
in
let scope_return_struct_name =
@ -908,7 +913,7 @@ let translate_program (prgm : Ast.program) :
(Ast.ScopeName.get_info scope_name))
in
let scope_input_var =
Dcalc.Ast.Var.make
Dcalc.Ast.new_var
(Marked.unmark (Ast.ScopeName.get_info scope_name) ^ "_in")
in
let scope_input_struct_name =
@ -939,7 +944,7 @@ let translate_program (prgm : Ast.program) :
in
(* the resulting expression is the list of definitions of all the scopes,
ending with the top-level scope. *)
let (scopes, decl_ctx) : Dcalc.Ast.expr Dcalc.Ast.scopes Bindlib.box * _ =
let (scopes, decl_ctx) : (Dcalc.Ast.untyped Dcalc.Ast.expr, Dcalc.Ast.untyped) Dcalc.Ast.scopes Bindlib.box * _ =
List.fold_right
(fun scope_name (scopes, decl_ctx) ->
let scope = Ast.ScopeMap.find scope_name prgm.program_scopes in

2
compiler/scopelang/scope_to_dcalc.mli
View File

@ -17,7 +17,7 @@
(** Scope language to default calculus translator *)
val translate_program :
Ast.program -> Dcalc.Ast.program * Dependency.TVertex.t list
Ast.program -> Dcalc.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

5
compiler/utils/marked.mli
View File

@ -18,10 +18,11 @@
(** AST node annotations (used for position, type, etc.) *)
type ('a, 'm) t = 'a * 'm
(** Everything related to the source code should keep its position stored, to
improve error messages *)
(** Everything related to the source code should keep at least its position
stored, to improve error messages *)
type 'a pos = ('a, Pos.t) t
(** The type of marks containing only position information *)
val mark : 'm -> 'a -> ('a, 'm) t
val unmark : ('a, 'm) t -> 'a

4
compiler/verification/conditions.mli
View File

@ -26,7 +26,7 @@ type verification_condition_kind =
a conflict error *)
type verification_condition = {
vc_guard : Dcalc.Ast.expr Utils.Marked.pos;
vc_guard : Dcalc.Ast.typed_expr;
(** This expression should have type [bool]*)
vc_kind : verification_condition_kind;
vc_scope : Dcalc.Ast.ScopeName.t;
@ -38,7 +38,7 @@ type verification_condition = {
}
val generate_verification_conditions :
Dcalc.Ast.program ->
'm Dcalc.Ast.program ->
Dcalc.Ast.ScopeName.t option ->
verification_condition list
(** [generate_verification_conditions p None] will generate the verification

8
compiler/verification/io.mli
View File

@ -39,9 +39,7 @@ module type Backend = sig
val is_model_empty : model -> bool
val translate_expr :
backend_context ->
Dcalc.Ast.expr Utils.Marked.pos ->
backend_context * vc_encoding
backend_context -> Dcalc.Ast.typed_expr -> backend_context * vc_encoding
end
module type BackendIO = sig
@ -57,9 +55,7 @@ module type BackendIO = sig
type vc_encoding
val translate_expr :
backend_context ->
Dcalc.Ast.expr Utils.Marked.pos ->
backend_context * vc_encoding
backend_context -> Dcalc.Ast.typed_expr -> backend_context * vc_encoding
type model

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

@ -603,7 +603,7 @@ and translate_expr (ctx : context) (vc : expr Marked.pos) : context * Expr.expr
match Marked.unmark e with
| EAbs (e, _) ->
(* Create a fresh Catala variable to substitue and obtain the body *)
let fresh_v = Var.make "arm!tmp" in
let fresh_v = new_var "arm!tmp" in
let fresh_e = EVar fresh_v in
(* Invariant: Catala enums always have exactly one argument *)