[commit: ghc] master: Take type-function arity into account (a008ead)

[git at git.haskell.org]

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

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

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

commit a008eadfaa4816be349b4fefde9b9b9edc1ca359
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Feb 18 12:52:18 2016 +0000

    Take type-function arity into account
    
    ...when computing the size of a call on the RHS of a type
    instance declaration.
    
    This came up in Trac #11581.  The change is in
       TcType.tcTyFamInsts
    which now trims the type arguments in a call.  See the
    comments with that function definition.


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

a008eadfaa4816be349b4fefde9b9b9edc1ca359
 compiler/typecheck/TcType.hs                           | 14 ++++++++++++--
 testsuite/tests/indexed-types/should_compile/T11581.hs |  8 ++++++++
 testsuite/tests/indexed-types/should_compile/all.T     |  1 +
 3 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index 8021c75..00b3a0f 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -693,13 +693,23 @@ isSigMaybe _                = Nothing
 -}
 
 -- | Finds outermost type-family applications occuring in a type,
--- after expanding synonyms.
+-- after expanding synonyms.  In the list (F, tys) that is returned
+-- we guarantee that tys matches F's arity.  For example, given
+--    type family F a :: * -> *    (arity 1)
+-- calling tcTyFamInsts on (Maybe (F Int Bool) will return
+--     (F, [Int]), not (F, [Int,Bool])
+--
+-- This is important for its use in deciding termination of type
+-- instances (see Trac #11581).  E.g.
+--    type instance G [Int] = ...(F Int <big type>)...
+-- we don't need to take <big type> into account when asking if
+-- the calls on the RHS are smaller than the LHS
 tcTyFamInsts :: Type -> [(TyCon, [Type])]
 tcTyFamInsts ty
   | Just exp_ty <- coreView ty  = tcTyFamInsts exp_ty
 tcTyFamInsts (TyVarTy _)        = []
 tcTyFamInsts (TyConApp tc tys)
-  | isTypeFamilyTyCon tc        = [(tc, tys)]
+  | isTypeFamilyTyCon tc        = [(tc, take (tyConArity tc) tys)]
   | otherwise                   = concat (map tcTyFamInsts tys)
 tcTyFamInsts (LitTy {})         = []
 tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderType bndr)
diff --git a/testsuite/tests/indexed-types/should_compile/T11581.hs b/testsuite/tests/indexed-types/should_compile/T11581.hs
new file mode 100644
index 0000000..7815a86
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T11581.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T11581 where
+
+type family F a :: * -> *
+type family G a
+
+type instance G [a] = F a (Int,Bool)
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index e97acbf..bee76d2 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -274,3 +274,4 @@ test('T11408', normal, compile, [''])
 test('T11361', normal, compile, ['-dunique-increment=-1'])
   # -dunique-increment=-1 doesn't work inside the file
 test('T11361a', normal, compile_fail, [''])
+test('T11581', normal, compile, [''])