diff options
| -rw-r--r-- | compiler/basicTypes/UniqSupply.lhs | 1 | ||||
| -rw-r--r-- | compiler/simplCore/SimplMonad.lhs | 3 | ||||
| -rw-r--r-- | libraries/base/Control/Applicative.hs | 28 | ||||
| -rw-r--r-- | libraries/base/GHC/Base.lhs | 69 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 3 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T8848.stderr | 7 |
6 files changed, 67 insertions, 44 deletions
diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index 401d69b0f4..d1a1efd298 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -125,6 +125,7 @@ instance Applicative UniqSM where (USM f) <*> (USM x) = USM $ \us -> case f us of (# ff, us' #) -> case x us' of (# xx, us'' #) -> (# ff xx, us'' #) + (*>) = thenUs_ -- | Run the 'UniqSM' action, returning the final 'UniqSupply' initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index e5561b2fc0..ca14688583 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -103,8 +103,9 @@ instance Functor SimplM where fmap = liftM instance Applicative SimplM where - pure = return + pure = returnSmpl (<*>) = ap + (*>) = thenSmpl_ instance Monad SimplM where (>>) = thenSmpl_ diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs index d6157b3d69..cc87343fc2 100644 --- a/libraries/base/Control/Applicative.hs +++ b/libraries/base/Control/Applicative.hs @@ -1,6 +1,8 @@ {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- @@ -63,7 +65,7 @@ import GHC.Read (Read) import GHC.Show (Show) newtype Const a b = Const { getConst :: a } - deriving (Generic, Generic1) + deriving (Generic, Generic1, Monoid) instance Foldable (Const m) where foldMap _ _ = mempty @@ -71,17 +73,17 @@ instance Foldable (Const m) where instance Functor (Const m) where fmap _ (Const v) = Const v --- Added in base-4.7.0.0 -instance Monoid a => Monoid (Const a b) where - mempty = Const mempty - mappend (Const a) (Const b) = Const (mappend a b) - instance Monoid m => Applicative (Const m) where pure _ = Const mempty - Const f <*> Const v = Const (f `mappend` v) + (<*>) = coerce (mappend :: m -> m -> m) +-- This is pretty much the same as +-- Const f <*> Const v = Const (f `mappend` v) +-- but guarantees that mappend for Const a b will have the same arity +-- as the one for a; it won't create a closure to raise the arity +-- to 2. newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } - deriving (Generic, Generic1) + deriving (Generic, Generic1, Monad) instance Monad m => Functor (WrappedMonad m) where fmap f (WrapMonad v) = WrapMonad (liftM f v) @@ -90,11 +92,6 @@ instance Monad m => Applicative (WrappedMonad m) where pure = WrapMonad . return WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) --- Added in base-4.7.0.0 (GHC Trac #8218) -instance Monad m => Monad (WrappedMonad m) where - return = WrapMonad . return - a >>= f = WrapMonad (unwrapMonad a >>= unwrapMonad . f) - instance MonadPlus m => Alternative (WrappedMonad m) where empty = WrapMonad mzero WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) @@ -118,10 +115,7 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ -- newtype ZipList a = ZipList { getZipList :: [a] } - deriving (Show, Eq, Ord, Read, Generic, Generic1) - -instance Functor ZipList where - fmap f (ZipList xs) = ZipList (map f xs) + deriving (Show, Eq, Ord, Read, Functor, Generic, Generic1) instance Applicative ZipList where pure x = ZipList (repeat x) diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs index d99ad01e27..495a6b25b8 100644 --- a/libraries/base/GHC/Base.lhs +++ b/libraries/base/GHC/Base.lhs @@ -391,7 +391,9 @@ class Functor f => Applicative f where -- | Sequence actions, discarding the value of the first argument. (*>) :: f a -> f b -> f b - (*>) = liftA2 (const id) + a1 *> a2 = (id <$ a1) <*> a2 + -- This is essentially the same as liftA2 (const id), but if the + -- Functor instance has an optimized (<$), we want to use that instead. -- | Sequence actions, discarding the value of the second argument. (<*) :: f a -> f b -> f a @@ -405,14 +407,28 @@ class Functor f => Applicative f where -- This function may be used as a value for `fmap` in a `Functor` instance. liftA :: Applicative f => (a -> b) -> f a -> f b liftA f a = pure f <*> a +-- Caution: since this may be used for `fmap`, we can't use the obvious +-- definition of liftA = fmap. -- | Lift a binary function to actions. liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c -liftA2 f a b = (fmap f a) <*> b +liftA2 f a b = fmap f a <*> b -- | Lift a ternary function to actions. liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d -liftA3 f a b c = (fmap f a) <*> b <*> c +liftA3 f a b c = fmap f a <*> b <*> c + + +{-# INLINEABLE liftA #-} +{-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-} +{-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-} +{-# INLINEABLE liftA2 #-} +{-# SPECIALISE liftA2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-} +{-# SPECIALISE liftA2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-} +{-# INLINEABLE liftA3 #-} +{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-} +{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> + Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-} -- | The 'join' function is the conventional monad join operator. It -- is used to remove one level of monadic structure, projecting its @@ -429,13 +445,21 @@ monadic expressions. Instances of 'Monad' should satisfy the following laws: -> return a >>= k == k a -> m >>= return == m -> m >>= (\x -> k x >>= h) == (m >>= k) >>= h +* @'return' a '>>=' k = k a@ +* @m '>>=' 'return' = m@ +* @m '>>=' (\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@ + +Furthermore, the 'Monad' and 'Applicative' operations should relate as follows: + +* @'pure' = 'return'@ +* @('<*>') = 'ap'@ + +The above laws imply that -Instances of both 'Monad' and 'Functor' should additionally satisfy the law: +* @'fmap' f xs = xs '>>=' 'return' . f@, +* @('>>') = ('*>') -> fmap f xs == xs >>= return . f +and that 'pure' and ('<*>') satisfy the applicative functor laws. The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' defined in the "Prelude" satisfy these laws. @@ -569,7 +593,12 @@ is equivalent to -} ap :: (Monad m) => m (a -> b) -> m a -> m b -ap = liftM2 id +ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) } +-- Since many Applicative instances define (<*>) = ap, we +-- cannot define ap = (<*>) +{-# INLINEABLE ap #-} +{-# SPECIALISE ap :: IO (a -> b) -> IO a -> IO b #-} +{-# SPECIALISE ap :: Maybe (a -> b) -> Maybe a -> Maybe b #-} -- instances for Prelude types @@ -593,15 +622,19 @@ instance Functor Maybe where fmap f (Just a) = Just (f a) instance Applicative Maybe where - pure = return - (<*>) = ap + pure = Just + + Just f <*> m = fmap f m + Nothing <*> _m = Nothing + + Just _m1 *> m2 = m2 + Nothing *> _m2 = Nothing instance Monad Maybe where (Just x) >>= k = k x Nothing >>= _ = Nothing - (Just _) >> k = k - Nothing >> _ = Nothing + (>>) = (*>) return = Just fail _ = Nothing @@ -662,11 +695,7 @@ class (Alternative m, Monad m) => MonadPlus m where mplus :: m a -> m a -> m a mplus = (<|>) -instance MonadPlus Maybe where - mzero = Nothing - - Nothing `mplus` ys = ys - xs `mplus` _ys = xs +instance MonadPlus Maybe \end{code} @@ -694,9 +723,7 @@ instance Alternative [] where empty = [] (<|>) = (++) -instance MonadPlus [] where - mzero = [] - mplus = (++) +instance MonadPlus [] \end{code} A few list functions that appear here because they are used here. diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 368753a437..f6f52d737d 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -496,10 +496,11 @@ test('T9020', [(wordsize(32), 343005716, 10), # Original: 381360728 # 2014-07-31: 343005716 (Windows) (general round of updates) - (wordsize(64), 785871680, 10)]) + (wordsize(64), 680162056, 10)]) # prev: 795469104 # 2014-07-17: 728263536 (general round of updates) # 2014-09-10: 785871680 post-AMP-cleanup + # 2014-11-03: 680162056 Further Applicative and Monad adjustments ], compile,['']) diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr index dad6b17652..6dcc1bb425 100644 --- a/testsuite/tests/simplCore/should_compile/T8848.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848.stderr @@ -11,18 +11,17 @@ Rule fired: Class op $p1Applicative Rule fired: Class op fmap Rule fired: Class op <*> Rule fired: Class op $p1Applicative -Rule fired: Class op fmap +Rule fired: Class op <$ Rule fired: Class op <*> Rule fired: Class op $p1Applicative Rule fired: Class op fmap Rule fired: Class op <*> Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z) Rule fired: Class op $p1Applicative -Rule fired: Class op fmap +Rule fired: Class op <$ Rule fired: Class op <*> -Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z) Rule fired: Class op $p1Applicative -Rule fired: Class op fmap +Rule fired: Class op <$ Rule fired: Class op <*> Rule fired: Class op $p1Applicative Rule fired: Class op fmap |