aboutsummaryrefslogtreecommitdiff
path: root/pretyping/patternops.ml
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping/patternops.ml')
-rw-r--r--pretyping/patternops.ml125
1 files changed, 65 insertions, 60 deletions
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 79e9c727d7..c36542aebc 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -14,13 +14,11 @@ open Nameops
open Term
open Vars
open Glob_term
-open Glob_ops
open Pp
open Mod_subst
open Misctypes
open Decl_kinds
open Pattern
-open Evd
open Environ
let case_info_pattern_eq i1 i2 =
@@ -44,8 +42,9 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with
Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2
| PProd (v1, t1, b1), PProd (v2, t2, b2) ->
Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2
-| PLetIn (v1, t1, b1), PLetIn (v2, t2, b2) ->
- Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2
+| PLetIn (v1, b1, t1, c1), PLetIn (v2, b2, t2, c2) ->
+ Name.equal v1 v2 && constr_pattern_eq b1 b2 &&
+ Option.equal constr_pattern_eq t1 t2 && constr_pattern_eq c1 c2
| PSort s1, PSort s2 -> Miscops.glob_sort_eq s1 s2
| PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2
| PIf (t1, l1, r1), PIf (t2, l2, r2) ->
@@ -85,7 +84,8 @@ let rec occur_meta_pattern = function
| PProj (_,arg) -> occur_meta_pattern arg
| PLambda (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c)
| PProd (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c)
- | PLetIn (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c)
+ | PLetIn (na,b,t,c) ->
+ Option.fold_left (fun b t -> b || occur_meta_pattern t) (occur_meta_pattern b) t || (occur_meta_pattern c)
| PIf (c,c1,c2) ->
(occur_meta_pattern c) ||
(occur_meta_pattern c1) || (occur_meta_pattern c2)
@@ -101,7 +101,7 @@ exception BoundPattern;;
let rec head_pattern_bound t =
match t with
| PProd (_,_,b) -> head_pattern_bound b
- | PLetIn (_,_,b) -> head_pattern_bound b
+ | PLetIn (_,_,_,b) -> head_pattern_bound b
| PApp (c,args) -> head_pattern_bound c
| PIf (c,_,_) -> head_pattern_bound c
| PCase (_,p,c,br) -> head_pattern_bound c
@@ -112,14 +112,14 @@ let rec head_pattern_bound t =
-> raise BoundPattern
(* Perhaps they were arguments, but we don't beta-reduce *)
| PLambda _ -> raise BoundPattern
- | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type")
+ | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.")
-let head_of_constr_reference c = match kind_of_term c with
+let head_of_constr_reference sigma c = match EConstr.kind sigma c with
| Const (sp,_) -> ConstRef sp
| Construct (sp,_) -> ConstructRef sp
| Ind (sp,_) -> IndRef sp
| Var id -> VarRef id
- | _ -> anomaly (Pp.str "Not a rigid reference")
+ | _ -> anomaly (Pp.str "Not a rigid reference.")
let pattern_of_constr env sigma t =
let rec pattern_of_constr env t =
@@ -132,7 +132,7 @@ let pattern_of_constr env sigma t =
| Sort (Prop Pos) -> PSort GSet
| Sort (Type _) -> PSort (GType [])
| Cast (c,_,_) -> pattern_of_constr env c
- | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,
+ | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,Some (pattern_of_constr env t),
pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b)
| Prod (na,c,b) -> PProd (na,pattern_of_constr env c,
pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
@@ -143,7 +143,7 @@ let pattern_of_constr env sigma t =
match kind_of_term f with
| Evar (evk,args) ->
(match snd (Evd.evar_source evk sigma) with
- Evar_kinds.MatchingVar (true,id) -> Some id
+ Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar id) -> Some id
| _ -> None)
| _ -> None
with
@@ -153,20 +153,18 @@ let pattern_of_constr env sigma t =
| Ind (sp,u) -> PRef (canonical_gr (IndRef sp))
| Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp))
| Proj (p, c) ->
- pattern_of_constr env (Retyping.expand_projection env sigma p c [])
+ pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) []))
| Evar (evk,ctxt as ev) ->
(match snd (Evd.evar_source evk sigma) with
- | Evar_kinds.MatchingVar (b,id) ->
- let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in
- let () = ignore (pattern_of_constr env ty) in
- assert (not b); PMeta (Some id)
+ | Evar_kinds.MatchingVar (Evar_kinds.FirstOrderPatVar id) ->
+ PMeta (Some id)
| Evar_kinds.GoalEvar | Evar_kinds.VarInstance _ ->
(* These are the two evar kinds used for existing goals *)
(* see Proofview.mark_in_evm *)
- PEvar (evk,Array.map (pattern_of_constr env) ctxt)
+ if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value sigma ev)
+ else PEvar (evk,Array.map (pattern_of_constr env) ctxt)
+ | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false
| _ ->
- let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in
- let () = ignore (pattern_of_constr env ty) in
PMeta None)
| Case (ci,p,a,br) ->
let cip =
@@ -191,7 +189,7 @@ let map_pattern_with_binders g f l = function
| PSoApp (n,pl) -> PSoApp (n, List.map (f l) pl)
| PLambda (n,a,b) -> PLambda (n,f l a,f (g n l) b)
| PProd (n,a,b) -> PProd (n,f l a,f (g n l) b)
- | PLetIn (n,a,b) -> PLetIn (n,f l a,f (g n l) b)
+ | PLetIn (n,a,t,b) -> PLetIn (n,f l a,Option.map (f l) t,f (g n l) b)
| PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2)
| PCase (ci,po,p,pl) ->
PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl)
@@ -206,11 +204,13 @@ let error_instantiate_pattern id l =
| [_] -> "is"
| _ -> "are"
in
- errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id
+ user_err (str "Cannot substitute the term bound to " ++ pr_id id
++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l
++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.")
let instantiate_pattern env sigma lvar c =
+ let open EConstr in
+ let open Vars in
let rec aux vars = function
| PVar id as x ->
(try
@@ -222,14 +222,16 @@ let instantiate_pattern env sigma lvar c =
ctx
in
let c = substl inst c in
- pattern_of_constr env sigma c
+ (** FIXME: Stupid workaround to pattern_of_constr being evar sensitive *)
+ let c = Evarutil.nf_evar sigma c in
+ pattern_of_constr env sigma (EConstr.Unsafe.to_constr c)
with Not_found (* List.index failed *) ->
let vars =
List.map_filter (function Name id -> Some id | _ -> None) vars in
error_instantiate_pattern id (List.subtract Id.equal ctx vars)
with Not_found (* Map.find failed *) ->
x)
- | (PFix _ | PCoFix _) -> error ("Non instantiable pattern.")
+ | (PFix _ | PCoFix _) -> user_err Pp.(str "Non instantiable pattern.")
| c ->
map_pattern_with_binders (fun id vars -> id::vars) aux vars c in
aux [] c
@@ -276,11 +278,12 @@ let rec subst_pattern subst pat =
let c2' = subst_pattern subst c2 in
if c1' == c1 && c2' == c2 then pat else
PProd (name,c1',c2')
- | PLetIn (name,c1,c2) ->
+ | PLetIn (name,c1,t,c2) ->
let c1' = subst_pattern subst c1 in
+ let t' = Option.smartmap (subst_pattern subst) t in
let c2' = subst_pattern subst c2 in
- if c1' == c1 && c2' == c2 then pat else
- PLetIn (name,c1',c2')
+ if c1' == c1 && t' == t && c2' == c2 then pat else
+ PLetIn (name,c1',t',c2')
| PSort _
| PMeta _ -> pat
| PIf (c,c1,c2) ->
@@ -317,51 +320,52 @@ let rec subst_pattern subst pat =
let mkPLambda na b = PLambda(na,PMeta None,b)
let rev_it_mkPLambda = List.fold_right mkPLambda
-let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp)
+let err ?loc pp = user_err ?loc ~hdr:"pattern_of_glob_constr" pp
let warn_cast_in_pattern =
CWarnings.create ~name:"cast-in-pattern" ~category:"automation"
(fun () -> Pp.strbrk "Casts are ignored in patterns")
-let rec pat_of_raw metas vars = function
- | GVar (_,id) ->
+let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
+ | GVar id ->
(try PRel (List.index Name.equal (Name id) vars)
with Not_found -> PVar id)
- | GPatVar (_,(false,n)) ->
+ | GPatVar (Evar_kinds.FirstOrderPatVar n) ->
metas := n::!metas; PMeta (Some n)
- | GRef (_,gr,_) ->
+ | GRef (gr,_) ->
PRef (canonical_gr gr)
(* Hack to avoid rewriting a complete interpretation of patterns *)
- | GApp (_, GPatVar (_,(true,n)), cl) ->
+ | GApp ({ CAst.v = GPatVar (Evar_kinds.SecondOrderPatVar n) }, cl) ->
metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
- | GApp (_,c,cl) ->
+ | GApp (c,cl) ->
PApp (pat_of_raw metas vars c,
Array.of_list (List.map (pat_of_raw metas vars) cl))
- | GLambda (_,na,bk,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ | GLambda (na,bk,c1,c2) ->
+ Name.iter (fun n -> metas := n::!metas) na;
PLambda (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
- | GProd (_,na,bk,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ | GProd (na,bk,c1,c2) ->
+ Name.iter (fun n -> metas := n::!metas) na;
PProd (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
- | GLetIn (_,na,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ | GLetIn (na,c1,t,c2) ->
+ Name.iter (fun n -> metas := n::!metas) na;
PLetIn (na, pat_of_raw metas vars c1,
+ Option.map (pat_of_raw metas vars) t,
pat_of_raw metas (na::vars) c2)
- | GSort (_,s) ->
+ | GSort s ->
PSort s
| GHole _ ->
PMeta None
- | GCast (_,c,_) ->
+ | GCast (c,_) ->
warn_cast_in_pattern ();
pat_of_raw metas vars c
- | GIf (_,c,(_,None),b1,b2) ->
+ | GIf (c,(_,None),b1,b2) ->
PIf (pat_of_raw metas vars c,
pat_of_raw metas vars b1,pat_of_raw metas vars b2)
- | GLetTuple (loc,nal,(_,None),b,c) ->
- let mkGLambda na c =
- GLambda (loc,na,Explicit,GHole (loc,Evar_kinds.InternalHole, IntroAnonymous, None),c) in
+ | GLetTuple (nal,(_,None),b,c) ->
+ let mkGLambda na c = CAst.make ?loc @@
+ GLambda (na,Explicit, CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in
let c = List.fold_right mkGLambda nal c in
let cip =
{ cip_style = LetStyle;
@@ -372,24 +376,24 @@ let rec pat_of_raw metas vars = function
let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in
PCase (cip, PMeta None, pat_of_raw metas vars b,
[0,tags,pat_of_raw metas vars c])
- | GCases (loc,sty,p,[c,(na,indnames)],brs) ->
+ | GCases (sty,p,[c,(na,indnames)],brs) ->
let get_ind = function
- | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
+ | (_,(_,[{ CAst.v = PatCstr((ind,_),_,_) }],_))::_ -> Some ind
| _ -> None
in
let ind_tags,ind = match indnames with
- | Some (_,ind,nal) -> Some (List.length nal), Some ind
+ | Some (_,(ind,nal)) -> Some (List.length nal), Some ind
| None -> None, get_ind brs
in
let ext,brs = pats_of_glob_branches loc metas vars ind brs
in
let pred = match p,indnames with
- | Some p, Some (_,_,nal) ->
+ | Some p, Some (_,(_,nal)) ->
let nvars = na :: List.rev nal @ vars in
rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p))
- | (None | Some (GHole _)), _ -> PMeta None
+ | (None | Some { CAst.v = GHole _}), _ -> PMeta None
| Some p, None ->
- user_err_loc (loc,"",strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.")
+ user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.")
in
let info =
{ cip_style = sty;
@@ -402,26 +406,27 @@ let rec pat_of_raw metas vars = function
one non-trivial branch. These facts are used in [Constrextern]. *)
PCase (info, pred, pat_of_raw metas vars c, brs)
- | r -> err (loc_of_glob_constr r) (Pp.str "Non supported pattern.")
+ | r -> err ?loc (Pp.str "Non supported pattern.")
+ )
and pats_of_glob_branches loc metas vars ind brs =
let get_arg = function
- | PatVar(_,na) ->
- name_iter (fun n -> metas := n::!metas) na;
+ | { CAst.v = PatVar na } ->
+ Name.iter (fun n -> metas := n::!metas) na;
na
- | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.")
+ | { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.")
in
let rec get_pat indexes = function
| [] -> false, []
- | [(_,_,[PatVar(_,Anonymous)],GHole _)] -> true, [] (* ends with _ => _ *)
- | (_,_,[PatCstr(_,(indsp,j),lv,_)],br) :: brs ->
+ | [(_,(_,[{ CAst.v = PatVar Anonymous }], { CAst.v = GHole _}))] -> true, [] (* ends with _ => _ *)
+ | (_,(_,[{ CAst.v = PatCstr((indsp,j),lv,_) }],br)) :: brs ->
let () = match ind with
| Some sp when eq_ind sp indsp -> ()
| _ ->
- err loc (Pp.str "All constructors must be in the same inductive type.")
+ err ?loc (Pp.str "All constructors must be in the same inductive type.")
in
if Int.Set.mem (j-1) indexes then
- err loc
+ err ?loc
(str "No unique branch for " ++ int j ++ str"-th constructor.");
let lna = List.map get_arg lv in
let vars' = List.rev lna @ vars in
@@ -429,7 +434,7 @@ and pats_of_glob_branches loc metas vars ind brs =
let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in
let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in
ext, ((j-1, tags, pat) :: pats)
- | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.")
+ | (loc,(_,_,_)) :: _ -> err ?loc (Pp.str "Non supported pattern.")
in
get_pat Int.Set.empty brs
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 13:51:05 +0000