diff options
| -rw-r--r-- | pretyping/recordops.ml | 4 | ||||
| -rw-r--r-- | test-suite/success/CanonicalStructure.v | 7 |
2 files changed, 10 insertions, 1 deletions
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index fa3a61afce..8ca06e9a5f 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -20,6 +20,7 @@ open Libobject open Library open Classops open Mod_subst +open Reductionops (*s A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) @@ -197,7 +198,8 @@ let check_and_decompose_canonical_structure ref = let vc = match Environ.constant_opt_value env sp with | Some vc -> vc | None -> error_not_structure ref in - let f,args = match kind_of_term (snd (decompose_lam vc)) with + let body = snd (splay_lambda (Global.env()) Evd.empty vc) in + let f,args = match kind_of_term body with | App (f,args) -> f,args | _ -> error_not_structure ref in let indsp = match kind_of_term f with diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v index 003810cc20..44d21b83bc 100644 --- a/test-suite/success/CanonicalStructure.v +++ b/test-suite/success/CanonicalStructure.v @@ -5,3 +5,10 @@ Structure foo : Type := Foo { }. Canonical Structure unopt_nat := @Foo nat (fun _ => O). + +(* Granted wish #1187 *) + +Record Silly (X : Set) : Set := mkSilly { x : X }. +Definition anotherMk := mkSilly. +Definition struct := anotherMk nat 3. +Canonical Structure struct. |