aboutsummaryrefslogtreecommitdiff
path: root/pretyping/patternops.ml
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping/patternops.ml')
-rw-r--r--pretyping/patternops.ml56
1 files changed, 30 insertions, 26 deletions
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 2090aad8a0..b16d044956 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -44,8 +44,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 +86,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 +103,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
@@ -114,7 +116,7 @@ let rec head_pattern_bound t =
| PLambda _ -> raise BoundPattern
| 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
@@ -132,7 +134,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)
@@ -153,18 +155,14 @@ 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 [])
- | Evar (evk,ctxt as ev) ->
+ pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) []))
+ | Evar (evk,ctxt) ->
(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.GoalEvar ->
PEvar (evk,Array.map (pattern_of_constr env) ctxt)
| _ ->
- 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 =
@@ -189,7 +187,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)
@@ -204,11 +202,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
@@ -220,7 +220,9 @@ 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
@@ -274,11 +276,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) ->
@@ -315,7 +318,7 @@ 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"
@@ -343,9 +346,10 @@ let rec pat_of_raw metas vars = function
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) ->
+ | 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) ->
PSort s
@@ -387,7 +391,7 @@ let rec pat_of_raw metas vars = function
rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p))
| (None | Some (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;
@@ -400,14 +404,14 @@ 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:(loc_of_glob_constr r) (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;
na
- | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.")
+ | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.")
in
let rec get_pat indexes = function
| [] -> false, []
@@ -416,10 +420,10 @@ and pats_of_glob_branches loc metas vars ind 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
@@ -427,7 +431,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-03 20:28:26 +0000