diff options
| author | Matthieu Sozeau | 2017-08-24 15:50:47 +0200 |
|---|---|---|
| committer | Pierre-Marie Pédrot | 2017-10-17 12:50:44 +0200 |
| commit | d21586b1355cbc178ffeb066392a9ef86d5184d2 (patch) | |
| tree | 4d873f479cd04f367b984c44751d7b8a5c151891 | |
| parent | 1a58e205e79ca2fd0a40b014e929c180e5ff57eb (diff) | |
unification: fix BZ#5692, recognize prim projs as CS projections
| -rw-r--r-- | pretyping/recordops.ml | 20 | ||||
| -rw-r--r-- | pretyping/unification.ml | 8 |
2 files changed, 21 insertions, 7 deletions
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 26b16c039b..e970a1db90 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -329,15 +329,25 @@ let declare_canonical_structure ref = let lookup_canonical_conversion (proj,pat) = assoc_pat pat (Refmap.find proj !object_table) +let decompose_projection sigma c args = + match EConstr.kind sigma c with + | Const (c, u) -> + let n = find_projection_nparams (ConstRef c) in + (** Check if there is some canonical projection attached to this structure *) + let _ = Refmap.find (ConstRef c) !object_table in + let arg = Stack.nth args n in + arg + | Proj (p, c) -> + let _ = Refmap.find (ConstRef (Projection.constant p)) !object_table in + c + | _ -> raise Not_found + let is_open_canonical_projection env sigma (c,args) = let open EConstr in try - let (ref, _) = Termops.global_of_constr sigma c in - let n = find_projection_nparams ref in - (** Check if there is some canonical projection attached to this structure *) - let _ = Refmap.find ref !object_table in + let arg = decompose_projection sigma c args in try - let arg = whd_all env sigma (Stack.nth args n) in + let arg = whd_all env sigma arg in let hd = match EConstr.kind sigma arg with App (hd, _) -> hd | _ -> arg in not (isConstruct sigma hd) with Failure _ -> false diff --git a/pretyping/unification.ml b/pretyping/unification.ml index d52c3932df..e8f7e2bbaf 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -501,6 +501,10 @@ let expand_key ts env sigma = function in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red | None -> None +let isApp_or_Proj sigma c = + match kind sigma c with + | App _ | Proj _ -> true + | _ -> false type unirec_flags = { at_top: bool; @@ -1020,7 +1024,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = - if isApp sigma cM then + if isApp_or_Proj sigma cM then let f1l1 = whd_nored_state sigma (cM,Stack.empty) in if is_open_canonical_projection curenv sigma f1l1 then let f2l2 = whd_nored_state sigma (cN,Stack.empty) in @@ -1036,7 +1040,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e error_cannot_unify (fst curenvnb) sigma (cM,cN) else try f1 () with e when precatchable_exception e -> - if isApp sigma cN then + if isApp_or_Proj sigma cN then let f2l2 = whd_nored_state sigma (cN, Stack.empty) in if is_open_canonical_projection curenv sigma f2l2 then let f1l1 = whd_nored_state sigma (cM, Stack.empty) in |