Define `Infinite` list and use where appropriate.

Also add perf test for infinite list fusion.

In particular, in `GHC.Core`, often we deal with infinite lists of roles. Also in a few locations we deal with infinite lists of names.

Thanks to simonpj for helping to write the Note [Fusion for `Infinite` lists].

21 files changed, 300 insertions, 89 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 57e2fcdc75..26fb6c35b4 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -119,7 +119,6 @@ in GHC.Builtin.Types.
 -}
 
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
 
 module GHC.Builtin.Names
    ( Unique, Uniquable(..), hasKey,  -- Re-exported for convenience
@@ -143,6 +142,8 @@ import GHC.Builtin.Uniques
 import GHC.Types.Name
 import GHC.Types.SrcLoc
 import GHC.Data.FastString
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
 
 import Language.Haskell.Syntax.Module.Name
 
@@ -154,9 +155,13 @@ import Language.Haskell.Syntax.Module.Name
 ************************************************************************
 -}
 
-allNameStrings :: [String]
+allNameStrings :: Infinite String
 -- Infinite list of a,b,c...z, aa, ab, ac, ... etc
-allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ]
+allNameStrings = Inf.allListsOf ['a'..'z']
+
+allNameStringList :: [String]
+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc
+allNameStringList = Inf.toList allNameStrings
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 1449e2331d..ad4e1b4ada 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -63,6 +63,7 @@ module GHC.Core.Coercion (
         splitForAllCo_ty_maybe, splitForAllCo_co_maybe,
 
         nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,
+        tyConRoleListX, tyConRoleListRepresentational,
 
         pickLR,
 
@@ -154,6 +155,8 @@ import GHC.Builtin.Types.Prim
 import GHC.Data.List.SetOps
 import GHC.Data.Maybe
 import GHC.Types.Unique.FM
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
 
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
@@ -408,12 +411,10 @@ where co_rep1, co_rep2 are the coercions on the representations.
 --
 -- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]
 decomposeCo :: Arity -> Coercion
-            -> [Role]  -- the roles of the output coercions
-                       -- this must have at least as many
-                       -- entries as the Arity provided
+            -> Infinite Role  -- the roles of the output coercions
             -> [Coercion]
 decomposeCo arity co rs
-  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]
+  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]
            -- Remember, Nth is zero-indexed
 
 decomposeFunCo :: HasDebugCallStack
@@ -533,7 +534,7 @@ splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
 splitTyConAppCo_maybe co
   | Just (ty, r) <- isReflCo_maybe co
   = do { (tc, tys) <- splitTyConApp_maybe ty
-       ; let args = zipWith mkReflCo (tyConRolesX r tc) tys
+       ; let args = zipWith mkReflCo (tyConRoleListX r tc) tys
        ; return (tc, args) }
 splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)
 splitTyConAppCo_maybe (FunCo _ w arg res)     = Just (funTyCon, cos)
@@ -819,15 +820,14 @@ mkAppCo co arg
     -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)
   = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)
   where
-    zip_roles (r1:_)  []            = [downgradeRole r1 Nominal arg]
-    zip_roles (r1:rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys
-    zip_roles _       _             = panic "zip_roles" -- but the roles are infinite...
+    zip_roles (Inf r1 _)  []            = [downgradeRole r1 Nominal arg]
+    zip_roles (Inf r1 rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys
 
 mkAppCo (TyConAppCo r tc args) arg
   = case r of
       Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])
       Representational -> mkTyConAppCo Representational tc (args ++ [arg'])
-        where new_role = (tyConRolesRepresentational tc) !! (length args)
+        where new_role = tyConRolesRepresentational tc Inf.!! length args
               arg'     = downgradeRole new_role Nominal arg
       Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])
 mkAppCo co arg = AppCo co  arg
@@ -1153,10 +1153,7 @@ mkNthCo r n co
       , tc1 == tc2
       = let len1 = length tys1
             len2 = length tys2
-            good_role = case coercionRole co of
-                          Nominal -> r == Nominal
-                          Representational -> r == (tyConRolesRepresentational tc1 !! n)
-                          Phantom -> r == Phantom
+            good_role = r == nthRole (coercionRole co) tc1 n
         in len1 == len2 && n < len1 && good_role
 
       | otherwise
@@ -1349,7 +1346,7 @@ setNominalRole_maybe r co
     setNominalRole_maybe_helper co@(Refl _) = Just co
     setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co
     setNominalRole_maybe_helper (TyConAppCo Representational tc cos)
-      = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos
+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos
            ; return $ TyConAppCo Nominal tc cos' }
     setNominalRole_maybe_helper (FunCo Representational w co1 co2)
       = do { co1' <- setNominalRole_maybe Representational co1
@@ -1393,27 +1390,33 @@ toPhantomCo co
 
 -- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational
 applyRoles :: TyCon -> [Coercion] -> [Coercion]
-applyRoles tc cos
-  = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos
+applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational
 
 -- the Role parameter is the Role of the TyConAppCo
 -- defined here because this is intimately concerned with the implementation
 -- of TyConAppCo
 -- Always returns an infinite list (with a infinite tail of Nominal)
-tyConRolesX :: Role -> TyCon -> [Role]
+tyConRolesX :: Role -> TyCon -> Infinite Role
 tyConRolesX Representational tc = tyConRolesRepresentational tc
-tyConRolesX role             _  = repeat role
+tyConRolesX role             _  = Inf.repeat role
+
+tyConRoleListX :: Role -> TyCon -> [Role]
+tyConRoleListX role = Inf.toList . tyConRolesX role
+
+-- Returns the roles of the parameters of a tycon, with an infinite tail
+-- of Nominal
+tyConRolesRepresentational :: TyCon -> Infinite Role
+tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal
 
 -- Returns the roles of the parameters of a tycon, with an infinite tail
 -- of Nominal
-tyConRolesRepresentational :: TyCon -> [Role]
-tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal
+tyConRoleListRepresentational :: TyCon -> [Role]
+tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational
 
 nthRole :: Role -> TyCon -> Int -> Role
 nthRole Nominal _ _ = Nominal
 nthRole Phantom _ _ = Phantom
-nthRole Representational tc n
-  = (tyConRolesRepresentational tc) `getNth` n
+nthRole Representational tc n = tyConRolesRepresentational tc Inf.!! n
 
 ltRole :: Role -> Role -> Bool
 -- Is one role "less" than another?
@@ -2034,7 +2037,7 @@ ty_co_subst !lc role ty
     go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $
                              liftCoSubstTyVar lc r tv
     go r (AppTy ty1 ty2)   = mkAppCo (go r ty1) (go Nominal ty2)
-    go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)
+    go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)
     go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2)
     go r t@(ForAllTy (Bndr v _) ty)
        = let (lc', v', h) = liftCoSubstVarBndr lc v
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 6fa8fc1273..d061d795a7 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -245,7 +245,7 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
       (True, Nominal) ->
         mkTyConAppCo Representational tc
                      (zipWith3 (opt_co3 env sym)
-                               (map Just (tyConRolesRepresentational tc))
+                               (map Just (tyConRoleListRepresentational tc))
                                (repeat Nominal)
                                cos)
       (False, Nominal) ->
@@ -254,7 +254,7 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
                       -- must use opt_co2 here, because some roles may be P
                       -- See Note [Optimising coercion optimisation]
         mkTyConAppCo r tc (zipWith (opt_co2 env sym)
-                                   (tyConRolesRepresentational tc)  -- the current roles
+                                   (tyConRoleListRepresentational tc)  -- the current roles
                                    cos)
       (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)
 
@@ -546,7 +546,7 @@ opt_univ env sym prov role oty1 oty2
   , equalLength tys1 tys2 -- see Note [Differing kinds]
       -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);
       -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps
-  = let roles    = tyConRolesX role tc1
+  = let roles    = tyConRoleListX role tc1
         arg_cos  = zipWith3 (mkUnivCo prov') roles tys1 tys2
         arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos
     in
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index e955e5befd..5ecb83d4a6 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -63,6 +63,8 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Data.Bag
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
 
 {-
 ************************************************************************
@@ -1477,7 +1479,7 @@ normalise_type ty
                Nothing ->
                  do { ArgsReductions redns res_co
                         <- normalise_args (typeKind nfun)
-                                          (repeat Nominal)
+                                          (Inf.repeat Nominal)
                                           arg_tys
                     ; role <- getRole
                     ; return $
@@ -1486,7 +1488,7 @@ normalise_type ty
                           (mkSymMCo res_co) } }
 
 normalise_args :: Kind    -- of the function
-               -> [Role]  -- roles at which to normalise args
+               -> Infinite Role  -- roles at which to normalise args
                -> [Type]  -- args
                -> NormM ArgsReductions
 -- returns ArgsReductions (Reductions cos xis) res_co,
@@ -1496,7 +1498,7 @@ normalise_args :: Kind    -- of the function
 -- but the resulting application *will* be well-kinded
 -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow
 normalise_args fun_ki roles args
-  = do { normed_args <- zipWithM normalise1 roles args
+  = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args
        ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args }
   where
     (ki_binders, inner_ki) = splitPiTys fun_ki
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 086a727095..6c285db819 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -2177,7 +2177,7 @@ lintCoercion co@(TyConAppCo r tc cos)
        ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos')
        ; lint_co_app co (tyConKind tc) (map pFst co_kinds)
        ; lint_co_app co (tyConKind tc) (map pSnd co_kinds)
-       ; zipWithM_ (lintRole co) (tyConRolesX r tc) co_roles
+       ; zipWithM_ (lintRole co) (tyConRoleListX r tc) co_roles
        ; return (TyConAppCo r tc cos') }
 
 lintCoercion co@(AppCo co1 co2)
diff --git a/compiler/GHC/Core/Reduction.hs b/compiler/GHC/Core/Reduction.hs
index f15b335fd7..f97b9517b6 100644
--- a/compiler/GHC/Core/Reduction.hs
+++ b/compiler/GHC/Core/Reduction.hs
@@ -35,6 +35,8 @@ import GHC.Core.TyCon      ( TyCon )
 import GHC.Core.Type
 
 import GHC.Data.Pair       ( Pair(Pair) )
+import GHC.Data.List.Infinite ( Infinite (..) )
+import qualified GHC.Data.List.Infinite as Inf
 
 import GHC.Types.Var       ( setTyVarKind )
 import GHC.Types.Var.Env   ( mkInScopeSet )
@@ -42,7 +44,7 @@ import GHC.Types.Var.Set   ( TyCoVarSet )
 
 import GHC.Utils.Misc      ( HasDebugCallStack, equalLength )
 import GHC.Utils.Outputable
-import GHC.Utils.Panic     ( assertPpr, panic )
+import GHC.Utils.Panic     ( assertPpr )
 
 {-
 %************************************************************************
@@ -788,7 +790,7 @@ simplifyArgsWorker :: HasDebugCallStack
                        -- the binders & result kind (not a Π-type) of the function applied to the args
                        -- list of binders can be shorter or longer than the list of args
                    -> TyCoVarSet   -- free vars of the args
-                   -> [Role]       -- list of roles, r
+                   -> Infinite Role-- list of roles, r
                    -> [Reduction]  -- rewritten type arguments, arg_i
                                    -- each comes with the coercion used to rewrite it,
                                    -- arg_co_i :: ty_i ~ arg_i
@@ -809,11 +811,11 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
   where
     orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs
 
-    go :: LiftingContext  -- mapping from tyvars to rewriting coercions
-       -> [TyCoBinder]    -- Unsubsted binders of function's kind
-       -> Kind        -- Unsubsted result kind of function (not a Pi-type)
-       -> [Role]      -- Roles at which to rewrite these ...
-       -> [Reduction] -- rewritten arguments, with their rewriting coercions
+    go :: LiftingContext -- mapping from tyvars to rewriting coercions
+       -> [TyCoBinder]   -- Unsubsted binders of function's kind
+       -> Kind           -- Unsubsted result kind of function (not a Pi-type)
+       -> Infinite Role  -- Roles at which to rewrite these ...
+       -> [Reduction]    -- rewritten arguments, with their rewriting coercions
        -> ArgsReductions
     go !lc binders inner_ki _ []
         -- The !lc makes the function strict in the lifting context
@@ -826,7 +828,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
         kind_co | noFreeVarsOfType final_kind = MRefl
                 | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind
 
-    go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns)
+    go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns)
       =  -- We rewrite an argument ty with arg_redn = Reduction arg_co arg
          -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),
          -- tcTypeKind(ty) = tcTypeKind(arg).
@@ -859,7 +861,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
             (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys
             casted_args           = assertPpr (equalLength arg_redns arg_cos)
                                               (ppr arg_redns $$ ppr arg_cos)
-                                  $ zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos
+                                  $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos
                -- In general decomposePiCos can return fewer cos than tys,
                -- but not here; because we're well typed, there will be enough
                -- binders. Note that decomposePiCos does substitutions, so even
@@ -874,19 +876,3 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
               = go zapped_lc bndrs new_inner roles casted_args
         in
           ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out)
-
-    go _ _ _ _ _ = panic
-        "simplifyArgsWorker wandered into deeper water than usual"
-           -- This debug information is commented out because leaving it in
-           -- causes a ~2% increase in allocations in T9872d.
-           -- That's independent of the analogous case in rewrite_args_fast
-           -- in GHC.Tc.Solver.Rewrite:
-           -- each of these causes a 2% increase on its own, so commenting them
-           -- both out gives a 4% decrease in T9872d.
-           {-
-
-             (vcat [ppr orig_binders,
-                    ppr orig_inner_ki,
-                    ppr (take 10 orig_roles), -- often infinite!
-                    ppr orig_tys])
-           -}
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index 188d5ff32f..596fef6b6f 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -1742,7 +1742,7 @@ pushRefl co =
       ->  Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2
                                        , mkReflCo r ty1,  mkReflCo r ty2 ])
     Just (TyConApp tc tys, r)
-      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))
+      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))
     Just (ForAllTy (Bndr tv _) ty, r)
       -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))
     -- NB: NoRefl variant. Otherwise, we get a loop!
diff --git a/compiler/GHC/Data/List/Infinite.hs b/compiler/GHC/Data/List/Infinite.hs
new file mode 100644
index 0000000000..0dec54438f
--- /dev/null
+++ b/compiler/GHC/Data/List/Infinite.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHC.Data.List.Infinite
+  ( Infinite (..)
+  , head, tail
+  , filter
+  , (++)
+  , unfoldr
+  , (!!)
+  , groupBy
+  , dropList
+  , iterate
+  , concatMap
+  , allListsOf
+  , toList
+  , repeat
+  ) where
+
+import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), Traversable (..), flip, otherwise)
+import Control.Category (Category (..))
+import Control.Monad (guard)
+import qualified Data.Foldable as F
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified GHC.Base as List (build)
+
+data Infinite a = Inf a (Infinite a)
+  deriving (Foldable, Functor, Traversable)
+
+head :: Infinite a -> a
+head (Inf a _) = a
+{-# NOINLINE [1] head #-}
+
+tail :: Infinite a -> Infinite a
+tail (Inf _ as) = as
+{-# NOINLINE [1] tail #-}
+
+{-# RULES
+"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x
+#-}
+
+instance Applicative Infinite where
+    pure = repeat
+    Inf f fs <*> Inf a as = Inf (f a) (fs <*> as)
+
+mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b
+mapMaybe f = go
+  where
+    go (Inf a as) = let bs = go as in case f a of
+        Nothing -> bs
+        Just b -> Inf b bs
+{-# NOINLINE [1] mapMaybe #-}
+
+{-# RULES
+"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as
+"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f
+  #-}
+
+{-# INLINE [0] mapMaybeFB #-}
+mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r
+mapMaybeFB cons f a bs = case f a of
+    Nothing -> bs
+    Just r -> cons r bs
+
+filter :: (a -> Bool) -> Infinite a -> Infinite a
+filter f = mapMaybe (\ a -> a <$ guard (f a))
+{-# INLINE filter #-}
+
+infixr 5 ++
+(++) :: Foldable f => f a -> Infinite a -> Infinite a
+(++) = flip (F.foldr Inf)
+
+unfoldr :: (b -> (a, b)) -> b -> Infinite a
+unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b
+{-# INLINE unfoldr #-}
+
+(!!) :: Infinite a -> Int -> a
+Inf a _ !! 0 = a
+Inf _ as !! n = as !! (n-1)
+
+groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a)
+groupBy eq = go
+  where
+    go (Inf a as) = Inf (a:|bs) (go cs)
+      where (bs, cs) = span (eq a) as
+
+span :: (a -> Bool) -> Infinite a -> ([a], Infinite a)
+span p = spanJust (\ a -> a <$ guard (p a))
+{-# INLINE span #-}
+
+spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a)
+spanJust p = go
+  where
+    go as@(Inf a as')
+      | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs)
+      | otherwise = ([], as)
+
+iterate :: (a -> a) -> a -> Infinite a
+iterate f = go where go a = Inf a (go (f a))
+{-# NOINLINE [1] iterate #-}
+
+{-# RULES
+"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a)
+"iterateFB" [1] iterateFB Inf = iterate
+#-}
+
+iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b
+iterateFB c f a = go a
+  where go a = a `c` go (f a)
+{-# INLINE [0] iterateFB #-}
+
+concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b
+concatMap f = go where go (Inf a as) = f a ++ go as
+{-# NOINLINE [1] concatMap #-}
+
+{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-}
+
+{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-}
+
+foldr :: (a -> b -> b) -> Infinite a -> b
+foldr f = go where go (Inf a as) = f a (go as)
+{-# INLINE [0] foldr #-}
+
+build :: (forall b . (a -> b -> b) -> b) -> Infinite a
+build g = g Inf
+{-# INLINE [1] build #-}
+
+-- Analogous to 'foldr'/'build' fusion for '[]'
+{-# RULES
+"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f
+"foldr/id" foldr Inf = id
+
+"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f)
+#-}
+
+{-# RULES
+"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as
+"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g)
+"mapFB/id" forall c . mapFB c (\ x -> x) = c
+#-}
+
+mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c
+mapFB c f = \ x ys -> c (f x) ys
+{-# INLINE [0] mapFB #-}
+
+dropList :: [a] -> Infinite b -> Infinite b
+dropList [] bs = bs
+dropList (_:as) (Inf _ bs) = dropList as bs
+
+-- | Compute all lists of the given alphabet.
+-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@
+allListsOf :: [a] -> Infinite [a]
+allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as)
+
+-- See Note [Fusion for `Infinite` lists].
+toList :: Infinite a -> [a]
+toList = \ as -> List.build (\ c _ -> foldr c as)
+{-# INLINE toList #-}
+
+repeat :: a -> Infinite a
+repeat a = as where as = Inf a as
+{-# INLINE [0] repeat #-}
+
+repeatFB :: (a -> b -> b) -> a -> b
+repeatFB c x = xs where xs = c x xs
+{-# INLINE [0] repeatFB #-}
+
+{-# RULES
+"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a
+"repeatFB" [1] repeatFB Inf = repeat
+#-}
+
+{-
+Note [Fusion for `Infinite` lists]
+~~~~~~~~~~~~~~~~~~~~
+We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in
+GHC.Base to support fusion for regular lists. In particular, we define the following:
+• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a`
+• `foldr :: (a -> b -> b) -> Infinite a -> b`
+• A RULE `foldr f (build g) = g f`
+• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in
+  terms of `foldr`
+
+This can work across data types. For example, consider `toList :: Infinite a -> [a]`.
+We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]').
+Ergo, we define it in terms of 'Infinite.foldr' and `List.build`.
+
+For a bigger example, consider `List.map f (toList (Infinite.map g as))`
+
+We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`,
+and the list structure between `toList` and `List.map`. And indeed we do: see test
+"InfiniteListFusion".
+-}
diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs
index 9d57e99b07..d28f835327 100644
--- a/compiler/GHC/HsToCore/Pmc/Ppr.hs
+++ b/compiler/GHC/HsToCore/Pmc/Ppr.hs
@@ -1,6 +1,5 @@
 
 
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 -- | Provides facilities for pretty-printing 'Nabla's in a way appropriate for
 -- user facing pattern match warnings.
@@ -10,6 +9,8 @@ module GHC.HsToCore.Pmc.Ppr (
 
 import GHC.Prelude
 
+import GHC.Data.List.Infinite (Infinite (..))
+import qualified GHC.Data.List.Infinite as Inf
 import GHC.Types.Basic
 import GHC.Types.Id
 import GHC.Types.Var.Env
@@ -101,12 +102,11 @@ prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList
     attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x))
 
 
-type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a
+type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) a
 
 -- Try nice names p,q,r,s,t before using the (ugly) t_i
-nameList :: [SDoc]
-nameList = map text ["p","q","r","s","t"] ++
-            [ text ('t':show u) | u <- [(0 :: Int)..] ]
+nameList :: Infinite SDoc
+nameList = map text ["p","q","r","s","t"] Inf.++ flip Inf.unfoldr (0 :: Int) (\ u -> (text ('t':show u), u+1))
 
 runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
 runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of
@@ -117,7 +117,7 @@ runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of
 getCleanName :: Id -> PmPprM SDoc
 getCleanName x = do
   (renamings, name_supply) <- get
-  let (clean_name:name_supply') = name_supply
+  let Inf clean_name name_supply' = name_supply
   case lookupDVarEnv renamings x of
     Just (_, nm) -> pure nm
     Nothing -> do
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 1263d5104b..65e2695f66 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -31,7 +31,7 @@ import GHC.Data.FastString
 import GHC.Data.Maybe (catMaybes)
 import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)
 import GHC.Hs.Type (pprLHsContext)
-import GHC.Builtin.Names (allNameStrings)
+import GHC.Builtin.Names (allNameStringList)
 import GHC.Builtin.Types (filterCTuple)
 import qualified GHC.LanguageExtensions as LangExt
 import Data.List.NonEmpty (NonEmpty((:|)))
@@ -486,7 +486,7 @@ instance Diagnostic PsMessage where
                  , nest 2
                    (what
                     <+> tc'
-                    <+> hsep (map text (takeList tparms allNameStrings))
+                    <+> hsep (map text (takeList tparms allNameStringList))
                     <+> equals_or_where) ] ]
            where
              -- Avoid printing a constraint tuple in the error message. Print
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index b8899e2431..d31cae7820 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -173,7 +173,7 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
           children_only
             = do { args <- unzipRedns <$>
                             zipWithM ( \ ty r -> go r rec_nts ty )
-                                     tys (tyConRolesX role tc)
+                                     tys (tyConRoleListX role tc)
                  ; return $ mkTyConAppRedn role tc args }
           nt_co  = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
           nt_rhs = newTyConInstRhs tc tys
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index a664092221..fa24c6286b 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE MonadComprehensions #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
@@ -125,6 +126,8 @@ import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Data.FastString
+import GHC.Data.List.Infinite ( Infinite (..) )
+import qualified GHC.Data.List.Infinite as Inf
 import GHC.Data.List.SetOps
 import GHC.Data.Maybe
 import GHC.Data.Bag( unitBag )
@@ -3693,12 +3696,10 @@ splitTyConKind skol_info in_scope avoid_occs kind
         ; uniqs   <- newUniqueSupply
         ; rdr_env <- getLocalRdrEnv
         ; lvl     <- getTcLevel
-        ; let new_occs = [ occ
-                         | str <- allNameStrings
-                         , let occ = mkOccName tvName str
-                         , isNothing (lookupLocalRdrOcc rdr_env occ)
-                         -- Note [Avoid name clashes for associated data types]
-                         , not (occ `elem` avoid_occs) ]
+        ; let new_occs = Inf.filter (\ occ ->
+                  isNothing (lookupLocalRdrOcc rdr_env occ) &&
+                  -- Note [Avoid name clashes for associated data types]
+                  not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings
               new_uniqs = uniqsFromSupply uniqs
               subst = mkEmptySubst in_scope
               details = SkolemTv skol_info (pushTcLevel lvl) False
@@ -3716,8 +3717,8 @@ splitTyConKind skol_info in_scope avoid_occs kind
                         name   = mkInternalName uniq occ loc
                         tv     = mkTcTyVar name arg' details
                         subst' = extendSubstInScope subst tv
-                        (uniq:uniqs') = uniqs
-                        (occ:occs')   = occs
+                        uniq:uniqs' = uniqs
+                        Inf occ occs' = occs
 
                     Just (Named (Bndr tv vis), kind')
                       -> go occs uniqs subst' (tcb : acc) kind'
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index 332d59244a..b3affa011d 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -1914,7 +1914,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
     role       = eqRelRole eq_rel
 
       -- infinite, as tyConRolesX returns an infinite tail of Nominal
-    tc_roles   = tyConRolesX role tc
+    tc_roles   = tyConRoleListX role tc
 
       -- Add nuances to the location during decomposition:
       --  * if the argument is a kind argument, remember this, so that error
@@ -3128,7 +3128,7 @@ unifyWanted rewriters loc role orig_ty1 orig_ty2
       | tc1 == tc2, tys1 `equalLength` tys2
       , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
       = do { cos <- zipWith3M (unifyWanted rewriters loc)
-                              (tyConRolesX role tc1) tys1 tys2
+                              (tyConRoleListX role tc1) tys1 tys2
            ; return (mkTyConAppCo role tc1 cos) }
 
     go ty1@(TyVarTy tv) ty2
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
index 6e8baf15a6..e746f35e41 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ b/compiler/GHC/Tc/Solver/Rewrite.hs
@@ -42,6 +42,8 @@ import Control.Monad
 import Control.Applicative (liftA3)
 import GHC.Builtin.Types.Prim (tYPETyCon)
 import Data.List ( find )
+import GHC.Data.List.Infinite (Infinite)
+import qualified GHC.Data.List.Infinite as Inf
 
 {-
 ************************************************************************
@@ -368,7 +370,7 @@ we skip adding to the cache here.
 {-# INLINE rewrite_args_tc #-}
 rewrite_args_tc
   :: TyCon         -- T
-  -> Maybe [Role]  -- Nothing: ambient role is Nominal; all args are Nominal
+  -> Maybe (Infinite Role)  -- Nothing: ambient role is Nominal; all args are Nominal
                    -- Otherwise: no assumptions; use roles provided
   -> [Type]
   -> RewriteM ArgsReductions -- See the commentary on rewrite_args
@@ -392,7 +394,7 @@ rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet
 rewrite_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
                                      -- named.
              -> Kind -> TcTyCoVarSet -- function kind; kind's free vars
-             -> Maybe [Role] -> [Type]    -- these are in 1-to-1 correspondence
+             -> Maybe (Infinite Role) -> [Type]    -- these are in 1-to-1 correspondence
                                           -- Nothing: use all Nominal
              -> RewriteM ArgsReductions
 -- This function returns ArgsReductions (Reductions cos xis) res_co
@@ -413,7 +415,7 @@ rewrite_args orig_binders
   = case (orig_m_roles, any_named_bndrs) of
       (Nothing, False) -> rewrite_args_fast orig_tys
       _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys
-        where orig_roles = fromMaybe (repeat Nominal) orig_m_roles
+        where orig_roles = fromMaybe (Inf.repeat Nominal) orig_m_roles
 
 {-# INLINE rewrite_args_fast #-}
 -- | fast path rewrite_args, in which none of the binders are named and
@@ -438,10 +440,10 @@ rewrite_args_fast orig_tys
 -- | Slow path, compared to rewrite_args_fast, because this one must track
 -- a lifting context.
 rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
-                  -> [Role] -> [Type]
+                  -> Infinite Role -> [Type]
                   -> RewriteM ArgsReductions
 rewrite_args_slow binders inner_ki fvs roles tys
-  = do { rewritten_args <- zipWithM rw roles tys
+  = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys
        ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }
   where
     {-# INLINE rw #-}
@@ -587,7 +589,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
   = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of
            Just (tc, xis) ->
              do { let tc_roles  = tyConRolesRepresentational tc
-                      arg_roles = dropList xis tc_roles
+                      arg_roles = Inf.dropList xis tc_roles
                 ; ArgsReductions (Reductions arg_cos arg_xis) kind_co
                     <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys
 
@@ -608,7 +610,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
                         ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)
                                   `mkTcTransCo`
                                   mkTcTyConAppCo Representational tc
-                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)
+                                    (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos)
 
                 ; return $
                     mkHetReduction
@@ -616,7 +618,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
                       kind_co }
            Nothing ->
              do { ArgsReductions redns kind_co
-                    <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys
+                    <- rewrite_vector (tcTypeKind fun_xi) (Inf.repeat Nominal) arg_tys
                 ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }
 
        ; role <- getRole
@@ -636,7 +638,7 @@ rewrite_ty_con_app tc tys
 
 -- Rewrite a vector (list of arguments).
 rewrite_vector :: Kind   -- of the function being applied to these arguments
-               -> [Role] -- If we're rewriting w.r.t. ReprEq, what roles do the
+               -> Infinite Role -- If we're rewriting w.r.t. ReprEq, what roles do the
                          -- args have?
                -> [Type] -- the args to rewrite
                -> RewriteM ArgsReductions
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index eae089c203..c0f42e056f 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -976,7 +976,7 @@ any_rewritable role tv_pred tc_pred should_expand
 
     go_tc NomEq  bvs _  tys = any (go NomEq bvs) tys
     go_tc ReprEq bvs tc tys = any (go_arg bvs)
-                              (tyConRolesRepresentational tc `zip` tys)
+                              (tyConRoleListRepresentational tc `zip` tys)
 
     go_arg bvs (Nominal,          ty) = go NomEq  bvs ty
     go_arg bvs (Representational, ty) = go ReprEq bvs ty
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 8e73f8b736..d065f4194e 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -378,6 +378,7 @@ Library
         GHC.Data.Graph.Ppr
         GHC.Data.Graph.UnVar
         GHC.Data.IOEnv
+        GHC.Data.List.Infinite
         GHC.Data.List.SetOps
         GHC.Data.Maybe
         GHC.Data.OrdList
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index b875e35ddb..212a79d42a 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -87,6 +87,7 @@ GHC.Data.FiniteMap
 GHC.Data.Graph.Directed
 GHC.Data.Graph.UnVar
 GHC.Data.IOEnv
+GHC.Data.List.Infinite
 GHC.Data.List.SetOps
 GHC.Data.Maybe
 GHC.Data.OrdList
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 2926e7b6bf..807e8f02ed 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -87,6 +87,7 @@ GHC.Data.FiniteMap
 GHC.Data.Graph.Directed
 GHC.Data.Graph.UnVar
 GHC.Data.IOEnv
+GHC.Data.List.Infinite
 GHC.Data.List.SetOps
 GHC.Data.Maybe
 GHC.Data.OrdList
diff --git a/testsuite/tests/perf/compiler/InfiniteListFusion.hs b/testsuite/tests/perf/compiler/InfiniteListFusion.hs
new file mode 100644
index 0000000000..5bfd9d7122
--- /dev/null
+++ b/testsuite/tests/perf/compiler/InfiniteListFusion.hs
@@ -0,0 +1,9 @@
+module Main where
+
+import qualified GHC.Data.List.Infinite as Inf
+
+main :: IO ()
+main = print $ sum $ take (2^16) $ Inf.toList $ Inf.filter isEven $ Inf.iterate succ (0 :: Int)
+
+isEven :: Integral a => a -> Bool
+isEven n = 0 == mod n 2
diff --git a/testsuite/tests/perf/compiler/InfiniteListFusion.stdout b/testsuite/tests/perf/compiler/InfiniteListFusion.stdout
new file mode 100644
index 0000000000..c584a2a13b
--- /dev/null
+++ b/testsuite/tests/perf/compiler/InfiniteListFusion.stdout
@@ -0,0 +1 @@
+4294901760
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index a70b93df01..e6e46ba62e 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -649,4 +649,9 @@ test('T21839c',
     [   collect_compiler_stats('all', 1),
         only_ways(['normal'])],
     compile,
-    ['-O'])
\ No newline at end of file
+    ['-O'])
+
+test ('InfiniteListFusion',
+      [collect_stats('bytes allocated',2), when(arch('i386'), skip)],
+      compile_and_run,
+      ['-O2 -package ghc'])