Commit 49d173b7 authored by Pietro Abate's avatar Pietro Abate
Browse files

Fix type substition for parametric types

parent 0d3a9e60
...@@ -1008,8 +1008,6 @@ let get_variables main_memo temp_memo t = ...@@ -1008,8 +1008,6 @@ let get_variables main_memo temp_memo t =
(Var.Set.union tvpos tpos, (Var.Set.union tvpos tpos,
Var.Set.union tvneg tneg, Var.Set.union tvneg tneg,
Var.Set.union tvars vars) Var.Set.union tvars vars)
in in
get_variables true Var.Set.(empty,empty,empty) t get_variables true Var.Set.(empty,empty,empty) t
...@@ -2816,6 +2814,17 @@ module Positive = struct ...@@ -2816,6 +2814,17 @@ module Positive = struct
descr (solve new_t) descr (solve new_t)
end end
let substitute_list t l =
if no_var t then t
else begin
let subst l d =
try ty(snd(List.find (fun (alpha,_) -> Var.equal d alpha) l))
with Not_found -> var d
in
let new_t = (substitute_aux Var.Set.empty (decompose t) (subst l)) in
descr (solve new_t)
end
let substitutefree delta t = let substitutefree delta t =
if no_var t then t else if no_var t then t else
let h = Hashtbl.create 17 in let h = Hashtbl.create 17 in
......
...@@ -165,6 +165,7 @@ module Positive : sig ...@@ -165,6 +165,7 @@ module Positive : sig
val xml: v -> v -> v val xml: v -> v -> v
val substitute : t -> (Var.var * t) -> t val substitute : t -> (Var.var * t) -> t
val substitute_list : t -> (Var.var * t) list -> t
val substituterec : t -> Var.var -> t val substituterec : t -> Var.var -> t
val solve: v -> Node.t val solve: v -> Node.t
val substitutefree : Var.Set.t -> t -> t val substitutefree : Var.Set.t -> t -> t
......
...@@ -59,11 +59,9 @@ let pp_env ppf env = ...@@ -59,11 +59,9 @@ let pp_env ppf env =
let pp_item ppf (s,t) = match t with let pp_item ppf (s,t) = match t with
|Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t |Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
|Type (t,[||]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t |Type (t,[||]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
|Type (t,[|a|]) ->
Format.fprintf ppf "type %s %a = %a" s Var.pp a Types.Print.pp_noname t
|Type (t,al) -> |Type (t,al) ->
Format.fprintf ppf "type %s %a = %a" s Format.fprintf ppf "type %s %a = %a" s
(Utils.pp_list ~delim:("(",")") Var.pp) (Array.to_list al) (Utils.pp_list ~delim:("{[","]}") Var.pp) (Array.to_list al)
Types.Print.pp_noname t Types.Print.pp_noname t
|_ -> () |_ -> ()
in in
...@@ -273,7 +271,8 @@ let type_ns env loc p ns = ...@@ -273,7 +271,8 @@ let type_ns env loc p ns =
let find_global_type env loc ids = let find_global_type env loc ids =
match find_global env loc ids with match find_global env loc ids with
| Type (t,_) | ESchemaComponent (t,_) -> t | Type (t,pargs) -> (t,pargs)
| ESchemaComponent (t,_) -> (t,[||]) (* XXX *)
| _ -> error loc "This path does not refer to a type" | _ -> error loc "This path does not refer to a type"
let find_global_schema_component env loc ids = let find_global_schema_component env loc ids =
...@@ -283,7 +282,7 @@ let find_global_schema_component env loc ids = ...@@ -283,7 +282,7 @@ let find_global_schema_component env loc ids =
let find_local_type env loc id = let find_local_type env loc id =
match Env.find id env.ids with match Env.find id env.ids with
| Type (t,_) -> t | Type (t,pargs) -> (t,pargs)
| _ -> raise Not_found | _ -> raise Not_found
let find_value id env = let find_value id env =
...@@ -381,16 +380,27 @@ module IType = struct ...@@ -381,16 +380,27 @@ module IType = struct
and derecurs_var env loc ids = and derecurs_var env loc ids =
match ids with match ids with
| ([v],_) -> | ([v],a) ->
let v = ident env.penv_tenv loc v in let v = ident env.penv_tenv loc v in
begin begin
try Env.find v env.penv_derec try Env.find v env.penv_derec
with Not_found -> with Not_found ->
try mk_type (find_local_type env.penv_tenv loc v) try
let (t,pargs) = find_local_type env.penv_tenv loc v in
let palen = Array.length pargs in
if palen <> List.length a then
raise_loc_generic loc
(Printf.sprintf "Parametric type %s is not fully qualified" (Ident.to_string v));
let a = Array.of_list a in
let l = ref [] in
for i=0 to (Array.length pargs) - 1 do
l := (pargs.(i), typ(derecurs env a.(i)))::!l
done;
mk_type (Types.Positive.substitute_list t !l)
with Not_found -> mk_capture v with Not_found -> mk_capture v
end end
| (ids,_) -> | (ids,_) ->
mk_type (find_global_type env.penv_tenv loc ids) mk_type (fst(find_global_type env.penv_tenv loc ids))
and derecurs_def env b = and derecurs_def env b =
let seen = ref IdSet.empty in let seen = ref IdSet.empty in
......
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