summaryrefslogtreecommitdiff
path: root/libraries/base/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/base/GHC')
-rw-r--r--libraries/base/GHC/Base.lhs203
-rw-r--r--libraries/base/GHC/Conc/Sync.lhs12
-rw-r--r--libraries/base/GHC/Event/Array.hs2
-rw-r--r--libraries/base/GHC/Event/EPoll.hsc1
-rw-r--r--libraries/base/GHC/Event/Internal.hs1
-rw-r--r--libraries/base/GHC/Event/Manager.hs1
-rw-r--r--libraries/base/GHC/Event/Poll.hsc1
-rw-r--r--libraries/base/GHC/Event/TimerManager.hs1
-rw-r--r--libraries/base/GHC/GHCi.hs9
-rw-r--r--libraries/base/GHC/ST.lhs4
10 files changed, 221 insertions, 14 deletions
diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs
index 1c8e144b7f..6d0c4b12d5 100644
--- a/libraries/base/GHC/Base.lhs
+++ b/libraries/base/GHC/Base.lhs
@@ -129,6 +129,8 @@ infixl 4 <$
infixl 1 >>, >>=
infixr 0 $
+infixl 4 <*>, <*, *>, <**>
+
default () -- Double isn't available yet
\end{code}
@@ -159,10 +161,102 @@ foldr = error "urk"
-}
\end{code}
+%*********************************************************
+%* *
+\subsection{Monoids}
+%* *
+%*********************************************************
+\begin{code}
+
+-- ---------------------------------------------------------------------------
+-- | The class of monoids (types with an associative binary operation that
+-- has an identity). Instances should satisfy the following laws:
+--
+-- * @mappend mempty x = x@
+--
+-- * @mappend x mempty = x@
+--
+-- * @mappend x (mappend y z) = mappend (mappend x y) z@
+--
+-- * @mconcat = 'foldr' mappend mempty@
+--
+-- The method names refer to the monoid of lists under concatenation,
+-- but there are many other instances.
+--
+-- Minimal complete definition: 'mempty' and 'mappend'.
+--
+-- Some types can be viewed as a monoid in more than one way,
+-- e.g. both addition and multiplication on numbers.
+-- In such cases we often define @newtype@s and make those instances
+-- of 'Monoid', e.g. 'Sum' and 'Product'.
+
+class Monoid a where
+ mempty :: a
+ -- ^ Identity of 'mappend'
+ mappend :: a -> a -> a
+ -- ^ An associative operation
+ mconcat :: [a] -> a
+
+ -- ^ Fold a list using the monoid.
+ -- For most types, the default definition for 'mconcat' will be
+ -- used, but the function is included in the class definition so
+ -- that an optimized version can be provided for specific types.
+
+ mconcat = foldr mappend mempty
+
+instance Monoid [a] where
+ mempty = []
+ mappend = (++)
+
+instance Monoid b => Monoid (a -> b) where
+ mempty _ = mempty
+ mappend f g x = f x `mappend` g x
+
+instance Monoid () where
+ -- Should it be strict?
+ mempty = ()
+ _ `mappend` _ = ()
+ mconcat _ = ()
+
+instance (Monoid a, Monoid b) => Monoid (a,b) where
+ mempty = (mempty, mempty)
+ (a1,b1) `mappend` (a2,b2) =
+ (a1 `mappend` a2, b1 `mappend` b2)
+
+instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+ mempty = (mempty, mempty, mempty)
+ (a1,b1,c1) `mappend` (a2,b2,c2) =
+ (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
+ mempty = (mempty, mempty, mempty, mempty)
+ (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
+ (a1 `mappend` a2, b1 `mappend` b2,
+ c1 `mappend` c2, d1 `mappend` d2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
+ Monoid (a,b,c,d,e) where
+ mempty = (mempty, mempty, mempty, mempty, mempty)
+ (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
+ (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
+ d1 `mappend` d2, e1 `mappend` e2)
+
+-- lexicographical ordering
+instance Monoid Ordering where
+ mempty = EQ
+ LT `mappend` _ = LT
+ EQ `mappend` y = y
+ GT `mappend` _ = GT
+
+instance Monoid a => Applicative ((,) a) where
+ pure x = (mempty, x)
+ (u, f) <*> (v, x) = (u `mappend` v, f x)
+\end{code}
+
%*********************************************************
%* *
-\subsection{Monadic classes @Functor@, @Monad@ }
+\subsection{Monadic classes @Functor@, @Applicative@, @Monad@ }
%* *
%*********************************************************
@@ -186,6 +280,82 @@ class Functor f where
(<$) :: a -> f b -> f a
(<$) = fmap . const
+-- | A functor with application, providing operations to
+--
+-- * embed pure expressions ('pure'), and
+--
+-- * sequence computations and combine their results ('<*>').
+--
+-- A minimal complete definition must include implementations of these
+-- functions satisfying the following laws:
+--
+-- [/identity/]
+--
+-- @'pure' 'id' '<*>' v = v@
+--
+-- [/composition/]
+--
+-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
+--
+-- [/homomorphism/]
+--
+-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
+--
+-- [/interchange/]
+--
+-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
+--
+-- The other methods have the following default definitions, which may
+-- be overridden with equivalent specialized implementations:
+--
+-- * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
+--
+-- * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
+--
+-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
+--
+-- * @'fmap' f x = 'pure' f '<*>' x@
+--
+-- If @f@ is also a 'Monad', it should satisfy
+--
+-- * @'pure' = 'return'@
+--
+-- * @('<*>') = 'ap'@
+--
+-- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
+
+class Functor f => Applicative f where
+ -- | Lift a value.
+ pure :: a -> f a
+
+ -- | Sequential application.
+ (<*>) :: f (a -> b) -> f a -> f b
+
+ -- | Sequence actions, discarding the value of the first argument.
+ (*>) :: f a -> f b -> f b
+ (*>) = liftA2 (const id)
+
+ -- | Sequence actions, discarding the value of the second argument.
+ (<*) :: f a -> f b -> f a
+ (<*) = liftA2 const
+
+-- | A variant of '<*>' with the arguments reversed.
+(<**>) :: Applicative f => f a -> f (a -> b) -> f b
+(<**>) = liftA2 (flip ($))
+
+-- | Lift a function to actions.
+-- 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
+
+-- | 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
+
+-- | 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
+
{- | The 'Monad' class defines the basic operations over a /monad/,
a concept from a branch of mathematics known as /category theory/.
From the perspective of a Haskell programmer, however, it is best to
@@ -209,37 +379,52 @@ The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
defined in the "Prelude" satisfy these laws.
-}
-class Monad m where
+class Applicative m => Monad m where
-- | Sequentially compose two actions, passing any value produced
-- by the first as an argument to the second.
(>>=) :: forall a b. m a -> (a -> m b) -> m b
+ m >>= f = join (fmap f m)
+
-- | Sequentially compose two actions, discarding any value produced
-- by the first, like sequencing operators (such as the semicolon)
-- in imperative languages.
(>>) :: forall a b. m a -> m b -> m b
+ (>>) = (*>)
+ {-# INLINE (>>) #-}
+
+ join :: m (m a) -> m a
+ join m = m >>= id
+
-- Explicit for-alls so that we know what order to
-- give type arguments when desugaring
-- | Inject a value into the monadic type.
return :: a -> m a
+ return = pure
+
-- | Fail with a message. This operation is not part of the
-- mathematical definition of a monad, but is invoked on pattern-match
-- failure in a @do@ expression.
fail :: String -> m a
-
- {-# INLINE (>>) #-}
- m >> k = m >>= \_ -> k
fail s = error s
+
+-- instances for Prelude types
+
instance Functor ((->) r) where
fmap = (.)
+instance Applicative ((->) a) where
+ pure = const
+ (<*>) f g x = f x (g x)
+
instance Monad ((->) r) where
return = const
f >>= k = \ r -> k (f r) r
instance Functor ((,) a) where
fmap f (x,y) = (x, f y)
+
\end{code}
@@ -253,6 +438,10 @@ instance Functor ((,) a) where
instance Functor [] where
fmap = map
+instance Applicative [] where
+ pure = return
+ (<*>) = liftA2 id
+
instance Monad [] where
m >>= k = foldr ((++) . k) [] m
m >> k = foldr ((++) . (\ _ -> k)) [] m
@@ -601,6 +790,10 @@ asTypeOf = const
instance Functor IO where
fmap f x = x >>= (return . f)
+instance Applicative IO where
+ pure = return
+ (<*>) = liftA2 id
+
instance Monad IO where
{-# INLINE return #-}
{-# INLINE (>>) #-}
diff --git a/libraries/base/GHC/Conc/Sync.lhs b/libraries/base/GHC/Conc/Sync.lhs
index ebb7226d09..6a14b4d6af 100644
--- a/libraries/base/GHC/Conc/Sync.lhs
+++ b/libraries/base/GHC/Conc/Sync.lhs
@@ -548,6 +548,10 @@ unSTM (STM a) = a
instance Functor STM where
fmap f x = x >>= (return . f)
+instance Applicative STM where
+ pure = return
+ (<*>) = liftA2 id
+
instance Monad STM where
{-# INLINE return #-}
{-# INLINE (>>) #-}
@@ -571,9 +575,13 @@ thenSTM (STM m) k = STM ( \s ->
returnSTM :: a -> STM a
returnSTM x = STM (\s -> (# s, x #))
+instance Alternative STM where
+ empty = retry
+ (<|>) = orElse
+
instance MonadPlus STM where
- mzero = retry
- mplus = orElse
+ mzero = empty
+ mplus = (<|>)
-- | Unsafely performs IO in the STM monad. Beware: this is a highly
-- dangerous thing to do.
diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs
index 30dbd77f5b..3626387669 100644
--- a/libraries/base/GHC/Event/Array.hs
+++ b/libraries/base/GHC/Event/Array.hs
@@ -24,7 +24,7 @@ module GHC.Event.Array
, useAsPtr
) where
-import Control.Monad hiding (forM_)
+import Control.Monad hiding (forM_, empty)
import Data.Bits ((.|.), shiftR)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.Maybe
diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc
index b808b21e96..298f450096 100644
--- a/libraries/base/GHC/Event/EPoll.hsc
+++ b/libraries/base/GHC/Event/EPoll.hsc
@@ -41,7 +41,6 @@ available = False
import Control.Monad (when)
import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Data.Word (Word32)
import Foreign.C.Error (eNOENT, getErrno, throwErrno,
throwErrnoIfMinus1, throwErrnoIfMinus1_)
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index a4c2e10d32..fcd7886a20 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -25,7 +25,6 @@ module GHC.Event.Internal
import Data.Bits ((.|.), (.&.))
import Data.List (foldl', intercalate)
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
import GHC.Base
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index d55d5b1193..53788137ac 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -56,7 +56,6 @@ import Data.Bits ((.&.))
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
writeIORef)
import Data.Maybe (Maybe(..), maybe)
-import Data.Monoid (mappend, mconcat, mempty)
import GHC.Arr (Array, (!), listArray)
import GHC.Base
import GHC.Conc.Signal (runHandlers)
diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc
index bb0b6e570b..4a27fcc3f4 100644
--- a/libraries/base/GHC/Event/Poll.hsc
+++ b/libraries/base/GHC/Event/Poll.hsc
@@ -28,7 +28,6 @@ import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
import Control.Monad ((=<<), liftM, liftM2, unless)
import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
import Data.Word
import Foreign.C.Types (CInt(..), CShort(..))
import Foreign.Ptr (Ptr)
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index f94f06148a..a3734fc473 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -42,7 +42,6 @@ import Control.Monad ((=<<), liftM, sequence_, when)
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
writeIORef)
import Data.Maybe (Maybe(..))
-import Data.Monoid (mempty)
import GHC.Base
import GHC.Conc.Signal (runHandlers)
import GHC.Num (Num(..))
diff --git a/libraries/base/GHC/GHCi.hs b/libraries/base/GHC/GHCi.hs
index f66d540574..8436837c88 100644
--- a/libraries/base/GHC/GHCi.hs
+++ b/libraries/base/GHC/GHCi.hs
@@ -21,7 +21,7 @@ module GHC.GHCi {-# WARNING "This is an unstable interface." #-} (
GHCiSandboxIO(..), NoIO()
) where
-import GHC.Base (IO(), Monad, (>>=), return, id, (.))
+import GHC.Base (IO(), Monad, Functor(fmap), Applicative(..), (>>=), liftA2, return, id, (.))
-- | A monad that can execute GHCi statements by lifting them out of
-- m into the IO monad. (e.g state monads)
@@ -34,6 +34,13 @@ instance GHCiSandboxIO IO where
-- | A monad that doesn't allow any IO.
newtype NoIO a = NoIO { noio :: IO a }
+instance Functor NoIO where
+ fmap f (NoIO a) = NoIO (fmap f a)
+
+instance Applicative NoIO where
+ pure = return
+ (<*>) = liftA2 id
+
instance Monad NoIO where
return a = NoIO (return a)
(>>=) k f = NoIO (noio k >>= noio . f)
diff --git a/libraries/base/GHC/ST.lhs b/libraries/base/GHC/ST.lhs
index 5da8b0afed..8c7b4a6eee 100644
--- a/libraries/base/GHC/ST.lhs
+++ b/libraries/base/GHC/ST.lhs
@@ -65,6 +65,10 @@ instance Functor (ST s) where
case (m s) of { (# new_s, r #) ->
(# new_s, f r #) }
+instance Applicative (ST s) where
+ pure = return
+ (<*>) = liftA2 id
+
instance Monad (ST s) where
{-# INLINE return #-}
{-# INLINE (>>) #-}
View Lorry Controller Status