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].

5 files changed, 24 insertions, 21 deletions

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