diff --git a/compiler/GHC/Data/List/Infinite.hs b/compiler/GHC/Data/List/Infinite.hs index 9d5af5433d0d8dd47456e3be675b567703b58808..67f78d47338476ea6a070866b0a19a5d2ccbb127 100644 --- a/compiler/GHC/Data/List/Infinite.hs +++ b/compiler/GHC/Data/List/Infinite.hs @@ -16,15 +16,18 @@ module GHC.Data.List.Infinite , allListsOf , toList , repeat + , enumFrom ) where -import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), Traversable (..), flip, otherwise) +import Prelude ((-), Applicative (..), Bool (..), Enum (succ), Foldable, Functor (..), Int, Maybe (..), Monad (..), 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) +infixr 5 `Inf` + data Infinite a = Inf a (Infinite a) deriving (Foldable, Functor, Traversable) @@ -44,6 +47,11 @@ instance Applicative Infinite where pure = repeat Inf f fs <*> Inf a as = Inf (f a) (fs <*> as) +instance Monad Infinite where + x >>= f = join (f <$> x) + where + join (Inf a as) = head a `Inf` join (tail <$> as) + mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b mapMaybe f = go where @@ -171,6 +179,10 @@ repeatFB c x = xs where xs = c x xs "repeatFB" [1] repeatFB Inf = repeat #-} +enumFrom :: Enum a => a -> Infinite a +enumFrom = iterate succ +{-# INLINE enumFrom #-} + {- Note [Fusion for `Infinite` lists] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 67f166bc8691118131f846351d6506a7c1afd8bf..796f5c35da1ecb42df72effdccb198e81db26004 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} -- | The deriving code for the Functor, Foldable, and Traversable classes module GHC.Tc.Deriv.Functor @@ -43,7 +44,10 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Id.Make (coerceId) import GHC.Builtin.Types (true_RDR, false_RDR) +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf +import Data.Foldable import Data.Maybe (catMaybes, isJust) {- @@ -181,7 +185,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon fmap_eqns = map fmap_eqn data_cons - ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_fmap :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) ft_fmap = FT { ft_triv = \x -> pure x -- fmap f x = x , ft_var = \x -> pure $ nlHsApp f_Expr x @@ -220,7 +224,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon replace_eqns = map replace_eqn data_cons - ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_replace :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) ft_replace = FT { ft_triv = \x -> pure x -- p <$ x = x , ft_var = \_ -> pure z_Expr @@ -600,27 +604,23 @@ foldDataConArgs ft con dit -- The kind checks have ensured the last type parameter is of kind *. -- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) +mkSimpleLam :: (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) + -> State (Infinite RdrName) (LHsExpr GhcPs) -- (mkSimpleLam fn) returns (\x. fn(x)) mkSimpleLam lam = - get >>= \case - n:names -> do + get >>= \ (Inf n names) -> do put names body <- lam (nlHsVar n) return (mkHsLam (noLocA [nlVarPat n]) body) - _ -> panic "mkSimpleLam" mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs - -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) + -> State (Infinite RdrName) (LHsExpr GhcPs)) + -> State (Infinite RdrName) (LHsExpr GhcPs) mkSimpleLam2 lam = - get >>= \case - n1:n2:names -> do + get >>= \ (n1 `Inf` n2 `Inf` names) -> do put names body <- lam (nlHsVar n1) (nlHsVar n2) return (mkHsLam (noLocA [nlVarPat n1,nlVarPat n2]) body) - _ -> panic "mkSimpleLam2" -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -- @@ -637,7 +637,7 @@ mkSimpleConMatch :: Monad m => HsMatchContextPs -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch ctxt fold extra_pats con insides = do let con_name = getRdrName con - let vars_needed = takeList insides as_RDRs + let vars_needed = takeList insides as_RDRList let bare_pat = nlConVarPat con_name vars_needed let pat = if null vars_needed then bare_pat @@ -673,7 +673,7 @@ mkSimpleConMatch2 :: Monad m -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch2 ctxt fold extra_pats con insides = do let con_name = getRdrName con - vars_needed = takeList insides as_RDRs + vars_needed = takeList insides (toList as_RDRs) pat = nlConVarPat con_name vars_needed -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indices in each expression to match up with the argument indices @@ -684,13 +684,13 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do -- with the same index has a type which mentions the last type -- variable. argTysTyVarInfo = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo (toList as_Vars) con_expr | null asWithTyVar = nlHsApps con_name asWithoutTyVar | otherwise = - let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo bs_Vars as_Vars + let bs = filterByList argTysTyVarInfo bs_RDRList + vars = filterByLists argTysTyVarInfo bs_VarList as_VarList in mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars) rhs <- fold con_expr exps @@ -887,7 +887,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldr :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) ft_foldr = FT { ft_triv = return Nothing -- foldr f = \x z -> z @@ -922,7 +922,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon mkFoldr = foldr nlHsApp z -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldMap :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) ft_foldMap = FT { ft_triv = return Nothing -- foldMap f = \x -> mempty @@ -957,7 +957,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon -- that may or may not be null. Yields IsNull if it's certainly -- null, and yields NotNull if it's certainly not null. -- See Note [Deriving null] - ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) + ft_null :: FFoldType (State (Infinite RdrName) (NullM (LHsExpr GhcPs))) ft_null = FT { ft_triv = return IsNull -- null = \_ -> True @@ -1082,7 +1082,7 @@ gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_trav :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) ft_trav = FT { ft_triv = return Nothing -- traverse f = pure x @@ -1140,13 +1140,21 @@ f_RDR, z_RDR :: RdrName f_RDR = mkVarUnqual (fsLit "f") z_RDR = mkVarUnqual (fsLit "z") -as_RDRs, bs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +as_RDRs, bs_RDRs :: Infinite RdrName +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- Inf.enumFrom (1::Int) ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- Inf.enumFrom (1::Int) ] -as_Vars, bs_Vars :: [LHsExpr GhcPs] -as_Vars = map nlHsVar as_RDRs -bs_Vars = map nlHsVar bs_RDRs +as_Vars, bs_Vars :: Infinite (LHsExpr GhcPs) +as_Vars = fmap nlHsVar as_RDRs +bs_Vars = fmap nlHsVar bs_RDRs + +as_RDRList, bs_RDRList :: [RdrName] +as_RDRList = Inf.toList as_RDRs +bs_RDRList = Inf.toList bs_RDRs + +as_VarList, bs_VarList :: [LHsExpr GhcPs] +as_VarList = Inf.toList as_Vars +bs_VarList = Inf.toList bs_Vars f_Pat, z_Pat :: LPat GhcPs f_Pat = nlVarPat f_RDR