Commit 11469bf5 authored by Mário Pereira's avatar Mário Pereira
Browse files

Coercions

Started a module to contain operations specific to coercions
parent bb227958
...@@ -263,15 +263,12 @@ let dexpr_expected_type dt dty = match dty with ...@@ -263,15 +263,12 @@ let dexpr_expected_type dt dty = match dty with
| Some dty -> dterm_expected_type dt dty | Some dty -> dterm_expected_type dt dty
| None -> dfmla_expected_type dt | None -> dfmla_expected_type dt
let ts_of_dty = function let ts_of_dty = function
| Dapp (ts, _) | Duty { ty_node = Tyapp (ts , _)} -> ts | Dapp (ts, _) | Duty { ty_node = Tyapp (ts , _)} -> ts
| _ -> assert false (*fixme*) | _ -> assert false (*fixme*)
let darg_expected dt_dty dty = dty_unify dt_dty dty let darg_expected dt_dty dty = dty_unify dt_dty dty
(** Constructors *) (** Constructors *)
let dpattern ?loc node = let dpattern ?loc node =
...@@ -307,32 +304,25 @@ let dterm tuc ?loc node = ...@@ -307,32 +304,25 @@ let dterm tuc ?loc node =
let rec dterm_expected dt dty = let rec dterm_expected dt dty =
match dt.dt_dty with match dt.dt_dty with
| Some dt_dty -> | Some dt_dty ->
begin begin try dty_unify dt_dty dty; dt with Exit ->
try dty_unify dt_dty dty; dt with Exit -> begin match ty_of_dty false dt_dty, ty_of_dty false dty with
begin | { ty_node = Tyapp (ts1, _) }, { ty_node = Tyapp (ts2, _) } ->
match ty_of_dty false dt_dty, ty_of_dty false dty with begin try
| { ty_node = Tyapp (ts1, _) }, { ty_node = Tyapp (ts2, _) } -> let open Theory in
begin let ls = Coercion.find ts1 ts2 tuc.uc_crcmap in
try dterm_node loc (DTapp (ls, [dt]))
let ls = with Not_found ->
Mts.find ts2 (Mts.find ts1 tuc.Theory.uc_crcmap) in Loc.errorm ?loc:dt.dt_loc
dterm_node loc (DTapp (ls, [dt])) "This term has type %a,@ but is expected to have type %a"
with Not_found -> print_dty dt_dty print_dty dty end
Loc.errorm ?loc:dt.dt_loc | _ ->
"This term has type %a,@ but is expected to have type %a" Loc.errorm ?loc:dt.dt_loc
print_dty dt_dty "This term has type %a,@ but is expected to have type %a"
print_dty dty print_dty dt_dty print_dty dty end
end
| _ ->
Loc.errorm ?loc:dt.dt_loc
"This term has type %a,@ but is expected to have type %a"
print_dty dt_dty print_dty dty
end
end end
| None -> | None ->
try try dty_unify dty_bool dty; dt with Exit ->
dty_unify dty_bool dty; dt Loc.error ?loc:dt.dt_loc TermExpected
with Exit -> Loc.error ?loc:dt.dt_loc TermExpected
and dterm_node loc node = and dterm_node loc node =
let f ty = { dt_node = node; dt_dty = ty; dt_loc = loc } in let f ty = { dt_node = node; dt_dty = ty; dt_loc = loc } in
...@@ -356,7 +346,7 @@ and dterm_node loc node = ...@@ -356,7 +346,7 @@ and dterm_node loc node =
| Duty {ty_node = Tyapp (ts,_)} | Dapp (ts,_) -> not (ts_equal ts Ty.ts_func) | Duty {ty_node = Tyapp (ts,_)} | Dapp (ts,_) -> not (ts_equal ts Ty.ts_func)
| Dvar _ -> false | _ -> true in | Dvar _ -> false | _ -> true in
if not_arrow res then Loc.errorm ?loc:dt1.dt_loc if not_arrow res then Loc.errorm ?loc:dt1.dt_loc
"This term has type %a,@ it cannot be applied" print_dty res; "This term has type %a,@ it cannot be applied" print_dty res;
let dtyl, dty = specialize_ls fs_func_app in let dtyl, dty = specialize_ls fs_func_app in
dty_unify_app fs_func_app dterm_expected_type [dt1;dt2] dtyl; dty_unify_app fs_func_app dterm_expected_type [dt1;dt2] dtyl;
f dty f dty
...@@ -410,8 +400,6 @@ and dterm_node loc node = ...@@ -410,8 +400,6 @@ and dterm_node loc node =
f (dt.dt_dty) f (dt.dt_dty)
in Loc.try1 ?loc (dterm_node loc) node in Loc.try1 ?loc (dterm_node loc) node
(** Final stage *) (** Final stage *)
let pat_ty_of_dty ~strict dty = let pat_ty_of_dty ~strict dty =
......
...@@ -150,7 +150,39 @@ let list_metas () = Hstr.fold (fun _ v acc -> v::acc) meta_table [] ...@@ -150,7 +150,39 @@ let list_metas () = Hstr.fold (fun _ v acc -> v::acc) meta_table []
(** Theory *) (** Theory *)
type coercions_map = (lsymbol Mts.t) Mts.t module Coercion = struct
type t = (lsymbol Mts.t) Mts.t
exception CoercionCycle of lsymbol
let mem ts1 ts2 crcmap =
try let m = Mts.find ts1 crcmap in Mts.mem ts2 m
with Not_found -> false
let check_cycle ts1 ts2 crcmap =
(* we know that the graph is transitively closed *)
mem ts2 ts1 crcmap
let add crcmap = function
| [MAls ({ls_args = [{ty_node = Tyapp (ty1,_)}];
ls_value = Some {ty_node = Tyapp (ty2,_)}} as ls)] ->
if check_cycle ty1 ty2 crcmap then raise (CoercionCycle ls)
else
let m1 = try Mts.find ty1 crcmap with Not_found -> Mts.empty in
if Mts.mem ty2 m1 then
Warning.emit
"Coercion %s hiddes previous coercion from %s to %s"
ls.ls_name.id_string ty1.ts_name.id_string ty2.ts_name.id_string;
let m2 = Mts.add ty2 ls m1 in
Mts.add ty1 m2 crcmap
| _ -> assert false
let find ts1 ts2 crcmap =
Mts.find ts2 (Mts.find ts1 crcmap)
(* let join m1 m2 = *)
end
type theory = { type theory = {
th_name : ident; (* theory name *) th_name : ident; (* theory name *)
...@@ -160,7 +192,7 @@ type theory = { ...@@ -160,7 +192,7 @@ type theory = {
th_known : known_map; (* known identifiers *) th_known : known_map; (* known identifiers *)
th_local : Sid.t; (* locally declared idents *) th_local : Sid.t; (* locally declared idents *)
th_used : Sid.t; (* used theories *) th_used : Sid.t; (* used theories *)
th_crcmap : coercions_map; (* coercions *) th_crcmap : Coercion.t; (* coercions *)
} }
and tdecl = { and tdecl = {
...@@ -266,7 +298,7 @@ type theory_uc = { ...@@ -266,7 +298,7 @@ type theory_uc = {
uc_known : known_map; uc_known : known_map;
uc_local : Sid.t; uc_local : Sid.t;
uc_used : Sid.t; uc_used : Sid.t;
uc_crcmap : coercions_map; uc_crcmap : Coercion.t;
} }
exception CloseTheory exception CloseTheory
...@@ -287,22 +319,14 @@ let empty_theory n p = { ...@@ -287,22 +319,14 @@ let empty_theory n p = {
let close_theory uc = match uc.uc_export with let close_theory uc = match uc.uc_export with
| [e] -> | [e] ->
Mts.iter { th_name = uc.uc_name;
(fun k m ->
(Mts.iter (fun k2 ls -> Format.eprintf "%s * %s -> %s@."
k.ts_name.id_string
k2.ts_name.id_string
ls.ls_name.id_string) m
)) uc.uc_crcmap;
{
th_name = uc.uc_name;
th_path = uc.uc_path; th_path = uc.uc_path;
th_decls = List.rev uc.uc_decls; th_decls = List.rev uc.uc_decls;
th_export = e; th_export = e;
th_known = uc.uc_known; th_known = uc.uc_known;
th_local = uc.uc_local; th_local = uc.uc_local;
th_used = uc.uc_used; th_used = uc.uc_used;
th_crcmap = uc.uc_crcmap} th_crcmap = uc.uc_crcmap }
| _ -> raise CloseTheory | _ -> raise CloseTheory
let get_namespace uc = List.hd uc.uc_import let get_namespace uc = List.hd uc.uc_import
...@@ -346,15 +370,6 @@ let known_meta kn al = ...@@ -346,15 +370,6 @@ let known_meta kn al =
in in
List.iter check al List.iter check al
let add_coercion crcmap m al = match al with
| [MAls ({ls_args = [{ ty_node = Tyapp (ty1,_) }];
ls_value = Some { ty_node = Tyapp (ty2,_) }} as ls)] ->
let crcmap1 = try Mts.find ty1 crcmap with Not_found -> Mts.empty in
let crcmap2 = Mts.add ty2 ls crcmap1 in
Mts.add ty1 crcmap2 crcmap
| _ -> assert false
let meta_coercion = register_meta ~desc:"coercion" "coercion" [MTlsymbol] let meta_coercion = register_meta ~desc:"coercion" "coercion" [MTlsymbol]
let add_tdecl uc td = match td.td_node with let add_tdecl uc td = match td.td_node with
...@@ -371,7 +386,7 @@ let add_tdecl uc td = match td.td_node with ...@@ -371,7 +386,7 @@ let add_tdecl uc td = match td.td_node with
{ uc with uc_decls = td :: uc.uc_decls } { uc with uc_decls = td :: uc.uc_decls }
| Meta (m,al) when meta_equal m meta_coercion -> | Meta (m,al) when meta_equal m meta_coercion ->
known_meta uc.uc_known al; known_meta uc.uc_known al;
{ uc with uc_crcmap = add_coercion uc.uc_crcmap m al } { uc with uc_crcmap = Coercion.add uc.uc_crcmap al }
| Meta (_,al) -> known_meta uc.uc_known al; | Meta (_,al) -> known_meta uc.uc_known al;
{ uc with uc_decls = td :: uc.uc_decls } { uc with uc_decls = td :: uc.uc_decls }
...@@ -919,5 +934,7 @@ let () = Exn_printer.register ...@@ -919,5 +934,7 @@ let () = Exn_printer.register
Format.fprintf fmt "Metaproperty %s expects a %a argument but \ Format.fprintf fmt "Metaproperty %s expects a %a argument but \
is applied to %a" is applied to %a"
m.meta_name print_meta_arg_type t1 print_meta_arg_type t2 m.meta_name print_meta_arg_type t1 print_meta_arg_type t2
| Coercion.CoercionCycle ls ->
Format.fprintf fmt "Coercion %s introduces a cycle" ls.ls_name.id_string
| _ -> raise exn | _ -> raise exn
end end
...@@ -80,7 +80,14 @@ val list_metas : unit -> meta list ...@@ -80,7 +80,14 @@ val list_metas : unit -> meta list
(** {2 Theories} *) (** {2 Theories} *)
type coercions_map = (lsymbol Mts.t) Mts.t module Coercion : sig
type t
val add : t -> meta_arg list -> t
val find : tysymbol -> tysymbol -> t -> lsymbol
end
type theory = private { type theory = private {
th_name : ident; (* theory name *) th_name : ident; (* theory name *)
...@@ -90,7 +97,7 @@ type theory = private { ...@@ -90,7 +97,7 @@ type theory = private {
th_known : known_map; (* known identifiers *) th_known : known_map; (* known identifiers *)
th_local : Sid.t; (* locally declared idents *) th_local : Sid.t; (* locally declared idents *)
th_used : Sid.t; (* used theories *) th_used : Sid.t; (* used theories *)
th_crcmap : coercions_map (* coercions *) th_crcmap : Coercion.t (* coercions *)
} }
and tdecl = private { and tdecl = private {
...@@ -130,7 +137,7 @@ type theory_uc = private { ...@@ -130,7 +137,7 @@ type theory_uc = private {
uc_known : known_map; uc_known : known_map;
uc_local : Sid.t; uc_local : Sid.t;
uc_used : Sid.t; uc_used : Sid.t;
uc_crcmap : coercions_map; uc_crcmap : Coercion.t;
} }
......
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