aboutsummaryrefslogtreecommitdiff
path: root/plugins/funind/glob_termops.ml
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/funind/glob_termops.ml')
-rw-r--r--plugins/funind/glob_termops.ml262
1 files changed, 53 insertions, 209 deletions
diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml
index 003bb4e30d..41eb48657a 100644
--- a/plugins/funind/glob_termops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -10,83 +10,26 @@ open Misctypes
Some basic functions to rebuild glob_constr
In each of them the location is Loc.ghost
*)
-let mkGRef ref = CAst.make @@ GRef(ref,None)
-let mkGVar id = CAst.make @@ GVar(id)
-let mkGApp(rt,rtl) = CAst.make @@ GApp(rt,rtl)
-let mkGLambda(n,t,b) = CAst.make @@ GLambda(n,Explicit,t,b)
-let mkGProd(n,t,b) = CAst.make @@ GProd(n,Explicit,t,b)
-let mkGLetIn(n,b,t,c) = CAst.make @@ GLetIn(n,b,t,c)
-let mkGCases(rto,l,brl) = CAst.make @@ GCases(Term.RegularStyle,rto,l,brl)
-let mkGSort s = CAst.make @@ GSort(s)
-let mkGHole () = CAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None)
-let mkGCast(b,t) = CAst.make @@ GCast(b,CastConv t)
+let mkGRef ref = DAst.make @@ GRef(ref,None)
+let mkGVar id = DAst.make @@ GVar(id)
+let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl)
+let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b)
+let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b)
+let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c)
+let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl)
+let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None)
(*
Some basic functions to decompose glob_constrs
These are analogous to the ones constrs
*)
-let glob_decompose_prod =
- let rec glob_decompose_prod args = function
- | { CAst.v = GProd(n,k,t,b) } ->
- glob_decompose_prod ((n,t)::args) b
- | rt -> args,rt
- in
- glob_decompose_prod []
-
-let glob_decompose_prod_or_letin =
- let rec glob_decompose_prod args = function
- | { CAst.v = GProd(n,k,t,b) } ->
- glob_decompose_prod ((n,None,Some t)::args) b
- | { CAst.v = GLetIn(n,b,t,c) } ->
- glob_decompose_prod ((n,Some b,t)::args) c
- | rt -> args,rt
- in
- glob_decompose_prod []
-
-let glob_compose_prod =
- List.fold_left (fun b (n,t) -> mkGProd(n,t,b))
-
-let glob_compose_prod_or_letin =
- List.fold_left (
- fun concl decl ->
- match decl with
- | (n,None,Some t) -> mkGProd(n,t,concl)
- | (n,Some bdy,t) -> mkGLetIn(n,bdy,t,concl)
- | _ -> assert false)
-
-let glob_decompose_prod_n n =
- let rec glob_decompose_prod i args c =
- if i<=0 then args,c
- else
- match c with
- | { CAst.v = GProd(n,_,t,b) } ->
- glob_decompose_prod (i-1) ((n,t)::args) b
- | rt -> args,rt
- in
- glob_decompose_prod n []
-
-
-let glob_decompose_prod_or_letin_n n =
- let rec glob_decompose_prod i args c =
- if i<=0 then args,c
- else
- match c with
- | { CAst.v = GProd(n,_,t,b) } ->
- glob_decompose_prod (i-1) ((n,None,Some t)::args) b
- | { CAst.v = GLetIn(n,b,t,c) } ->
- glob_decompose_prod (i-1) ((n,Some b,t)::args) c
- | rt -> args,rt
- in
- glob_decompose_prod n []
-
-
let glob_decompose_app =
let rec decompose_rapp acc rt =
(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *)
- match rt with
- | { CAst.v = GApp(rt,rtl) } ->
+ match DAst.get rt with
+ | GApp(rt,rtl) ->
decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
- | rt -> rt,List.rev acc
+ | _ -> rt,List.rev acc
in
decompose_rapp []
@@ -101,18 +44,6 @@ let glob_make_eq ?(typ= mkGHole ()) t1 t2 =
let glob_make_neq t1 t2 =
mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2])
-(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
-let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
-
-(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
- to [P1 \/ ( .... \/ Pn)]
-*)
-let rec glob_make_or_list = function
- | [] -> invalid_arg "mk_or"
- | [e] -> e
- | e::l -> glob_make_or e (glob_make_or_list l)
-
-
let remove_name_from_mapping mapping na =
match na with
| Anonymous -> mapping
@@ -120,7 +51,7 @@ let remove_name_from_mapping mapping na =
let change_vars =
let rec change_vars mapping rt =
- CAst.map_with_loc (fun ?loc -> function
+ DAst.map_with_loc (fun ?loc -> function
| GRef _ as x -> x
| GVar id ->
let new_id =
@@ -178,6 +109,7 @@ let change_vars =
| GCast(b,c) ->
GCast(change_vars mapping b,
Miscops.map_cast_type (change_vars mapping) c)
+ | GProj(p,c) -> GProj(p, change_vars mapping c)
) rt
and change_vars_br mapping ((loc,(idl,patl,res)) as br) =
let new_mapping = List.fold_right Id.Map.remove idl mapping in
@@ -191,22 +123,22 @@ let change_vars =
let rec alpha_pat excluded pat =
let loc = pat.CAst.loc in
- match pat.CAst.v with
+ match DAst.get pat with
| PatVar Anonymous ->
let new_id = Indfun_common.fresh_id excluded "_x" in
- (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty
+ (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty
| PatVar(Name id) ->
if Id.List.mem id excluded
then
- let new_id = Namegen.next_ident_away id excluded in
- (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),
+ let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
+ (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),
(Id.Map.add id new_id Id.Map.empty)
else pat, excluded,Id.Map.empty
| PatCstr(constr,patl,na) ->
let new_na,new_excluded,map =
match na with
| Name id when Id.List.mem id excluded ->
- let new_id = Namegen.next_ident_away id excluded in
+ let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty
| _ -> na,excluded,Id.Map.empty
in
@@ -219,7 +151,7 @@ let rec alpha_pat excluded pat =
([],new_excluded,map)
patl
in
- (CAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map
+ (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map
let alpha_patl excluded patl =
let patl,new_excluded,map =
@@ -238,7 +170,7 @@ let alpha_patl excluded patl =
let raw_get_pattern_id pat acc =
let rec get_pattern_id pat =
- match pat.CAst.v with
+ match DAst.get pat with
| PatVar(Anonymous) -> assert false
| PatVar(Name id) ->
[id]
@@ -257,11 +189,11 @@ let get_pattern_id pat = raw_get_pattern_id pat []
let rec alpha_rt excluded rt =
let loc = rt.CAst.loc in
- let new_rt = CAst.make ?loc @@
- match rt.CAst.v with
+ let new_rt = DAst.make ?loc @@
+ match DAst.get rt with
| GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt
| GLambda(Anonymous,k,t,b) ->
- let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in
+ let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in
let new_excluded = new_id :: excluded in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
@@ -276,7 +208,7 @@ let rec alpha_rt excluded rt =
let new_c = alpha_rt excluded c in
GLetIn(Anonymous,new_b,new_t,new_c)
| GLambda(Name id,k,t,b) ->
- let new_id = Namegen.next_ident_away id excluded in
+ let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
let t,b =
if Id.equal new_id id
then t, b
@@ -289,7 +221,7 @@ let rec alpha_rt excluded rt =
let new_b = alpha_rt new_excluded b in
GLambda(Name new_id,k,new_t,new_b)
| GProd(Name id,k,t,b) ->
- let new_id = Namegen.next_ident_away id excluded in
+ let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
let new_excluded = new_id::excluded in
let t,b =
if Id.equal new_id id
@@ -302,7 +234,7 @@ let rec alpha_rt excluded rt =
let new_b = alpha_rt new_excluded b in
GProd(Name new_id,k,new_t,new_b)
| GLetIn(Name id,b,t,c) ->
- let new_id = Namegen.next_ident_away id excluded in
+ let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
let c =
if Id.equal new_id id then c
else change_vars (Id.Map.add id new_id Id.Map.empty) c
@@ -320,7 +252,7 @@ let rec alpha_rt excluded rt =
match na with
| Anonymous -> (na::nal,excluded,mapping)
| Name id ->
- let new_id = Namegen.next_ident_away id excluded in
+ let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in
if Id.equal new_id id
then
na::nal,id::excluded,mapping
@@ -362,6 +294,7 @@ let rec alpha_rt excluded rt =
GApp(alpha_rt excluded f,
List.map (alpha_rt excluded) args
)
+ | GProj(p,c) -> GProj(p, alpha_rt excluded c)
in
new_rt
@@ -377,7 +310,7 @@ and alpha_br excluded (loc,(ids,patl,res)) =
[is_free_in id rt] checks if [id] is a free variable in [rt]
*)
let is_free_in id =
- let rec is_free_in x = CAst.with_loc_val (fun ?loc -> function
+ let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function
| GRef _ -> false
| GVar id' -> Id.compare id' id == 0
| GEvar _ -> false
@@ -413,6 +346,7 @@ let is_free_in id =
| GHole _ -> false
| GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t
| GCast (b,CastCoerce) -> is_free_in b
+ | GProj (_,c) -> is_free_in c
) x
and is_free_in_br (_,(ids,_,rt)) =
(not (Id.List.mem id ids)) && is_free_in rt
@@ -421,7 +355,7 @@ let is_free_in id =
-let rec pattern_to_term pt = CAst.with_val (function
+let rec pattern_to_term pt = DAst.with_val (function
| PatVar Anonymous -> assert false
| PatVar(Name id) ->
mkGVar id
@@ -448,8 +382,8 @@ let rec pattern_to_term pt = CAst.with_val (function
let replace_var_by_term x_id term =
- let rec replace_var_by_pattern x = CAst.map (function
- | GVar id when Id.compare id x_id == 0 -> term.CAst.v
+ let rec replace_var_by_pattern x = DAst.map (function
+ | GVar id when Id.compare id x_id == 0 -> DAst.get term
| GRef _
| GVar _
| GEvar _
@@ -506,6 +440,8 @@ let replace_var_by_term x_id term =
| GCast(b,c) ->
GCast(replace_var_by_pattern b,
Miscops.map_cast_type replace_var_by_pattern c)
+ | GProj(p,c) ->
+ GProj(p,replace_var_by_pattern c)
) x
and replace_var_by_pattern_br ((loc,(idl,patl,res)) as br) =
if List.exists (fun id -> Id.compare id x_id == 0) idl
@@ -522,11 +458,10 @@ exception NotUnifiable
let rec are_unifiable_aux = function
| [] -> ()
- | eq::eqs ->
- let open CAst in
- match eq with
- | { v = PatVar _ },_ | _, { v = PatVar _ } -> are_unifiable_aux eqs
- | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } ->
+ | (l, r) ::eqs ->
+ match DAst.get l, DAst.get r with
+ | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs
+ | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) ->
if not (eq_constructor constructor2 constructor1)
then raise NotUnifiable
else
@@ -545,11 +480,10 @@ let are_unifiable pat1 pat2 =
let rec eq_cases_pattern_aux = function
| [] -> ()
- | eq::eqs ->
- let open CAst in
- match eq with
- | { v = PatVar _ }, { v = PatVar _ } -> eq_cases_pattern_aux eqs
- | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } ->
+ | (l, r) ::eqs ->
+ match DAst.get l, DAst.get r with
+ | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs
+ | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) ->
if not (eq_constructor constructor2 constructor1)
then raise NotUnifiable
else
@@ -569,7 +503,7 @@ let eq_cases_pattern pat1 pat2 =
let ids_of_pat =
- let rec ids_of_pat ids = CAst.with_val (function
+ let rec ids_of_pat ids = DAst.with_val (function
| PatVar Anonymous -> ids
| PatVar(Name id) -> Id.Set.add id ids
| PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl
@@ -577,112 +511,21 @@ let ids_of_pat =
in
ids_of_pat Id.Set.empty
-let id_of_name = function
- | Anonymous -> Id.of_string "x"
- | Name x -> x
-
-(* TODO: finish Rec caes *)
-let ids_of_glob_constr c =
- let rec ids_of_glob_constr acc {loc; CAst.v = c} =
- let idof = id_of_name in
- match c with
- | GVar id -> id::acc
- | GApp (g,args) ->
- ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc
- | GLambda (na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
- | GProd (na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
- | GLetIn (na,b,t,c) -> idof na :: ids_of_glob_constr [] b @ Option.cata (ids_of_glob_constr []) [] t @ ids_of_glob_constr [] c @ acc
- | GCast (c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
- | GCast (c,CastCoerce) -> ids_of_glob_constr [] c @ acc
- | GIf (c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc
- | GLetTuple (nal,(na,po),b,c) ->
- List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
- | GCases (sty,rtntypopt,tml,brchl) ->
- List.flatten (List.map (fun (_,(idl,patl,c)) -> idl @ ids_of_glob_constr [] c) brchl)
- | GRec _ -> failwith "Fix inside a constructor branch"
- | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> []
- in
- (* build the set *)
- List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c)
-
-
-
-
-
-let zeta_normalize =
- let rec zeta_normalize_term x = CAst.map (function
- | GRef _
- | GVar _
- | GEvar _
- | GPatVar _ as rt -> rt
- | GApp(rt',rtl) ->
- GApp(zeta_normalize_term rt',
- List.map zeta_normalize_term rtl
- )
- | GLambda(name,k,t,b) ->
- GLambda(name,
- k,
- zeta_normalize_term t,
- zeta_normalize_term b
- )
- | GProd(name,k,t,b) ->
- GProd(name,
- k,
- zeta_normalize_term t,
- zeta_normalize_term b
- )
- | GLetIn(Name id,def,typ,b) ->
- (zeta_normalize_term (replace_var_by_term id def b)).CAst.v
- | GLetIn(Anonymous,def,typ,b) ->
- (zeta_normalize_term b).CAst.v
- | GLetTuple(nal,(na,rto),def,b) ->
- GLetTuple(nal,
- (na,Option.map zeta_normalize_term rto),
- zeta_normalize_term def,
- zeta_normalize_term b
- )
- | GCases(sty,infos,el,brl) ->
- GCases(sty,
- infos,
- List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
- List.map zeta_normalize_br brl
- )
- | GIf(b,(na,e_option),lhs,rhs) ->
- GIf(zeta_normalize_term b,
- (na,Option.map zeta_normalize_term e_option),
- zeta_normalize_term lhs,
- zeta_normalize_term rhs
- )
- | GRec _ -> raise (UserError(None,str "Not handled GRec"))
- | GSort _
- | GHole _ as rt -> rt
- | GCast(b,c) ->
- GCast(zeta_normalize_term b,
- Miscops.map_cast_type zeta_normalize_term c)
- ) x
- and zeta_normalize_br (loc,(idl,patl,res)) =
- (loc,(idl,patl,zeta_normalize_term res))
- in
- zeta_normalize_term
-
-
-
-
let expand_as =
- let rec add_as map ({loc; CAst.v = pat } as rt) =
- match pat with
+ let rec add_as map rt =
+ match DAst.get rt with
| PatVar _ -> map
| PatCstr(_,patl,Name id) ->
Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl)
| PatCstr(_,patl,_) -> List.fold_left add_as map patl
in
- let rec expand_as map = CAst.map (function
+ let rec expand_as map = DAst.map (function
| GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt
| GVar id as rt ->
begin
try
- (Id.Map.find id map).CAst.v
+ DAst.get (Id.Map.find id map)
with Not_found -> rt
end
| GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args)
@@ -702,6 +545,7 @@ let expand_as =
| GCases(sty,po,el,brl) ->
GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
List.map (expand_as_br map) brl)
+ | GProj(p,c) -> GProj(p, expand_as map c)
)
and expand_as_br map (loc,(idl,cpl,rt)) =
(loc,(idl,cpl, expand_as (List.fold_left add_as map cpl) rt))
@@ -718,12 +562,12 @@ let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expect
(* we first (pseudo) understand [rt] and get back the computed evar_map *)
(* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed.
If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *)
- let ctx,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in
+ let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in
let ctx, f = Evarutil.nf_evars_and_universes ctx in
(* then we map [rt] to replace the implicit holes by their values *)
let rec change rt =
- match rt.CAst.v with
+ match DAst.get rt with
| GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *)
(
try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *)
@@ -743,7 +587,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas
match evi.evar_body with
| Evar_defined c ->
(* we just have to lift the solution in glob_term *)
- Detyping.detype false [] env ctx (EConstr.of_constr (f c))
+ Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c))
| Evar_empty -> rt (* the hole was not solved : we do nothing *)
)
| (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *)
@@ -765,7 +609,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas
match evi.evar_body with
| Evar_defined c ->
(* we just have to lift the solution in glob_term *)
- Detyping.detype false [] env ctx (EConstr.of_constr (f c))
+ Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c))
| Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *)
in
res
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 03:13:28 +0000