From b0e52bbbc52691343b3fab927b20c1f512f59976 Mon Sep 17 00:00:00 2001
From: Pierre Letouzey <pierre.letouzey@inria.fr>
Date: Fri, 21 Jul 2017 12:02:36 +0200
Subject: Extraction: reduce primitive projections in types (fix bug 4709)

---
 API/API.mli                      | 2 ++
 plugins/extraction/extraction.ml | 6 +++++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/API/API.mli b/API/API.mli
index bb24d5768..d136deb70 100644
--- a/API/API.mli
+++ b/API/API.mli
@@ -169,6 +169,8 @@ sig
     val map : (Constant.t -> Constant.t) -> t -> t
     val constant : t -> Constant.t
     val equal : t -> t -> bool
+    val unfolded : t -> bool
+    val unfold : t -> t
   end
 
   type evaluable_global_reference =
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 3661faada..996df1a47 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -295,7 +295,11 @@ let rec extract_type env db j c args =
     | Ind ((kn,i),u) ->
 	let s = (extract_ind env kn).ind_packets.(i).ip_sign in
 	extract_type_app env db (IndRef (kn,i),s) args
-    | Case _ | Fix _ | CoFix _ | Proj _ -> Tunknown
+    | Proj (p,t) ->
+       (* Let's try to reduce, if it hasn't already been done. *)
+       if Projection.unfolded p then Tunknown
+       else extract_type env db j (Term.mkProj (Projection.unfold p, t)) args
+    | Case _ | Fix _ | CoFix _ -> Tunknown
     | _ -> assert false
 
 (*s Auxiliary function dealing with type application.
-- 
cgit v1.2.3


From dc38423a70e63206f8c4127182d3f2d703025a0d Mon Sep 17 00:00:00 2001
From: Pierre Letouzey <pierre.letouzey@inria.fr>
Date: Wed, 26 Jul 2017 19:38:57 +0200
Subject: adding a test-suite file 4709.v (thanks to the new command Extraction
 TestCompile)

---
 test-suite/bugs/closed/4709.v | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)
 create mode 100644 test-suite/bugs/closed/4709.v

diff --git a/test-suite/bugs/closed/4709.v b/test-suite/bugs/closed/4709.v
new file mode 100644
index 000000000..a9edcc804
--- /dev/null
+++ b/test-suite/bugs/closed/4709.v
@@ -0,0 +1,18 @@
+
+(** Bug 4709 https://coq.inria.fr/bug/4709
+    Extraction wasn't reducing primitive projections in types. *)
+
+Require Extraction.
+
+Set Primitive Projections.
+
+Record t := Foo { foo : Type }.
+Definition ty := foo (Foo nat).
+
+(* Without proper reduction of primitive projections in
+   [extract_type], the type [ty] was extracted as [Tunknown].
+   Let's check it isn't the case anymore. *)
+
+Parameter check : nat.
+Extract Constant check => "(O:ty)".
+Extraction TestCompile ty check.
-- 
cgit v1.2.3