[commit: ghc] ghc-8.6: Fix a typo in TcValidity.checkFamInstRhs (047c17a)

[git at git.haskell.org]

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

On branch  : ghc-8.6
Link       : http://ghc.haskell.org/trac/ghc/changeset/047c17a42f97fbd5df972b2c322b0ad0c6f9fdcd/ghc

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

commit 047c17a42f97fbd5df972b2c322b0ad0c6f9fdcd
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Aug 22 10:00:20 2018 +0100

    Fix a typo in TcValidity.checkFamInstRhs
    
    In error message generation we were using the wrong
    type constructor in inst_head.  Result: the type became
    ill-kinded, and that sent the compiler into a loop.
    
    A separate patch fixes the loop. This patch fixes the
    actual bug -- Trac #15473.
    
    I also improved the "occurs more often" error message
    a bit.  But it's still pretty terrible:
    
        * Variable ‘a’ occurs more often
          in the type family application ‘Undefined’
          than in the instance head ‘LetInterleave xs t ts is y z’
    
    It looks like nonsense, but all becomes clear if you use
    -fprint-explicit-kinds.  Really we should fix this by spotting
    when invisible arguments are involved and at least suggesting
    -fprint-explicit-kinds.
    
    (cherry picked from commit 8c7f90abcc1e8f9f29b751f23174e8db89ba6983)


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

047c17a42f97fbd5df972b2c322b0ad0c6f9fdcd
 compiler/typecheck/TcValidity.hs                   | 24 +++++++++++++---------
 .../tests/typecheck/should_compile/T15473.stderr   |  8 ++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  2 +-
 3 files changed, 23 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 7c6db0e..9f1c95d 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -60,7 +60,7 @@ import Unique      ( mkAlphaTyVarUnique )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
-import Data.List        ( (\\) )
+import Data.List        ( (\\), nub )
 import qualified Data.List.NonEmpty as NE
 
 {-
@@ -1441,13 +1441,14 @@ smallerMsg what inst_head
 
 noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc
 noMoreMsg tvs what inst_head
-  = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)
+  = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1)
                 <+> occurs <+> text "more often")
               2 (sep [ text "in the" <+> what
                      , text "than in the instance head" <+> quotes inst_head ])
          , parens undecidableMsg ]
   where
-   occurs = if isSingleton tvs then text "occurs"
+   tvs1   = nub tvs
+   occurs = if isSingleton tvs1 then text "occurs"
                                else text "occur"
 
 undecidableMsg, constraintKindsMsg :: SDoc
@@ -1799,22 +1800,25 @@ checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc
 checkFamInstRhs :: TyCon -> [Type]         -- LHS
                 -> [(TyCon, [Type])]       -- type family calls in RHS
                 -> [MsgDoc]
-checkFamInstRhs tc lhsTys famInsts
+checkFamInstRhs lhs_tc lhs_tys famInsts
   = mapMaybe check famInsts
   where
-   lhs_size = sizeTyConAppArgs tc lhsTys
-   fvs      = fvTypes lhsTys
+   lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys
+   inst_head = pprType (TyConApp lhs_tc lhs_tys)
+   lhs_fvs   = fvTypes lhs_tys
    check (tc, tys)
       | not (all isTyFamFree tys) = Just (nestedMsg what)
       | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what inst_head)
       | lhs_size <= fam_app_size  = Just (smallerMsg what inst_head)
       | otherwise                 = Nothing
       where
-        what         = text "type family application"
-                       <+> quotes (pprType (TyConApp tc tys))
-        inst_head    = pprType (TyConApp tc lhsTys)
-        bad_tvs      = fvTypes tys \\ fvs
+        what = text "type family application"
+               <+> quotes (pprType (TyConApp tc tys))
         fam_app_size = sizeTyConAppArgs tc tys
+        bad_tvs      = fvTypes tys \\ lhs_fvs
+                       -- The (\\) is list difference; e.g.
+                       --   [a,b,a,a] \\ [a,a] = [b,a]
+                       -- So we are counting repetitions
 
 checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar]
                   -> [Type]   -- ^ patterns the user wrote
diff --git a/testsuite/tests/typecheck/should_compile/T15473.stderr b/testsuite/tests/typecheck/should_compile/T15473.stderr
new file mode 100644
index 0000000..6fdeaa1
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T15473.stderr
@@ -0,0 +1,8 @@
+
+T15473.hs:11:3: error:
+    • Variable ‘a’ occurs more often
+        in the type family application ‘Undefined’
+        than in the instance head ‘LetInterleave xs t ts is y z’
+      (Use UndecidableInstances to permit this)
+    • In the equations for closed type family ‘LetInterleave’
+      In the type family declaration for ‘LetInterleave’
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 6e0398d..173a7e5 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -646,4 +646,4 @@ test('T15428', normal, compile, [''])
 test('T15431', normal, compile, [''])
 test('T15431a', normal, compile, [''])
 test('T15412', normal, compile, [''])
-test('T15473', expect_broken(15473), compile, [''])
+test('T15473', normal, compile_fail, [''])