[commit: ghc] master: Eta expand data family instances before printing them (44dc0aa)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/44dc0aad5b14f39b2fbc618626bf2446dddcb78b/ghc

>---------------------------------------------------------------

commit 44dc0aad5b14f39b2fbc618626bf2446dddcb78b
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jan 17 14:05:35 2014 +0000

    Eta expand data family instances before printing them
    
    Fixes Trac #8674


>---------------------------------------------------------------

44dc0aad5b14f39b2fbc618626bf2446dddcb78b
 compiler/types/FamInstEnv.lhs                      |   22 +++++++++++++++-----
 .../scripts/T8557.hs => ghci/scripts/T8674.hs}     |    3 +--
 testsuite/tests/ghci/scripts/T8674.script          |    2 ++
 testsuite/tests/ghci/scripts/T8674.stdout          |    5 +++++
 testsuite/tests/ghci/scripts/all.T                 |    1 +
 5 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 01375a3..c17668b 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -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.debugger/scripts/T8557.hs b/testsuite/tests/ghci/scripts/T8674.hs
similarity index 80%
copy from testsuite/tests/ghci.debugger/scripts/T8557.hs
copy to testsuite/tests/ghci/scripts/T8674.hs
index 6b45f17..da7c7cd 100644
--- a/testsuite/tests/ghci.debugger/scripts/T8557.hs
+++ b/testsuite/tests/ghci/scripts/T8674.hs
@@ -3,6 +3,5 @@ module T8557 where
 
 data family Sing (a :: k)
 data instance Sing (a :: [k]) = SNil
+data instance Sing Bool = SBool
 
-x :: Sing '[]
-x = SNil
diff --git a/testsuite/tests/ghci/scripts/T8674.script b/testsuite/tests/ghci/scripts/T8674.script
new file mode 100644
index 0000000..b55e03b
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8674.script
@@ -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
index 0000000..a4f5bbf
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8674.stdout
@@ -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
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 1f051c8..a7f6fa1 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -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'])