Fix a serious bug in roughMatchTcs

The roughMatchTcs function enables a quick definitely-no-match test
in lookupInstEnv.  Unfortunately, it didn't account for type families.
This didn't matter when type families were flattened away, but now
they aren't flattened it matters a lot.

The fix is very easy. See INVARIANT in GHC.Core.InstEnv
Note [ClsInst laziness and the rough-match fields]

Fixes #19336

The change makes compiler perf worse on two very-type-family-heavy
benchmarks, T9872{a,d}:
  T9872a(normal) ghc/alloc  2172536442.7  2216337648.0  +2.0%
  T9872d(normal) ghc/alloc   614584024.0   621081384.0  +1.1%
(Everything else is 0.0% or at most 0.1%.)

I think we just have to put up with this. Some cases were being
wrongly filtered out by roughMatchTcs that might actually match, which
could lead to false apartness checks.  And it only affects these very
type-family-heavy cases.

Metric Increase:
    T9872a
    T9872d

11 files changed, 158 insertions, 71 deletions

diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 3e0fc7361d..187ccf4994 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -104,8 +104,9 @@ data FamInst  -- See Note [FamInsts and CoAxioms]
             , fi_fam   :: Name          -- Family name
 
                 -- Used for "rough matching"; same idea as for class instances
-                -- See Note [Rough-match field] in GHC.Core.InstEnv
-            , fi_tcs   :: [Maybe Name]  -- Top of type args
+                -- See Note [Rough matching in class and family instances]
+                -- in GHC.Core.Unify
+            , fi_tcs   :: [RoughMatchTc]  -- Top of type args
                 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
 
             -- Used for "proper matching"; ditto
@@ -264,7 +265,7 @@ also.
 -- interface file.  In particular, we get the rough match info from the iface
 -- (instead of computing it here).
 mkImportedFamInst :: Name               -- Name of the family
-                  -> [Maybe Name]       -- Rough match info
+                  -> [RoughMatchTc]     -- Rough match info
                   -> CoAxiom Unbranched -- Axiom introduced
                   -> FamInst            -- Resulting family instance
 mkImportedFamInst fam mb_tcs axiom
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 0a5b306705..840465425f 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -49,7 +49,7 @@ import GHC.Types.Basic
 import GHC.Types.Unique.DFM
 import GHC.Types.Id
 import Data.Data        ( Data )
-import Data.Maybe       ( isJust, isNothing )
+import Data.Maybe       ( isJust )
 
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
@@ -70,8 +70,8 @@ data ClsInst
   = ClsInst {   -- Used for "rough matching"; see
                 -- Note [ClsInst laziness and the rough-match fields]
                 -- INVARIANT: is_tcs = roughMatchTcs is_tys
-               is_cls_nm :: Name        -- ^ Class name
-             , is_tcs  :: [Maybe Name]  -- ^ Top of type args
+               is_cls_nm :: Name          -- ^ Class name
+             , is_tcs  :: [RoughMatchTc]  -- ^ Top of type args
 
                -- | @is_dfun_name = idName . is_dfun@.
                --
@@ -107,10 +107,10 @@ fuzzyClsInstCmp x y =
     stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`
     mconcat (map cmp (zip (is_tcs x) (is_tcs y)))
   where
-    cmp (Nothing, Nothing) = EQ
-    cmp (Nothing, Just _) = LT
-    cmp (Just _, Nothing) = GT
-    cmp (Just x, Just y) = stableNameCmp x y
+    cmp (OtherTc,   OtherTc)   = EQ
+    cmp (OtherTc,   KnownTc _) = LT
+    cmp (KnownTc _, OtherTc)   = GT
+    cmp (KnownTc x, KnownTc y) = stableNameCmp x y
 
 isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool
 isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))
@@ -135,25 +135,16 @@ We avoid this as follows:
   pull in interfaces that it refers to. See Note [Proper-match fields].
 
 * Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and
-  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking
+  is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking
   inside the DFunId. The rough-match fields allow us to say "definitely does not
-  match", based only on Names.
+  match", based only on Names.  See GHC.Core.Unify
+  Note [Rough matching in class and family instances]
 
   This laziness is very important; see #12367. Try hard to avoid pulling on
   the structured fields unless you really need the instance.
 
 * Another place to watch is InstEnv.instIsVisible, which needs the module to
   which the ClsInst belongs. We can get this from is_dfun_name.
-
-* In is_tcs,
-    Nothing  means that this type arg is a type variable
-
-    (Just n) means that this type arg is a
-                TyConApp with a type constructor of n.
-                This is always a real tycon, never a synonym!
-                (Two different synonyms might match, but two
-                different real tycons can't.)
-                NB: newtypes are not transparent, though!
 -}
 
 {-
@@ -206,10 +197,9 @@ updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
 updateClsInstDFun tidy_dfun ispec
   = ispec { is_dfun = tidy_dfun (is_dfun ispec) }
 
-instanceRoughTcs :: ClsInst -> [Maybe Name]
+instanceRoughTcs :: ClsInst -> [RoughMatchTc]
 instanceRoughTcs = is_tcs
 
-
 instance NamedThing ClsInst where
    getName ispec = getName (is_dfun ispec)
 
@@ -300,12 +290,12 @@ mkLocalInstance dfun oflag tvs cls tys
 
     choose_one nss = chooseOrphanAnchor (unionNameSets nss)
 
-mkImportedInstance :: Name         -- ^ the name of the class
-                   -> [Maybe Name] -- ^ the types which the class was applied to
-                   -> Name         -- ^ the 'Name' of the dictionary binding
-                   -> DFunId       -- ^ the 'Id' of the dictionary.
-                   -> OverlapFlag  -- ^ may this instance overlap?
-                   -> IsOrphan     -- ^ is this instance an orphan?
+mkImportedInstance :: Name           -- ^ the name of the class
+                   -> [RoughMatchTc] -- ^ the types which the class was applied to
+                   -> Name           -- ^ the 'Name' of the dictionary binding
+                   -> DFunId         -- ^ the 'Id' of the dictionary.
+                   -> OverlapFlag    -- ^ may this instance overlap?
+                   -> IsOrphan       -- ^ is this instance an orphan?
                    -> ClsInst
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
@@ -842,7 +832,6 @@ lookupInstEnv' ie vis_mods cls tys
   = lookup ie
   where
     rough_tcs  = roughMatchTcs tys
-    all_tvs    = all isNothing rough_tcs
 
     --------------
     lookup env = case lookupUDFM env cls of
@@ -871,7 +860,7 @@ lookupInstEnv' ie vis_mods cls tys
 
       | otherwise
       = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,
-                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$
+                 (ppr cls <+> ppr tys) $$
                  (ppr tpl_tvs <+> ppr tpl_tys)
                 )
                 -- Unification will break badly if the variables overlap
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index dbfd4083ad..3b67a0a6f8 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -2,7 +2,7 @@
 
 {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}
 
 module GHC.Core.Unify (
         tcMatchTy, tcMatchTyKi,
@@ -11,8 +11,8 @@ module GHC.Core.Unify (
         tcMatchTyX_BM, ruleMatchTyKiX,
 
         -- * Rough matching
-        roughMatchTcs, instanceCantMatch,
-        typesCantMatch,
+        RoughMatchTc(..), roughMatchTcs, instanceCantMatch,
+        typesCantMatch, isRoughOtherTc,
 
         -- Side-effect free unification
         tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,
@@ -53,6 +53,7 @@ import GHC.Exts( oneShot )
 import GHC.Utils.Panic
 import GHC.Data.FastString
 
+import Data.Data ( Data )
 import Data.List ( mapAccumL )
 import Control.Monad
 import qualified Data.Semigroup as S
@@ -258,26 +259,70 @@ alwaysBindFun _tv _ty = BindMe
 *                                                                      *
 ********************************************************************* -}
 
--- See Note [Rough match] field in GHC.Core.InstEnv
+{- Note [Rough matching in class and family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  instance C (Maybe [Tree a]) Bool
+and suppose we are looking up
+     C Bool Bool
+
+We can very quickly rule the instance out, because the first
+argument is headed by Maybe, whereas in the constraint we are looking
+up has first argument headed by Bool.  These "headed by" TyCons are
+called the "rough match TyCons" of the constraint or instance.
+They are used for a quick filter, to check when an instance cannot
+possibly match.
+
+The main motivation is to avoid sucking in whole instance
+declarations that are utterly useless.  See GHC.Core.InstEnv
+Note [ClsInst laziness and the rough-match fields].
+
+INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon,
+like Maybe or Either, including a newtype or a data family, both of
+which are generative. It replies True to `isGenerativeTyCon tc Nominal`.
+
+But it is never
+    - A type synonym
+      E.g. Int and (S Bool) might match
+           if (S Bool) is a synonym for Int
+
+    - A type family (#19336)
+      E.g.   (Just a) and (F a) might match if (F a) reduces to (Just a)
+             albeit perhaps only after 'a' is instantiated.
+-}
+
+data RoughMatchTc
+  = KnownTc Name   -- INVARIANT: Name refers to a TyCon tc that responds
+                   -- true to `isGenerativeTyCon tc Nominal`. See
+                   -- Note [Rough matching in class and family instances]
+  | OtherTc        -- e.g. type variable at the head
+  deriving( Data )
+
+isRoughOtherTc :: RoughMatchTc -> Bool
+isRoughOtherTc OtherTc      = True
+isRoughOtherTc (KnownTc {}) = False
 
-roughMatchTcs :: [Type] -> [Maybe Name]
+roughMatchTcs :: [Type] -> [RoughMatchTc]
 roughMatchTcs tys = map rough tys
   where
     rough ty
       | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'
-      | Just (tc,_)   <- splitTyConApp_maybe ty = Just (tyConName tc)
-      | otherwise                               = Nothing
+      | Just (tc,_)   <- splitTyConApp_maybe ty
+      , not (isTypeFamilyTyCon tc)              = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc )
+                                                  KnownTc (tyConName tc)
+        -- See Note [Rough matching in class and family instances]
+      | otherwise                               = OtherTc
 
-instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
+instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool
 -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
 -- possibly be instantiated to actual, nor vice versa;
 -- False is non-committal
 instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as
 instanceCantMatch _         _         =  False  -- Safe
 
-itemCantMatch :: Maybe Name -> Maybe Name -> Bool
-itemCantMatch (Just t) (Just a) = t /= a
-itemCantMatch _        _        = False
+itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool
+itemCantMatch (KnownTc t) (KnownTc a) = t /= a
+itemCantMatch _           _           = False
 
 
 {-
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 836c9dc23d..1c43e3e6e6 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -48,6 +48,7 @@ import GHC.Core.Type
 import GHC.Core.Multiplicity
 import GHC.Core.InstEnv
 import GHC.Core.FamInstEnv
+import GHC.Core.Unify( RoughMatchTc(..) )
 
 import GHC.Driver.Env
 import GHC.Driver.Backend
@@ -685,34 +686,25 @@ tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
 instanceToIfaceInst :: ClsInst -> IfaceClsInst
 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
                              , is_cls_nm = cls_name, is_cls = cls
-                             , is_tcs = mb_tcs
+                             , is_tcs = rough_tcs
                              , is_orphan = orph })
   = ASSERT( cls_name == className cls )
-    IfaceClsInst { ifDFun    = dfun_name,
-                ifOFlag   = oflag,
-                ifInstCls = cls_name,
-                ifInstTys = map do_rough mb_tcs,
-                ifInstOrph = orph }
-  where
-    do_rough Nothing  = Nothing
-    do_rough (Just n) = Just (toIfaceTyCon_name n)
-
-    dfun_name = idName dfun_id
-
+    IfaceClsInst { ifDFun     = idName dfun_id
+                 , ifOFlag    = oflag
+                 , ifInstCls  = cls_name
+                 , ifInstTys  = ifaceRoughMatchTcs rough_tcs
+                 , ifInstOrph = orph }
 
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
 famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
                                  fi_fam      = fam,
-                                 fi_tcs      = roughs })
+                                 fi_tcs      = rough_tcs })
   = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom
                  , ifFamInstFam      = fam
-                 , ifFamInstTys      = map do_rough roughs
+                 , ifFamInstTys      = ifaceRoughMatchTcs rough_tcs
                  , ifFamInstOrph     = orph }
   where
-    do_rough Nothing  = Nothing
-    do_rough (Just n) = Just (toIfaceTyCon_name n)
-
     fam_decl = tyConName $ coAxiomTyCon axiom
     mod = ASSERT( isExternalName (coAxiomName axiom) )
           nameModule (coAxiomName axiom)
@@ -725,6 +717,12 @@ famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
          | otherwise
          = chooseOrphanAnchor lhs_names
 
+ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon]
+ifaceRoughMatchTcs tcs = map do_rough tcs
+  where
+    do_rough OtherTc     = Nothing
+    do_rough (KnownTc n) = Just (toIfaceTyCon_name n)
+
 --------------------------
 coreRuleToIfaceRule :: CoreRule -> IfaceRule
 coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index f523d24625..cd97c000a8 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -414,7 +414,7 @@ rnIfaceNeverExported name = do
 rnIfaceClsInst :: Rename IfaceClsInst
 rnIfaceClsInst cls_inst = do
     n <- rnIfaceGlobal (ifInstCls cls_inst)
-    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
+    tys <- mapM rnRoughMatchTyCon (ifInstTys cls_inst)
 
     dfun <- rnIfaceNeverExported (ifDFun cls_inst)
     return cls_inst { ifInstCls = n
@@ -422,14 +422,14 @@ rnIfaceClsInst cls_inst = do
                     , ifDFun = dfun
                     }
 
-rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
-rnMaybeIfaceTyCon Nothing = return Nothing
-rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc
+rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon)
+rnRoughMatchTyCon Nothing = return Nothing
+rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc
 
 rnIfaceFamInst :: Rename IfaceFamInst
 rnIfaceFamInst d = do
     fam <- rnIfaceGlobal (ifFamInstFam d)
-    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
+    tys <- mapM rnRoughMatchTyCon (ifFamInstTys d)
     axiom <- rnIfaceGlobal (ifFamInstAxiom d)
     return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
 
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 0cc11a1bab..5a843c5e7e 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -53,6 +53,7 @@ import GHC.Core.TyCo.Subst ( substTyCoVars )
 import GHC.Core.InstEnv
 import GHC.Core.FamInstEnv
 import GHC.Core
+import GHC.Core.Unify( RoughMatchTc(..) )
 import GHC.Core.Utils
 import GHC.Core.Unfold.Make
 import GHC.Core.Lint
@@ -1145,13 +1146,17 @@ look at it.
 ************************************************************************
 -}
 
+tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc
+tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc)
+tcRoughTyCon Nothing   = OtherTc
+
 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
 tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
                           , ifInstCls = cls, ifInstTys = mb_tcs
                           , ifInstOrph = orph })
   = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
                     fmap tyThingId (tcIfaceImplicit dfun_name)
-       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+       ; let mb_tcs' = map tcRoughTyCon mb_tcs
        ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
@@ -1161,7 +1166,7 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
                      tcIfaceCoAxiom axiom_name
              -- will panic if branched, but that's OK
          ; let axiom'' = toUnbranchedAxiom axiom'
-               mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+               mb_tcs' = map tcRoughTyCon mb_tcs
          ; return (mkImportedFamInst fam mb_tcs' axiom'') }
 
 {-
diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs
index 3abb0140b1..623ed147ff 100644
--- a/compiler/GHC/Tc/Instance/FunDeps.hs
+++ b/compiler/GHC/Tc/Instance/FunDeps.hs
@@ -236,7 +236,7 @@ improveFromInstEnv _ _ _ = []
 
 improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class
              -> ClsInst                    -- An instance template
-             -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate
+             -> [Type] -> [RoughMatchTc]   -- Arguments of this (C tys) predicate
              -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton
 
 improveClsFD clas_tvs fd
@@ -666,7 +666,7 @@ checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls
         --      instance C Int Char Char
         -- The second instance conflicts with the first by *both* fundeps
 
-trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
+trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc]
 -- Computing rough_tcs for a particular fundep
 --     class C a b c | a -> b where ...
 -- For each instance .... => C ta tb tc
@@ -679,4 +679,4 @@ trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs
   = zipWith select clas_tvs mb_tcs
   where
     select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
-                         | otherwise           = Nothing
+                         | otherwise           = OtherTc
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 084a98883d..42f0a3fddc 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -114,6 +114,7 @@ import GHC.Core.DataCon
 import GHC.Core.Type
 import GHC.Core.Class
 import GHC.Core.Coercion.Axiom
+import GHC.Core.Unify( RoughMatchTc(..) )
 import GHC.Core.FamInstEnv
    ( FamInst, pprFamInst, famInstsRepTyCons
    , famInstEnvElts, extendFamInstEnvList, normaliseType )
@@ -1681,7 +1682,7 @@ tcMissingParentClassWarn warnFlag isName shouldName
            -- "<location>: Warning: <type> is an instance of <is> but not
            -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
-                 warnMsg (Just name:_) =
+                 warnMsg (KnownTc name:_) =
                       addWarnAt (Reason warnFlag) instLoc $
                            hsep [ (quotes . ppr . nameOccName) name
                                 , text "is an instance of"
diff --git a/testsuite/tests/indexed-types/should_compile/T19336.hs b/testsuite/tests/indexed-types/should_compile/T19336.hs
new file mode 100644
index 0000000000..dfc7409fa3
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T19336.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances
+           , DataKinds, NoMonomorphismRestriction, UndecidableInstances
+           , TypeFamilies #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+module T19336 where
+
+import GHC.TypeLits
+
+class X a b where
+  convert :: a -> b
+
+instance X Int String where
+  convert = show
+
+instance X String String where
+  convert = id
+
+instance {-# OVERLAPPABLE #-} TypeError ('Text "Oops") => X a b where
+  convert = error "unreachable"
+
+type family F a where
+  F String = String
+  F Int    = String
+
+convert_f :: X a (F a) => a -> a -> F a
+convert_f _ = convert
+
+----------
+
+class Poly a where
+  poly :: a
+
+instance Poly String where
+  poly = "hi"
+
+instance Poly Int where
+  poly = 2
+
+----------
+
+oops = convert_f poly
diff --git a/testsuite/tests/indexed-types/should_compile/T19336.stderr b/testsuite/tests/indexed-types/should_compile/T19336.stderr
new file mode 100644
index 0000000000..f841f79628
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T19336.stderr
@@ -0,0 +1,4 @@
+
+T19336.hs:43:1: warning: [-Wmissing-signatures (in -Wall)]
+    Top-level binding with no type signature:
+      oops :: (X a (F a), Poly a) => a -> F a
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 469dd915df..7d8aa9f3ae 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -302,3 +302,4 @@ test('GivenLoop', normal, compile, [''])
 test('T18875', normal, compile, [''])
 test('T8707', normal, compile, ['-O'])
 test('T14111', normal, compile, ['-O'])
+test('T19336', normal, compile, ['-O'])