Eta expand data family instances before printing them
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 17 Jan 2014 14:05:35 +0000 (14:05 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 17 Jan 2014 14:06:27 +0000 (14:06 +0000)
Fixes Trac #8674

compiler/types/FamInstEnv.lhs
testsuite/tests/ghci/scripts/T8674.hs [new file with mode: 0644]
testsuite/tests/ghci/scripts/T8674.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T8674.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T

index 01375a3..c17668b 100644 (file)
@@ -178,17 +178,30 @@ pprFamInst famInst
 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr fi@(FamInst {fi_flavor = flavor})
-  = pprTyConSort <+> pp_instance <+> pprHead
+  = pprTyConSort <+> pp_instance <+> pp_head
   where
-    (fam_tc, tys) = famInstSplitLHS fi
-
     -- For *associated* types, say "type T Int = blah"
     -- For *top level* type instances, say "type instance T Int = blah"
     pp_instance
       | isTyConAssoc fam_tc = empty
       | otherwise           = ptext (sLit "instance")
 
-    pprHead = pprTypeApp fam_tc tys
+    (fam_tc, etad_lhs_tys) = famInstSplitLHS fi
+    vanilla_pp_head = pprTypeApp fam_tc etad_lhs_tys
+
+    pp_head | DataFamilyInst rep_tc <- flavor
+            , isAlgTyCon rep_tc
+            , let extra_tvs = dropList etad_lhs_tys (tyConTyVars rep_tc)
+            , not (null extra_tvs)
+            = getPprStyle $ \ sty ->
+              if debugStyle sty
+              then vanilla_pp_head   -- With -dppr-debug just show it as-is
+              else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs)
+                     -- Without -dppr-debug, eta-expand
+                     -- See Trac #8674
+            | otherwise
+            = vanilla_pp_head
+
     pprTyConSort = case flavor of
                      SynFamilyInst        -> ptext (sLit "type")
                      DataFamilyInst tycon
@@ -199,7 +212,6 @@ pprFamInstHdr fi@(FamInst {fi_flavor = flavor})
 
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
-
 \end{code}
 
 Note [Lazy axiom match]
diff --git a/testsuite/tests/ghci/scripts/T8674.hs b/testsuite/tests/ghci/scripts/T8674.hs
new file mode 100644 (file)
index 0000000..da7c7cd
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds #-}
+module T8557 where
+
+data family Sing (a :: k)
+data instance Sing (a :: [k]) = SNil
+data instance Sing Bool = SBool
+
diff --git a/testsuite/tests/ghci/scripts/T8674.script b/testsuite/tests/ghci/scripts/T8674.script
new file mode 100644 (file)
index 0000000..b55e03b
--- /dev/null
@@ -0,0 +1,2 @@
+:l T8674.hs
+:i Sing
diff --git a/testsuite/tests/ghci/scripts/T8674.stdout b/testsuite/tests/ghci/scripts/T8674.stdout
new file mode 100644 (file)
index 0000000..a4f5bbf
--- /dev/null
@@ -0,0 +1,5 @@
+type role Sing nominal
+data family Sing (a :: k)
+       -- Defined at T8674.hs:4:1
+data instance Sing Bool -- Defined at T8674.hs:6:15
+data instance Sing a -- Defined at T8674.hs:5:15
index 1f051c8..a7f6fa1 100755 (executable)
@@ -164,3 +164,4 @@ test('T8639', normal, ghci_script, ['T8639.script'])
 test('T8640', normal, ghci_script, ['T8640.script'])
 test('T8579', normal, ghci_script, ['T8579.script'])
 test('T8649', normal, ghci_script, ['T8649.script'])
+test('T8674', normal, ghci_script, ['T8674.script'])