Commit f89ff3cd authored by Andrei Paskevich's avatar Andrei Paskevich

mlw_typing: parse type declarations

parent bd6d67ef
......@@ -26,7 +26,7 @@ open Decl
open Mlw_ty
open Mlw_expr
type ps_ls = { ps: psymbol; ls: lsymbol }
type ps_ls = { ps : psymbol; ls : lsymbol }
type pconstructor = ps_ls * ps_ls option list
......
......@@ -26,7 +26,7 @@ open Mlw_expr
(** {2 Type declaration} *)
type ps_ls = private { ps: psymbol; ls: lsymbol }
type ps_ls = private { ps : psymbol; ls : lsymbol }
type pconstructor = ps_ls * ps_ls option list
......@@ -66,4 +66,4 @@ type known_map = pdecl Mid.t
val known_id : known_map -> ident -> unit
val known_add_decl : Decl.known_map -> known_map -> pdecl -> known_map
val merge_known: known_map -> known_map -> known_map
val merge_known : known_map -> known_map -> known_map
......@@ -26,10 +26,12 @@ open Term
(** value types (w/o effects) *)
type itysymbol = {
its_pure : tysymbol;
its_args : tvsymbol list;
its_regs : region list;
its_def : ity option;
its_pure : tysymbol;
its_args : tvsymbol list;
its_regs : region list;
its_def : ity option;
its_abst : bool;
its_priv : bool;
}
and ity = {
......@@ -43,9 +45,9 @@ and ity_node =
| Ityapp of itysymbol * ity list * region list
and region = {
reg_name : ident;
reg_ity : ity;
reg_ghost: bool;
reg_name : ident;
reg_ity : ity;
reg_ghost : bool;
}
(** regions *)
......@@ -181,10 +183,11 @@ let ity_v_any prv prr ity =
let ity_full_inst mv mr ity =
ity_v_map (fun v -> Mtv.find v mv) (fun r -> Mreg.find r mr) ity
let ity_freevars s ity = ity_v_fold (fun s v -> Stv.add v s) Util.const s ity
let ity_freevars = ity_v_fold (fun s v -> Stv.add v s) Util.const
let ity_topregions = ity_v_fold Util.const (fun s r -> Sreg.add r s)
let ity_closed ity = ity_v_all Util.ffalse Util.ttrue ity
let ity_pure ity = ity_v_all Util.ttrue Util.ffalse ity
let ity_closed = ity_v_all Util.ffalse Util.ttrue
let ity_pure = ity_v_all Util.ttrue Util.ffalse
(* smart constructors *)
......@@ -202,8 +205,8 @@ let ity_equal_check ty1 ty2 =
if not (ity_equal ty1 ty2) then raise (TypeMismatch (ty1, ty2))
type ity_subst = {
ity_subst_tv: ity Mtv.t;
ity_subst_reg: region Mreg.t;
ity_subst_tv : ity Mtv.t;
ity_subst_reg : region Mreg.t;
}
let ity_subst_empty = {
......@@ -258,27 +261,58 @@ let rec ity_of_ty ty = match ty.ty_node with
| Tyvar v -> ity_var v
| Tyapp (s,tl) -> ity_pur s (List.map ity_of_ty tl)
let rec ity_inst_fresh mv mr ity = match ity.ity_node with
| Ityvar v ->
mr, Mtv.find v mv
| Itypur (s,tl) ->
let mr,tl = Util.map_fold_left (ity_inst_fresh mv) mr tl in
mr, ity_pur s tl
| Ityapp (s,tl,rl) ->
let mr,tl = Util.map_fold_left (ity_inst_fresh mv) mr tl in
let mr,rl = Util.map_fold_left (reg_refresh mv) mr rl in
mr, ity_app s tl rl
and reg_refresh mv mr r = match Mreg.find_opt r mr with
| Some r ->
mr, r
| None ->
let mr,ity = ity_inst_fresh mv mr r.reg_ity in
let id = id_clone r.reg_name and ghost = r.reg_ghost in
let reg = create_region id ~ghost ity in
Mreg.add r reg mr, reg
let ity_app_fresh s tl =
(* type variable map *)
let add m v t = Mtv.add v t m in
let mv = try List.fold_left2 add Mtv.empty s.its_args tl
with Invalid_argument _ ->
raise (BadItyArity (s, List.length s.its_args, List.length tl)) in
(* refresh regions *)
let mr,rl = Util.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in
(* every external region in def is guaranteed to be in mr *)
match s.its_def with
| Some ity -> ity_full_inst mv mr ity
| None -> ity_app s tl rl
let ity_app s tl rl =
let tll = List.length tl in
let rll = List.length rl in
let stl = List.length s.its_args in
let srl = List.length s.its_regs in
if tll <> stl then raise (BadItyArity (s,stl,tll));
if rll <> srl then raise (BadRegArity (s,srl,rll));
(* type variable map *)
let add m v t = Mtv.add v t m in
let mv = List.fold_left2 add Mtv.empty s.its_args tl in
let mv = try List.fold_left2 add Mtv.empty s.its_args tl
with Invalid_argument _ ->
raise (BadItyArity (s, List.length s.its_args, List.length tl)) in
(* region map *)
let add m v r = Mreg.add v r m in
let mr = List.fold_left2 add Mreg.empty s.its_regs rl in
let mr = try List.fold_left2 add Mreg.empty s.its_regs rl
with Invalid_argument _ ->
raise (BadRegArity (s, List.length s.its_regs, List.length rl)) in
(* check that region types do unify *)
let sub = { ity_subst_tv = mv; ity_subst_reg = mr } in
let rmatch sub r1 r2 = ity_match sub r1.reg_ity r2.reg_ity in
ignore (List.fold_left2 rmatch sub s.its_regs rl);
(* to instantiate def, mv and mr are enough *)
match s.its_def with
| Some ity ->
ity_full_inst mv mr ity
| None ->
ity_app s tl rl
| Some ity -> ity_full_inst mv mr ity
| None -> ity_app s tl rl
let ity_pur s tl = match s.ts_def with
| Some ty ->
......@@ -288,7 +322,7 @@ let ity_pur s tl = match s.ts_def with
| None ->
ity_pur s tl
let create_itysymbol name args regs def (* model *) =
let create_itysymbol name ?(abst=false) ?(priv=false) args regs def =
let puredef = option_map ty_of_ity def in
let purets = create_tysymbol name args puredef in
(* all regions *)
......@@ -302,19 +336,20 @@ let create_itysymbol name args regs def (* model *) =
(* all regions in [def] must be in [regs] *)
let check r = Sreg.mem r sregs || raise (UnboundRegion r) in
ignore (option_map (ity_v_all Util.ttrue check) def);
(* if a type is a model alias, expand everything on the RHS *)
(* let def = if model then option_map (ity_mod purets) def else def in *)
(* if a type is an alias then abst and priv will be ignored *)
{ its_pure = purets;
its_args = args;
its_regs = regs;
its_def = def; }
its_def = def;
its_abst = abst;
its_priv = priv }
(** computation types (with effects) *)
(* exception symbols *)
type xsymbol = {
xs_name : ident;
xs_ity: ity; (* closed and pure *)
xs_ity : ity; (* closed and pure *)
}
exception PolymorphicException of ident * ity
......@@ -330,24 +365,25 @@ module Exn = StructMake (struct
type t = xsymbol
let tag xs = Hashweak.tag_hash xs.xs_name.id_tag
end)
module Sexn = Exn.S
module Mexn = Exn.M
(* effects *)
type effect = {
eff_reads: Sreg.t;
eff_writes: Sreg.t;
eff_erases: Sreg.t;
eff_renames: region Mreg.t; (* if r1->r2 then r1 appears in ty(r2) *)
eff_raises: Sexn.t;
eff_reads : Sreg.t;
eff_writes : Sreg.t;
eff_erases : Sreg.t;
eff_renames : region Mreg.t; (* if r1->r2 then r1 appears in ty(r2) *)
eff_raises : Sexn.t;
}
let eff_empty = {
eff_reads = Sreg.empty;
eff_writes = Sreg.empty;
eff_erases = Sreg.empty;
eff_reads = Sreg.empty;
eff_writes = Sreg.empty;
eff_erases = Sreg.empty;
eff_renames = Mreg.empty;
eff_raises = Sexn.empty
eff_raises = Sexn.empty
}
let eff_union x y =
......@@ -372,10 +408,10 @@ let eff_remove_raise xs e = { e with eff_raises = Sexn.remove xs e.eff_raises }
(* program variables *)
type pvsymbol = {
pv_vs: vsymbol;
pv_ity: ity;
pv_ghost: bool;
pv_mutable: region option;
pv_vs : vsymbol;
pv_ity : ity;
pv_ghost : bool;
pv_mutable : region option;
}
exception InvalidPVsymbol of ident
......@@ -403,11 +439,11 @@ type vty =
(* computation types *)
and cty = {
c_pre: term;
c_vty: vty;
c_eff: effect;
c_post: term;
c_xpost: xpost;
c_pre : term;
c_vty : vty;
c_eff : effect;
c_post : term;
c_xpost : xpost;
}
and xpost = (pvsymbol * term) Mexn.t
......
......@@ -30,6 +30,8 @@ type itysymbol = private {
its_args : tvsymbol list;
its_regs : region list;
its_def : ity option;
its_abst : bool;
its_priv : bool;
}
and ity = private {
......@@ -80,13 +82,14 @@ exception InvalidRegion of region
val create_region : preid -> ?ghost:bool -> ity -> region
val create_itysymbol :
preid -> tvsymbol list -> region list -> ity option -> itysymbol
val create_itysymbol : preid -> ?abst:bool -> ?priv:bool ->
tvsymbol list -> region list -> ity option -> itysymbol
val ity_var : tvsymbol -> ity
val ity_pur : tysymbol -> ity list -> ity
val ity_app : itysymbol -> ity list -> region list -> ity
val ity_app_fresh : itysymbol -> ity list -> ity
(* all aliases expanded, all regions removed *)
val ty_of_ity : ity -> ty
......@@ -124,18 +127,19 @@ val ity_s_any : (itysymbol -> bool) -> ity -> bool
*)
val ity_freevars : Stv.t -> ity -> Stv.t
val ity_topregions : Sreg.t -> ity -> Sreg.t
val ity_closed : ity -> bool
val ity_pure: ity -> bool
val ity_pure : ity -> bool
exception RegionMismatch of region * region
exception TypeMismatch of ity * ity
type ity_subst = private {
ity_subst_tv: ity Mtv.t;
ity_subst_reg: region Mreg.t;
ity_subst_tv : ity Mtv.t;
ity_subst_reg : region Mreg.t;
}
val ity_subst_empty: ity_subst
val ity_subst_empty : ity_subst
val ity_match : ity_subst -> ity -> ity -> ity_subst
......@@ -146,40 +150,42 @@ val ity_equal_check : ity -> ity -> unit
(* exception symbols *)
type xsymbol = private {
xs_name : ident;
xs_ity: ity; (* closed and pure *)
xs_ity : ity; (* closed and pure *)
}
val create_xsymbol: preid -> ity -> xsymbol
val create_xsymbol : preid -> ity -> xsymbol
module Mexn: Map.S with type key = xsymbol
module Sexn: Mexn.Set
(* effects *)
type effect = private {
eff_reads: Sreg.t;
eff_writes: Sreg.t;
eff_erases: Sreg.t;
eff_renames: region Mreg.t; (* if r1->r2 then r1 appears in ty(r2) *)
eff_raises: Sexn.t;
eff_reads : Sreg.t;
eff_writes : Sreg.t;
eff_erases : Sreg.t;
eff_renames : region Mreg.t; (* if r1->r2 then r1 appears in ty(r2) *)
eff_raises : Sexn.t;
}
val eff_empty: effect
val eff_union: effect -> effect -> effect
val eff_read: region -> effect
val eff_write: region -> effect
val eff_erase: region -> effect
val eff_raise: xsymbol -> effect
val eff_remove_raise: xsymbol -> effect -> effect
val eff_empty : effect
val eff_union : effect -> effect -> effect
val eff_read : region -> effect
val eff_write : region -> effect
val eff_erase : region -> effect
val eff_raise : xsymbol -> effect
val eff_remove_raise : xsymbol -> effect -> effect
(* program variables *)
type pvsymbol = private {
pv_vs: vsymbol;
pv_ity: ity;
pv_ghost: bool;
pv_mutable: region option;
pv_vs : vsymbol;
pv_ity : ity;
pv_ghost : bool;
pv_mutable : region option;
}
val create_pvsymbol: preid -> ?mut:region -> ?ghost:bool -> ity -> pvsymbol
val create_pvsymbol : preid -> ?mut:region -> ?ghost:bool -> ity -> pvsymbol
val pv_equal : pvsymbol -> pvsymbol -> bool
......@@ -190,19 +196,19 @@ type vty = private
(* computation types *)
and cty = private {
c_pre: term;
c_vty: vty;
c_eff: effect;
c_post: term;
c_xpost: xpost;
c_pre : term;
c_vty : vty;
c_eff : effect;
c_post : term;
c_xpost : xpost;
}
and xpost = (pvsymbol * term) Mexn.t
(* smart constructors *)
val create_cty:
val create_cty :
?pre:term -> ?post:term -> ?xpost:xpost -> ?effect:effect -> vty -> cty
val vty_value: pvsymbol -> vty
val vty_arrow: pvsymbol -> cty -> vty
val vty_value : pvsymbol -> vty
val vty_arrow : pvsymbol -> cty -> vty
This diff is collapsed.
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment