Clean up the conflicting data family instances error message

Summary:
The way we were pretty-printing conflicting data family
instances in an error message was far from ideal:

1. If a data type had no constructors, it would print an equals sign
   with nothing to the right of it.
2. It would try to print GADTs using Haskell98 syntax.
3. It eta-reduced away some type variables from the LHS.

This patch addresses these three issues:

1. We no longer print constructors at all in this error message.
   There's really no reason to do so in the first place, since
   duplicate data family instances always conflict, regardless of
   their constructors.
2. Since we no longer print constructors, we no longer have to
   worry about whether we're using GADT or Haskell98 syntax.
3. I've put in a fix to ensure that type variables are no longer
   eta-reduced away from the LHS.

Test Plan: make test TEST=T14179

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14179

Differential Revision: https://phabricator.haskell.org/D4711

1 files changed, 26 insertions, 7 deletions

diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index 3a3231d270..d0c5eeda69 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -169,18 +169,22 @@ Defined here to avoid module loops. CoAxiom is loaded very early on.
 pprCoAxiom :: CoAxiom br -> SDoc
 pprCoAxiom ax@(CoAxiom { co_ax_branches = branches })
   = hang (text "axiom" <+> ppr ax <+> dcolon)
-       2 (vcat (map (ppr_co_ax_branch (const pprType) ax) $ fromBranches branches))
+       2 (vcat (map (ppr_co_ax_branch (\_ ty -> equals <+> pprType ty) ax) $
+                    fromBranches branches))
 
 pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
 pprCoAxBranch = ppr_co_ax_branch pprRhs
   where
     pprRhs fam_tc rhs
-      | Just (tycon, _) <- splitTyConApp_maybe rhs
-      , isDataFamilyTyCon fam_tc
-      = pprDataCons tycon
+      | isDataFamilyTyCon fam_tc
+      = empty -- Don't bother printing anything for the RHS of a data family
+              -- instance...
 
       | otherwise
-      = ppr rhs
+      = equals <+> ppr rhs
+              -- ...but for a type family instance, do print out the RHS, since
+              -- it might be needed to disambiguate between duplicate instances
+              -- (#14179)
 
 pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc
 pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index)
@@ -194,8 +198,8 @@ ppr_co_ax_branch ppr_rhs
                           , cab_rhs = rhs
                           , cab_loc = loc })
   = foldr1 (flip hangNotEmpty 2)
-        [ pprUserForAll (mkTyVarBinders Inferred (tvs ++ cvs))
-        , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs
+        [ pprUserForAll (mkTyVarBinders Inferred (ee_tvs ++ cvs))
+        , pprTypeApp fam_tc ee_lhs <+> ppr_rhs fam_tc rhs
         , text "-- Defined" <+> pprLoc loc ]
   where
         pprLoc loc
@@ -206,6 +210,21 @@ ppr_co_ax_branch ppr_rhs
           = text "in" <+>
               quotes (ppr (nameModule name))
 
+        (ee_tvs, ee_lhs)
+          | Just (tycon, tc_args) <- splitTyConApp_maybe rhs
+          , isDataFamilyTyCon fam_tc
+          = -- Eta-expand LHS types, because sometimes data family instances
+            -- are eta-reduced.
+            -- See Note [Eta reduction for data family axioms] in TcInstDecls.
+            let tc_tvs           = tyConTyVars tycon
+                etad_tvs         = dropList tc_args tc_tvs
+                etad_tys         = mkTyVarTys etad_tvs
+                eta_expanded_tvs = tvs `chkAppend` etad_tvs
+                eta_expanded_lhs = lhs `chkAppend` etad_tys
+            in (eta_expanded_tvs, eta_expanded_lhs)
+          | otherwise
+          = (tvs, lhs)
+
 {-
 %************************************************************************
 %*                                                                      *