transformers 0.4.3.0 → 0.5.0.0
raw patch · 36 files changed
+1763/−781 lines, 36 filesdep +ghc-primdep ~base
Dependencies added: ghc-prim
Dependency ranges changed: base
Files
- Control/Applicative/Backwards.hs +23/−15
- Control/Applicative/Lift.hs +26/−20
- Control/Monad/IO/Class.hs +0/−39
- Control/Monad/Signatures.hs +7/−0
- Control/Monad/Trans/Class.hs +6/−2
- Control/Monad/Trans/Cont.hs +17/−1
- Control/Monad/Trans/Error.hs +75/−50
- Control/Monad/Trans/Except.hs +55/−19
- Control/Monad/Trans/Identity.hs +39/−13
- Control/Monad/Trans/List.hs +42/−13
- Control/Monad/Trans/Maybe.hs +61/−20
- Control/Monad/Trans/RWS.hs +4/−0
- Control/Monad/Trans/RWS/Lazy.hs +24/−8
- Control/Monad/Trans/RWS/Strict.hs +24/−8
- Control/Monad/Trans/Reader.hs +26/−1
- Control/Monad/Trans/State.hs +4/−0
- Control/Monad/Trans/State/Lazy.hs +24/−7
- Control/Monad/Trans/State/Strict.hs +23/−6
- Control/Monad/Trans/Writer.hs +4/−0
- Control/Monad/Trans/Writer/Lazy.hs +46/−13
- Control/Monad/Trans/Writer/Strict.hs +46/−13
- Data/Functor/Classes.hs +0/−196
- Data/Functor/Compose.hs +0/−92
- Data/Functor/Constant.hs +46/−7
- Data/Functor/Product.hs +0/−83
- Data/Functor/Reverse.hs +21/−13
- Data/Functor/Sum.hs +0/−65
- changelog +7/−0
- legacy/pre709/Data/Functor/Identity.hs +113/−0
- legacy/pre711/Control/Monad/IO/Class.hs +51/−0
- legacy/pre711/Data/Functor/Classes.hs +511/−0
- legacy/pre711/Data/Functor/Compose.hs +146/−0
- legacy/pre711/Data/Functor/Product.hs +148/−0
- legacy/pre711/Data/Functor/Sum.hs +127/−0
- oldsrc/Data/Functor/Identity.hs +0/−70
- transformers.cabal +17/−7
Control/Applicative/Backwards.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -31,22 +37,24 @@ -- actions in the reverse order. newtype Backwards f a = Backwards { forwards :: f a } -instance (Eq1 f, Eq a) => Eq (Backwards f a) where- Backwards x == Backwards y = eq1 x y+instance (Eq1 f) => Eq1 (Backwards f) where+ liftEq eq (Backwards x) (Backwards y) = liftEq eq x y -instance (Ord1 f, Ord a) => Ord (Backwards f a) where- compare (Backwards x) (Backwards y) = compare1 x y+instance (Ord1 f) => Ord1 (Backwards f) where+ liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y -instance (Read1 f, Read a) => Read (Backwards f a) where- readsPrec = readsData $ readsUnary1 "Backwards" Backwards+instance (Read1 f) => Read1 (Backwards f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards -instance (Show1 f, Show a) => Show (Backwards f a) where- showsPrec d (Backwards x) = showsUnary1 "Backwards" d x+instance (Show1 f) => Show1 (Backwards f) where+ liftShowsPrec sp sl d (Backwards x) =+ showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x -instance (Eq1 f) => Eq1 (Backwards f) where eq1 = (==)-instance (Ord1 f) => Ord1 (Backwards f) where compare1 = compare-instance (Read1 f) => Read1 (Backwards f) where readsPrec1 = readsPrec-instance (Show1 f) => Show1 (Backwards f) where showsPrec1 = showsPrec+instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1+instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 -- | Derived instance. instance (Functor f) => Functor (Backwards f) where@@ -67,8 +75,8 @@ foldMap f (Backwards t) = foldMap f t foldr f z (Backwards t) = foldr f z t foldl f z (Backwards t) = foldl f z t- foldr1 f (Backwards t) = foldl1 f t- foldl1 f (Backwards t) = foldr1 f t+ foldr1 f (Backwards t) = foldr1 f t+ foldl1 f (Backwards t) = foldl1 f t -- | Derived instance. instance (Traversable f) => Traversable (Backwards f) where
Control/Applicative/Lift.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -38,29 +41,32 @@ -- applicative functor. data Lift f a = Pure a | Other (f a) -instance (Eq1 f, Eq a) => Eq (Lift f a) where- Pure x1 == Pure x2 = x1 == x2- Other y1 == Other y2 = eq1 y1 y2- _ == _ = False+instance (Eq1 f) => Eq1 (Lift f) where+ liftEq eq (Pure x1) (Pure x2) = eq x1 x2+ liftEq _ (Pure _) (Other _) = False+ liftEq _ (Other _) (Pure _) = False+ liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 -instance (Ord1 f, Ord a) => Ord (Lift f a) where- compare (Pure x1) (Pure x2) = compare x1 x2- compare (Pure _) (Other _) = LT- compare (Other _) (Pure _) = GT- compare (Other y1) (Other y2) = compare1 y1 y2+instance (Ord1 f) => Ord1 (Lift f) where+ liftCompare comp (Pure x1) (Pure x2) = comp x1 x2+ liftCompare _ (Pure _) (Other _) = LT+ liftCompare _ (Other _) (Pure _) = GT+ liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 -instance (Read1 f, Read a) => Read (Lift f a) where- readsPrec = readsData $- readsUnary "Pure" Pure `mappend` readsUnary1 "Other" Other+instance (Read1 f) => Read1 (Lift f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith rp "Pure" Pure `mappend`+ readsUnaryWith (liftReadsPrec rp rl) "Other" Other -instance (Show1 f, Show a) => Show (Lift f a) where- showsPrec d (Pure x) = showsUnary "Pure" d x- showsPrec d (Other y) = showsUnary1 "Other" d y+instance (Show1 f) => Show1 (Lift f) where+ liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x+ liftShowsPrec sp sl d (Other y) =+ showsUnaryWith (liftShowsPrec sp sl) "Other" d y -instance (Eq1 f) => Eq1 (Lift f) where eq1 = (==)-instance (Ord1 f) => Ord1 (Lift f) where compare1 = compare-instance (Read1 f) => Read1 (Lift f) where readsPrec1 = readsPrec-instance (Show1 f) => Show1 (Lift f) where showsPrec1 = showsPrec+instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1+instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 instance (Functor f) => Functor (Lift f) where fmap f (Pure x) = Pure (f x)
− Control/Monad/IO/Class.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709-{-# LANGUAGE AutoDeriveTypeable #-}-#endif--------------------------------------------------------------------------------- |--- Module : Control.Monad.IO.Class--- Copyright : (c) Andy Gill 2001,--- (c) Oregon Graduate Institute of Science and Technology, 2001--- License : BSD-style (see the file LICENSE)------ Maintainer : R.Paterson@city.ac.uk--- Stability : experimental--- Portability : portable------ Class of monads based on @IO@.--------------------------------------------------------------------------------module Control.Monad.IO.Class (- MonadIO(..)- ) where---- | Monads in which 'IO' computations may be embedded.--- Any monad built by applying a sequence of monad transformers to the--- 'IO' monad will be an instance of this class.------ Instances should satisfy the following laws, which state that 'liftIO'--- is a transformer of monads:------ * @'liftIO' . 'return' = 'return'@------ * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@--class (Monad m) => MonadIO m where- -- | Lift a computation from the 'IO' monad.- liftIO :: IO a -> m a--instance MonadIO IO where- liftIO = id
Control/Monad/Signatures.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Signatures
Control/Monad/Trans/Class.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -192,8 +195,9 @@ > import Control.Monad.Trans.State > import qualified Control.Monad.Trans.Reader as R > import qualified Control.Monad.Trans.Except as E+> import Control.Monad.IO.Class >-> type InterpM = StateT Store (R.ReaderT Env (E.ExceptT Err []))+> type InterpM = StateT Store (R.ReaderT Env (E.ExceptT Err IO)) for suitable types @Store@, @Env@ and @Err@.
Control/Monad/Trans/Cont.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -47,6 +53,9 @@ import Data.Functor.Identity import Control.Applicative+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif {- | Continuation monad.@@ -142,8 +151,15 @@ f <*> v = ContT $ \ c -> runContT f $ \ g -> runContT v (c . g) instance Monad (ContT r m) where+#if !(MIN_VERSION_base(4,8,0)) return x = ContT ($ x)+#endif m >>= k = ContT $ \ c -> runContT m (\ x -> runContT (k x) c)++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where+ fail msg = ContT $ \ _ -> Fail.fail msg+#endif instance MonadTrans (ContT r) where lift m = ContT (m >>=)
Control/Monad/Trans/Error.hs view
@@ -1,8 +1,13 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif+#if !(MIN_VERSION_base(4,9,0)) {-# OPTIONS_GHC -fno-warn-orphans #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Error@@ -57,6 +62,9 @@ import Control.Applicative import Control.Exception (IOException) import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix #if !(MIN_VERSION_base(4,6,0)) import Control.Monad.Instances () -- deprecated from base-4.6@@ -66,6 +74,9 @@ import Data.Traversable (Traversable(traverse)) import System.IO.Error +#if !(MIN_VERSION_base(4,9,0))+-- These instances are in base-4.9.0+ instance MonadPlus IO where mzero = ioError (userError "mzero") m `mplus` n = m `catchIOError` \ _ -> n@@ -74,12 +85,45 @@ empty = mzero (<|>) = mplus -#if !(MIN_VERSION_base(4,4,0))+# if !(MIN_VERSION_base(4,4,0)) -- exported by System.IO.Error from base-4.4 catchIOError :: IO a -> (IOError -> IO a) -> IO a catchIOError = catch+# endif++instance (Error e) => Alternative (Either e) where+ empty = Left noMsg+ Left _ <|> n = n+ m <|> _ = m++instance (Error e) => MonadPlus (Either e) where+ mzero = Left noMsg+ Left _ `mplus` n = n+ m `mplus` _ = m #endif +#if !(MIN_VERSION_base(4,3,0))+-- These instances are in base-4.3++instance Applicative (Either e) where+ pure = Right+ Left e <*> _ = Left e+ Right f <*> r = fmap f r++instance Monad (Either e) where+ return = Right+ Left l >>= _ = Left l+ Right r >>= k = k r++instance MonadFix (Either e) where+ mfix f = let+ a = f $ case a of+ Right r -> r+ _ -> error "empty mfix argument"+ in a++#endif /* base to 4.2.0.x */+ -- | An exception to be thrown. -- -- Minimal complete definition: 'noMsg' or 'strMsg'.@@ -108,42 +152,6 @@ instance ErrorList Char where listMsg = id --- ------------------------------------------------------------------------------ Our parameterizable error monad--#if !(MIN_VERSION_base(4,3,0))---- These instances are in base-4.3--instance Applicative (Either e) where- pure = Right- Left e <*> _ = Left e- Right f <*> r = fmap f r--instance Monad (Either e) where- return = Right- Left l >>= _ = Left l- Right r >>= k = k r--instance MonadFix (Either e) where- mfix f = let- a = f $ case a of- Right r -> r- _ -> error "empty mfix argument"- in a--#endif /* base to 4.2.0.x */--instance (Error e) => Alternative (Either e) where- empty = Left noMsg- Left _ <|> n = n- m <|> _ = m--instance (Error e) => MonadPlus (Either e) where- mzero = Left noMsg- Left _ `mplus` n = n- m `mplus` _ = m- -- | The error monad transformer. It can be used to add error handling -- to other monads. --@@ -157,22 +165,32 @@ -- sequences two subcomputations, failing on the first error. newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } -instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where- ErrorT x == ErrorT y = eq1 x y+instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where+ liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y -instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where- compare (ErrorT x) (ErrorT y) = compare1 x y+instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where+ liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y -instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where- readsPrec = readsData $ readsUnary1 "ErrorT" ErrorT+instance (Read e, Read1 m) => Read1 (ErrorT e m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where- showsPrec d (ErrorT m) = showsUnary1 "ErrorT" d m+instance (Show e, Show1 m) => Show1 (ErrorT e m) where+ liftShowsPrec sp sl d (ErrorT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where eq1 = (==)-instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where compare1 = compare-instance (Read e, Read1 m) => Read1 (ErrorT e m) where readsPrec1 = readsPrec-instance (Show e, Show1 m) => Show1 (ErrorT e m) where showsPrec1 = showsPrec+instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1+instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1+instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where+ readsPrec = readsPrec1+instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where+ showsPrec = showsPrec1 -- | Map the unwrapped computation using the given function. --@@ -209,13 +227,20 @@ (<|>) = mplus instance (Monad m, Error e) => Monad (ErrorT e m) where+#if !(MIN_VERSION_base(4,8,0)) return a = ErrorT $ return (Right a)+#endif m >>= k = ErrorT $ do a <- runErrorT m case a of Left l -> return (Left l) Right r -> runErrorT (k r) fail msg = ErrorT $ return (Left (strMsg msg))++#if MIN_VERSION_base(4,9,0)+instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where+ fail msg = ErrorT $ return (Left (strMsg msg))+#endif instance (Monad m, Error e) => MonadPlus (ErrorT e m) where mzero = ErrorT $ return (Left noMsg)
Control/Monad/Trans/Except.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -52,7 +55,13 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif import Data.Foldable (Foldable(foldMap)) import Data.Monoid import Data.Traversable (Traversable(traverse))@@ -102,22 +111,33 @@ -- first exception. newtype ExceptT e m a = ExceptT (m (Either e a)) -instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where- ExceptT x == ExceptT y = eq1 x y+instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where+ liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y -instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where- compare (ExceptT x) (ExceptT y) = compare1 x y+instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where+ liftCompare comp (ExceptT x) (ExceptT y) =+ liftCompare (liftCompare comp) x y -instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where- readsPrec = readsData $ readsUnary1 "ExceptT" ExceptT+instance (Read e, Read1 m) => Read1 (ExceptT e m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where- showsPrec d (ExceptT m) = showsUnary1 "ExceptT" d m+instance (Show e, Show1 m) => Show1 (ExceptT e m) where+ liftShowsPrec sp sl d (ExceptT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where eq1 = (==)-instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where compare1 = compare-instance (Read e, Read1 m) => Read1 (ExceptT e m) where readsPrec1 = readsPrec-instance (Show e, Show1 m) => Show1 (ExceptT e m) where showsPrec1 = showsPrec+instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1+instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1+instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where+ readsPrec = readsPrec1+instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where+ showsPrec = showsPrec1 -- | The inverse of 'ExceptT'. runExceptT :: ExceptT e m a -> m (Either e a)@@ -159,11 +179,17 @@ Right x -> return (Right (k x)) instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where- empty = mzero- (<|>) = mplus+ empty = ExceptT $ return (Left mempty)+ ExceptT mx <|> ExceptT my = ExceptT $ do+ ex <- mx+ case ex of+ Left e -> liftM (either (Left . mappend e) Right) my+ Right x -> return (Right x) instance (Monad m) => Monad (ExceptT e m) where+#if !(MIN_VERSION_base(4,8,0)) return a = ExceptT $ return (Right a)+#endif m >>= k = ExceptT $ do a <- runExceptT m case a of@@ -171,12 +197,17 @@ Right x -> runExceptT (k x) fail = ExceptT . fail +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where+ fail = ExceptT . Fail.fail+#endif+ instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where mzero = ExceptT $ return (Left mempty)- ExceptT m `mplus` ExceptT n = ExceptT $ do- a <- m- case a of- Left e -> liftM (either (Left . mappend e) Right) n+ ExceptT mx `mplus` ExceptT my = ExceptT $ do+ ex <- mx+ case ex of+ Left e -> liftM (either (Left . mappend e) Right) my Right x -> return (Right x) instance (MonadFix m) => MonadFix (ExceptT e m) where@@ -188,6 +219,11 @@ instance (MonadIO m) => MonadIO (ExceptT e m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (ExceptT e m) where+ mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b+#endif -- | Signal an exception value @e@. --
Control/Monad/Trans/Identity.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -33,29 +39,37 @@ import Control.Applicative import Control.Monad (MonadPlus(mzero, mplus))+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix (MonadFix(mfix))+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif import Data.Foldable (Foldable(foldMap)) import Data.Traversable (Traversable(traverse)) -- | The trivial monad transformer, which maps a monad to an equivalent monad. newtype IdentityT f a = IdentityT { runIdentityT :: f a } -instance (Eq1 f, Eq a) => Eq (IdentityT f a) where- IdentityT x == IdentityT y = eq1 x y+instance (Eq1 f) => Eq1 (IdentityT f) where+ liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y -instance (Ord1 f, Ord a) => Ord (IdentityT f a) where- compare (IdentityT x) (IdentityT y) = compare1 x y+instance (Ord1 f) => Ord1 (IdentityT f) where+ liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y -instance (Read1 f, Read a) => Read (IdentityT f a) where- readsPrec = readsData $ readsUnary1 "IdentityT" IdentityT+instance (Read1 f) => Read1 (IdentityT f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT -instance (Show1 f, Show a) => Show (IdentityT f a) where- showsPrec d (IdentityT m) = showsUnary1 "IdentityT" d m+instance (Show1 f) => Show1 (IdentityT f) where+ liftShowsPrec sp sl d (IdentityT m) =+ showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m -instance (Eq1 f) => Eq1 (IdentityT f) where eq1 = (==)-instance (Ord1 f) => Ord1 (IdentityT f) where compare1 = compare-instance (Read1 f) => Read1 (IdentityT f) where readsPrec1 = readsPrec-instance (Show1 f) => Show1 (IdentityT f) where showsPrec1 = showsPrec+instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1+instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 instance (Functor m) => Functor (IdentityT m) where fmap f = mapIdentityT (fmap f)@@ -75,10 +89,17 @@ (<|>) = lift2IdentityT (<|>) instance (Monad m) => Monad (IdentityT m) where+#if !(MIN_VERSION_base(4,8,0)) return = IdentityT . return+#endif m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m fail msg = IdentityT $ fail msg +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where+ fail msg = IdentityT $ Fail.fail msg+#endif+ instance (MonadPlus m) => MonadPlus (IdentityT m) where mzero = IdentityT mzero mplus = lift2IdentityT mplus@@ -88,6 +109,11 @@ instance (MonadIO m) => MonadIO (IdentityT m) where liftIO = IdentityT . liftIO++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (IdentityT m) where+ mzipWith f = lift2IdentityT (mzipWith f)+#endif instance MonadTrans IdentityT where lift = IdentityT
Control/Monad/Trans/List.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -33,6 +36,12 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif import Data.Foldable (Foldable(foldMap)) import Data.Traversable (Traversable(traverse)) @@ -41,22 +50,30 @@ -- /Note:/ this does not yield a monad unless the argument monad is commutative. newtype ListT m a = ListT { runListT :: m [a] } -instance (Eq1 m, Eq a) => Eq (ListT m a) where- ListT x == ListT y = eq1 x y+instance (Eq1 m) => Eq1 (ListT m) where+ liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y -instance (Ord1 m, Ord a) => Ord (ListT m a) where- compare (ListT x) (ListT y) = compare1 x y+instance (Ord1 m) => Ord1 (ListT m) where+ liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y -instance (Read1 m, Read a) => Read (ListT m a) where- readsPrec = readsData $ readsUnary1 "ListT" ListT+instance (Read1 m) => Read1 (ListT m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Show1 m, Show a) => Show (ListT m a) where- showsPrec d (ListT m) = showsUnary1 "ListT" d m+instance (Show1 m) => Show1 (ListT m) where+ liftShowsPrec sp sl d (ListT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -instance (Eq1 m) => Eq1 (ListT m) where eq1 = (==)-instance (Ord1 m) => Ord1 (ListT m) where compare1 = compare-instance (Read1 m) => Read1 (ListT m) where readsPrec1 = readsPrec-instance (Show1 m) => Show1 (ListT m) where showsPrec1 = showsPrec+instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1+instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1+instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1+instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 -- | Map between 'ListT' computations. --@@ -82,13 +99,20 @@ m <|> n = ListT $ (++) <$> runListT m <*> runListT n instance (Monad m) => Monad (ListT m) where+#if !(MIN_VERSION_base(4,8,0)) return a = ListT $ return [a]+#endif m >>= k = ListT $ do a <- runListT m b <- mapM (runListT . k) a return (concat b) fail _ = ListT $ return [] +#if MIN_VERSION_base(4,9,0)+instance (Monad m) => Fail.MonadFail (ListT m) where+ fail _ = ListT $ return []+#endif+ instance (Monad m) => MonadPlus (ListT m) where mzero = ListT $ return [] m `mplus` n = ListT $ do@@ -103,6 +127,11 @@ instance (MonadIO m) => MonadIO (ListT m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (ListT m) where+ mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b+#endif -- | Lift a @callCC@ operation to the new monad. liftCallCC :: CallCC m [a] [b] -> CallCC (ListT m) a b
Control/Monad/Trans/Maybe.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -44,8 +47,14 @@ import Data.Functor.Classes import Control.Applicative-import Control.Monad (MonadPlus(mzero, mplus), liftM, ap)+import Control.Monad (MonadPlus(mzero, mplus), liftM)+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix (MonadFix(mfix))+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif import Data.Foldable (Foldable(foldMap)) import Data.Maybe (fromMaybe) import Data.Traversable (Traversable(traverse))@@ -60,22 +69,30 @@ -- computation does. newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } -instance (Eq1 m, Eq a) => Eq (MaybeT m a) where- MaybeT x == MaybeT y = eq1 x y+instance (Eq1 m) => Eq1 (MaybeT m) where+ liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y -instance (Ord1 m, Ord a) => Ord (MaybeT m a) where- compare (MaybeT x) (MaybeT y) = compare1 x y+instance (Ord1 m) => Ord1 (MaybeT m) where+ liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y -instance (Read1 m, Read a) => Read (MaybeT m a) where- readsPrec = readsData $ readsUnary1 "MaybeT" MaybeT+instance (Read1 m) => Read1 (MaybeT m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl -instance (Show1 m, Show a) => Show (MaybeT m a) where- showsPrec d (MaybeT m) = showsUnary1 "MaybeT" d m+instance (Show1 m) => Show1 (MaybeT m) where+ liftShowsPrec sp sl d (MaybeT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl -instance (Eq1 m) => Eq1 (MaybeT m) where eq1 = (==)-instance (Ord1 m) => Ord1 (MaybeT m) where compare1 = compare-instance (Read1 m) => Read1 (MaybeT m) where readsPrec1 = readsPrec-instance (Show1 m) => Show1 (MaybeT m) where showsPrec1 = showsPrec+instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1+instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1+instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1+instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 -- | Transform the computation inside a @MaybeT@. --@@ -103,22 +120,41 @@ traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a instance (Functor m, Monad m) => Applicative (MaybeT m) where- pure = return- (<*>) = ap- + pure = lift . return+ mf <*> mx = MaybeT $ do+ mb_f <- runMaybeT mf+ case mb_f of+ Nothing -> return Nothing+ Just f -> do+ mb_x <- runMaybeT mx+ case mb_x of+ Nothing -> return Nothing+ Just x -> return (Just (f x))+ instance (Functor m, Monad m) => Alternative (MaybeT m) where- empty = mzero- (<|>) = mplus+ empty = MaybeT (return Nothing)+ x <|> y = MaybeT $ do+ v <- runMaybeT x+ case v of+ Nothing -> runMaybeT y+ Just _ -> return v instance (Monad m) => Monad (MaybeT m) where- fail _ = MaybeT (return Nothing)+#if !(MIN_VERSION_base(4,8,0)) return = lift . return+#endif x >>= f = MaybeT $ do v <- runMaybeT x case v of Nothing -> return Nothing Just y -> runMaybeT (f y)+ fail _ = MaybeT (return Nothing) +#if MIN_VERSION_base(4,9,0)+instance (Monad m) => Fail.MonadFail (MaybeT m) where+ fail _ = MaybeT (return Nothing)+#endif+ instance (Monad m) => MonadPlus (MaybeT m) where mzero = MaybeT (return Nothing) mplus x y = MaybeT $ do@@ -136,6 +172,11 @@ instance (MonadIO m) => MonadIO (MaybeT m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (MaybeT m) where+ mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b+#endif -- | Lift a @callCC@ operation to the new monad. liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b
Control/Monad/Trans/RWS.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.RWS
Control/Monad/Trans/RWS/Lazy.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -64,6 +67,9 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix import Data.Monoid @@ -161,24 +167,34 @@ fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where- pure = return- (<*>) = ap+ pure a = RWST $ \ _ s -> return (a, s, mempty)+ RWST mf <*> RWST mx = RWST $ \ r s -> do+ ~(f, s', w) <- mf r s+ ~(x, s'',w') <- mx r s'+ return (f x, s'', w `mappend` w') instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where- empty = mzero- (<|>) = mplus+ empty = RWST $ \ _ _ -> mzero+ RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s instance (Monoid w, Monad m) => Monad (RWST r w s m) where+#if !(MIN_VERSION_base(4,8,0)) return a = RWST $ \ _ s -> return (a, s, mempty)+#endif m >>= k = RWST $ \ r s -> do ~(a, s', w) <- runRWST m r s ~(b, s'',w') <- runRWST (k a) r s' return (b, s'', w `mappend` w') fail msg = RWST $ \ _ _ -> fail msg +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where+ fail msg = RWST $ \ _ _ -> Fail.fail msg+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where- mzero = RWST $ \ _ _ -> mzero- m `mplus` n = RWST $ \ r s -> runRWST m r s `mplus` runRWST n r s+ mzero = RWST $ \ _ _ -> mzero+ RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s@@ -288,7 +304,7 @@ -- * @'modify' f = 'get' >>= ('put' . f)@ modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () modify f = RWST $ \ _ s -> return ((), f s, mempty)- + -- | Get a specific component of the state, using a projection function -- supplied. --
Control/Monad/Trans/RWS/Strict.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -64,6 +67,9 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix import Data.Monoid @@ -161,24 +167,34 @@ fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where- pure = return- (<*>) = ap+ pure a = RWST $ \ _ s -> return (a, s, mempty)+ RWST mf <*> RWST mx = RWST $ \ r s -> do+ (f, s', w) <- mf r s+ (x, s'',w') <- mx r s'+ return (f x, s'', w `mappend` w') instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where- empty = mzero- (<|>) = mplus+ empty = RWST $ \ _ _ -> mzero+ RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s instance (Monoid w, Monad m) => Monad (RWST r w s m) where+#if !(MIN_VERSION_base(4,8,0)) return a = RWST $ \ _ s -> return (a, s, mempty)+#endif m >>= k = RWST $ \ r s -> do (a, s', w) <- runRWST m r s (b, s'',w') <- runRWST (k a) r s' return (b, s'', w `mappend` w') fail msg = RWST $ \ _ _ -> fail msg +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where+ fail msg = RWST $ \ _ _ -> Fail.fail msg+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where- mzero = RWST $ \ _ _ -> mzero- m `mplus` n = RWST $ \ r s -> runRWST m r s `mplus` runRWST n r s+ mzero = RWST $ \ _ _ -> mzero+ RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s@@ -288,7 +304,7 @@ -- * @'modify' f = 'get' >>= ('put' . f)@ modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () modify f = RWST $ \ _ s -> return ((), f s, mempty)- + -- | Get a specific component of the state, using a projection function -- supplied. --
Control/Monad/Trans/Reader.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -47,10 +53,16 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix #if !(MIN_VERSION_base(4,6,0)) import Control.Monad.Instances () -- deprecated from base-4.6 #endif+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif -- | The parameterizable reader monad. --@@ -123,12 +135,19 @@ m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r instance (Monad m) => Monad (ReaderT r m) where+#if !(MIN_VERSION_base(4,8,0)) return = lift . return+#endif m >>= k = ReaderT $ \ r -> do a <- runReaderT m r runReaderT (k a) r fail msg = lift (fail msg) +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where+ fail msg = lift (Fail.fail msg)+#endif+ instance (MonadPlus m) => MonadPlus (ReaderT r m) where mzero = lift mzero m `mplus` n = ReaderT $ \ r -> runReaderT m r `mplus` runReaderT n r@@ -141,6 +160,12 @@ instance (MonadIO m) => MonadIO (ReaderT r m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (MonadZip m) => MonadZip (ReaderT r m) where+ mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a ->+ mzipWith f (m a) (n a)+#endif liftReaderT :: m a -> ReaderT r m a liftReaderT m = ReaderT (const m)
Control/Monad/Trans/State.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.State
Control/Monad/Trans/State/Lazy.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -77,6 +80,9 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix -- ---------------------------------------------------------------------------@@ -182,23 +188,34 @@ fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s instance (Functor m, Monad m) => Applicative (StateT s m) where- pure = return- (<*>) = ap+ pure a = StateT $ \ s -> return (a, s)+ StateT mf <*> StateT mx = StateT $ \ s -> do+ ~(f, s') <- mf s+ ~(x, s'') <- mx s'+ return (f x, s'')+ {-# INLINE (<*>) #-} instance (Functor m, MonadPlus m) => Alternative (StateT s m) where- empty = mzero- (<|>) = mplus+ empty = StateT $ \ _ -> mzero+ StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s instance (Monad m) => Monad (StateT s m) where- return a = state $ \ s -> (a, s)+#if !(MIN_VERSION_base(4,8,0))+ return a = StateT $ \ s -> return (a, s)+#endif m >>= k = StateT $ \ s -> do ~(a, s') <- runStateT m s runStateT (k a) s' fail str = StateT $ \ _ -> fail str +#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where+ fail str = StateT $ \ _ -> Fail.fail str+#endif+ instance (MonadPlus m) => MonadPlus (StateT s m) where mzero = StateT $ \ _ -> mzero- m `mplus` n = StateT $ \ s -> runStateT m s `mplus` runStateT n s+ StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s instance (MonadFix m) => MonadFix (StateT s m) where mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s
Control/Monad/Trans/State/Strict.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -74,6 +77,9 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix -- ---------------------------------------------------------------------------@@ -179,19 +185,30 @@ fmap (\ (a, s') -> (f a, s')) $ runStateT m s instance (Functor m, Monad m) => Applicative (StateT s m) where- pure = return- (<*>) = ap+ pure a = StateT $ \ s -> return (a, s)+ StateT mf <*> StateT mx = StateT $ \ s -> do+ (f, s') <- mf s+ (x, s'') <- mx s'+ return (f x, s'')+ {-# INLINE (<*>) #-} instance (Functor m, MonadPlus m) => Alternative (StateT s m) where- empty = mzero- (<|>) = mplus+ empty = StateT $ \ _ -> mzero+ StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s instance (Monad m) => Monad (StateT s m) where- return a = state $ \ s -> (a, s)+#if !(MIN_VERSION_base(4,8,0))+ return a = StateT $ \ s -> return (a, s)+#endif m >>= k = StateT $ \ s -> do (a, s') <- runStateT m s runStateT (k a) s' fail str = StateT $ \ _ -> fail str++#if MIN_VERSION_base(4,9,0)+instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where+ fail str = StateT $ \ _ -> Fail.fail str+#endif instance (MonadPlus m) => MonadPlus (StateT s m) where mzero = StateT $ \ _ -> mzero
Control/Monad/Trans/Writer.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Writer
Control/Monad/Trans/Writer/Lazy.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -53,8 +56,14 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix import Control.Monad.Signatures+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif import Data.Foldable (Foldable(foldMap)) import Data.Monoid import Data.Traversable (Traversable(traverse))@@ -100,22 +109,33 @@ -- combines the outputs of the subcomputations using 'mappend'. newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } -instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where- WriterT x == WriterT y = eq1 x y+instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where+ liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 -instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where- compare (WriterT x) (WriterT y) = compare1 x y+instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where+ liftCompare comp (WriterT m1) (WriterT m2) =+ liftCompare (liftCompare2 comp compare) m1 m2 -instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where- readsPrec = readsData $ readsUnary1 "WriterT" WriterT+instance (Read w, Read1 m) => Read1 (WriterT w m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT+ where+ rp' = liftReadsPrec2 rp rl readsPrec readList+ rl' = liftReadList2 rp rl readsPrec readList -instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where- showsPrec d (WriterT m) = showsUnary1 "WriterT" d m+instance (Show w, Show1 m) => Show1 (WriterT w m) where+ liftShowsPrec sp sl d (WriterT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m+ where+ sp' = liftShowsPrec2 sp sl showsPrec showList+ sl' = liftShowList2 sp sl showsPrec showList -instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where eq1 = (==)-instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where compare1 = compare-instance (Read w, Read1 m) => Read1 (WriterT w m) where readsPrec1 = readsPrec-instance (Show w, Show1 m) => Show1 (WriterT w m) where showsPrec1 = showsPrec+instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1+instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1+instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where+ readsPrec = readsPrec1+instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where+ showsPrec = showsPrec1 -- | Extract the output from a writer computation. --@@ -152,13 +172,20 @@ m <|> n = WriterT $ runWriterT m <|> runWriterT n instance (Monoid w, Monad m) => Monad (WriterT w m) where+#if !(MIN_VERSION_base(4,8,0)) return a = writer (a, mempty)+#endif m >>= k = WriterT $ do ~(a, w) <- runWriterT m ~(b, w') <- runWriterT (k a) return (b, w `mappend` w') fail msg = WriterT $ fail msg +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where+ fail msg = WriterT $ Fail.fail msg+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where mzero = WriterT mzero m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n@@ -173,6 +200,12 @@ instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where+ mzipWith f (WriterT x) (WriterT y) = WriterT $+ mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y+#endif -- | @'tell' w@ is an action that produces the output @w@. tell :: (Monad m) => w -> WriterT w m ()
Control/Monad/Trans/Writer/Strict.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -56,8 +59,14 @@ import Control.Applicative import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Fix import Control.Monad.Signatures+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif import Data.Foldable (Foldable(foldMap)) import Data.Monoid import Data.Traversable (Traversable(traverse))@@ -103,22 +112,33 @@ -- combines the outputs of the subcomputations using 'mappend'. newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } -instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where- WriterT x == WriterT y = eq1 x y+instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where+ liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 -instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where- compare (WriterT x) (WriterT y) = compare1 x y+instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where+ liftCompare comp (WriterT m1) (WriterT m2) =+ liftCompare (liftCompare2 comp compare) m1 m2 -instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where- readsPrec = readsData $ readsUnary1 "WriterT" WriterT+instance (Read w, Read1 m) => Read1 (WriterT w m) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT+ where+ rp' = liftReadsPrec2 rp rl readsPrec readList+ rl' = liftReadList2 rp rl readsPrec readList -instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where- showsPrec d (WriterT m) = showsUnary1 "WriterT" d m+instance (Show w, Show1 m) => Show1 (WriterT w m) where+ liftShowsPrec sp sl d (WriterT m) =+ showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m+ where+ sp' = liftShowsPrec2 sp sl showsPrec showList+ sl' = liftShowList2 sp sl showsPrec showList -instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where eq1 = (==)-instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where compare1 = compare-instance (Read w, Read1 m) => Read1 (WriterT w m) where readsPrec1 = readsPrec-instance (Show w, Show1 m) => Show1 (WriterT w m) where showsPrec1 = showsPrec+instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1+instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1+instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where+ readsPrec = readsPrec1+instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where+ showsPrec = showsPrec1 -- | Extract the output from a writer computation. --@@ -155,13 +175,20 @@ m <|> n = WriterT $ runWriterT m <|> runWriterT n instance (Monoid w, Monad m) => Monad (WriterT w m) where+#if !(MIN_VERSION_base(4,8,0)) return a = writer (a, mempty)+#endif m >>= k = WriterT $ do (a, w) <- runWriterT m (b, w') <- runWriterT (k a) return (b, w `mappend` w') fail msg = WriterT $ fail msg +#if MIN_VERSION_base(4,9,0)+instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where+ fail msg = WriterT $ Fail.fail msg+#endif+ instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where mzero = WriterT mzero m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n@@ -176,6 +203,12 @@ instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where liftIO = lift . liftIO++#if MIN_VERSION_base(4,4,0)+instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where+ mzipWith f (WriterT x) (WriterT y) = WriterT $+ mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y+#endif -- | @'tell' w@ is an action that produces the output @w@. tell :: (Monad m) => w -> WriterT w m ()
− Data/Functor/Classes.hs
@@ -1,196 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709-{-# LANGUAGE AutoDeriveTypeable #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Functor.Classes--- Copyright : (c) Ross Paterson 2013--- License : BSD-style (see the file LICENSE)------ Maintainer : R.Paterson@city.ac.uk--- Stability : experimental--- Portability : portable------ Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to--- unary type constructors.------ These classes are needed to express the constraints on arguments of--- transformers in portable Haskell. Thus for a new transformer @T@,--- one might write instances like------ > instance (Eq1 f) => Eq (T f a) where ...--- > instance (Ord1 f) => Ord (T f a) where ...--- > instance (Read1 f) => Read (T f a) where ...--- > instance (Show1 f) => Show (T f a) where ...------ If these instances can be defined, defining instances of the lifted--- classes is mechanical:------ > instance (Eq1 f) => Eq1 (T f) where eq1 = (==)--- > instance (Ord1 f) => Ord1 (T f) where compare1 = compare--- > instance (Read1 f) => Read1 (T f) where readsPrec1 = readsPrec--- > instance (Show1 f) => Show1 (T f) where showsPrec1 = showsPrec-----------------------------------------------------------------------------------module Data.Functor.Classes (- -- * Liftings of Prelude classes- Eq1(..),- Ord1(..),- Read1(..),- Show1(..),- -- * Helper functions- -- $example- readsData,- readsUnary,- readsUnary1,- readsBinary1,- showsUnary,- showsUnary1,- showsBinary1,- ) where--#if MIN_VERSION_base(4,8,0)-import Control.Applicative (Const)-#else-import Control.Applicative (Const(Const))-#endif-import Data.Functor.Identity (Identity)---- | Lifting of the 'Eq' class to unary type constructors.-class Eq1 f where- eq1 :: (Eq a) => f a -> f a -> Bool---- | Lifting of the 'Ord' class to unary type constructors.-class (Eq1 f) => Ord1 f where- compare1 :: (Ord a) => f a -> f a -> Ordering---- | Lifting of the 'Read' class to unary type constructors.-class Read1 f where- readsPrec1 :: (Read a) => Int -> ReadS (f a)---- | Lifting of the 'Show' class to unary type constructors.-class Show1 f where- showsPrec1 :: (Show a) => Int -> f a -> ShowS---- Instances for Prelude type constructors--instance Eq1 Maybe where eq1 = (==)-instance Ord1 Maybe where compare1 = compare-instance Read1 Maybe where readsPrec1 = readsPrec-instance Show1 Maybe where showsPrec1 = showsPrec--instance Eq1 [] where eq1 = (==)-instance Ord1 [] where compare1 = compare-instance Read1 [] where readsPrec1 = readsPrec-instance Show1 [] where showsPrec1 = showsPrec--instance (Eq a) => Eq1 ((,) a) where eq1 = (==)-instance (Ord a) => Ord1 ((,) a) where compare1 = compare-instance (Read a) => Read1 ((,) a) where readsPrec1 = readsPrec-instance (Show a) => Show1 ((,) a) where showsPrec1 = showsPrec--instance (Eq a) => Eq1 (Either a) where eq1 = (==)-instance (Ord a) => Ord1 (Either a) where compare1 = compare-instance (Read a) => Read1 (Either a) where readsPrec1 = readsPrec-instance (Show a) => Show1 (Either a) where showsPrec1 = showsPrec---- Instances for other functors defined in the base package--instance Eq1 Identity where eq1 = (==)-instance Ord1 Identity where compare1 = compare-instance Read1 Identity where readsPrec1 = readsPrec-instance Show1 Identity where showsPrec1 = showsPrec--#if MIN_VERSION_base(4,8,0)--- Eq, etc instances for Const were introduced in base-4.8-instance (Eq a) => Eq1 (Const a) where eq1 = (==)-instance (Ord a) => Ord1 (Const a) where compare1 = compare-instance (Read a) => Read1 (Const a) where readsPrec1 = readsPrec-instance (Show a) => Show1 (Const a) where showsPrec1 = showsPrec-#else-instance (Eq a) => Eq1 (Const a) where- eq1 (Const x) (Const y) = x == y-instance (Ord a) => Ord1 (Const a) where- compare1 (Const x) (Const y) = compare x y-instance (Read a) => Read1 (Const a) where- readsPrec1 = readsData $ readsUnary "Const" Const-instance (Show a) => Show1 (Const a) where- showsPrec1 d (Const x) = showsUnary "Const" d x-#endif---- Building blocks---- | @'readsData' p d@ is a parser for datatypes where each alternative--- begins with a data constructor. It parses the constructor and--- passes it to @p@. Parsers for various constructors can be constructed--- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with--- @mappend@ from the @Monoid@ class.-readsData :: (String -> ReadS a) -> Int -> ReadS a-readsData reader d =- readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]---- | @'readsUnary' n c n'@ matches the name of a unary data constructor--- and then parses its argument using 'readsPrec'.-readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t-readsUnary name cons kw s =- [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]---- | @'readsUnary1' n c n'@ matches the name of a unary data constructor--- and then parses its argument using 'readsPrec1'.-readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t-readsUnary1 name cons kw s =- [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]---- | @'readsBinary1' n c n'@ matches the name of a binary data constructor--- and then parses its arguments using 'readsPrec1'.-readsBinary1 :: (Read1 f, Read1 g, Read a) =>- String -> (f a -> g a -> t) -> String -> ReadS t-readsBinary1 name cons kw s =- [(cons x y,u) | kw == name,- (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]---- | @'showsUnary' n d x@ produces the string representation of a unary data--- constructor with name @n@ and argument @x@, in precedence context @d@.-showsUnary :: (Show a) => String -> Int -> a -> ShowS-showsUnary name d x = showParen (d > 10) $- showString name . showChar ' ' . showsPrec 11 x---- | @'showsUnary1' n d x@ produces the string representation of a unary data--- constructor with name @n@ and argument @x@, in precedence context @d@.-showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS-showsUnary1 name d x = showParen (d > 10) $- showString name . showChar ' ' . showsPrec1 11 x---- | @'showsBinary1' n d x@ produces the string representation of a binary--- data constructor with name @n@ and arguments @x@ and @y@, in precedence--- context @d@.-showsBinary1 :: (Show1 f, Show1 g, Show a) =>- String -> Int -> f a -> g a -> ShowS-showsBinary1 name d x y = showParen (d > 10) $- showString name . showChar ' ' . showsPrec1 11 x .- showChar ' ' . showsPrec1 11 y--{- $example-These functions can be used to assemble 'Read' and 'Show' instances for-new algebraic types. For example, given the definition--> data T f a = Zero a | One (f a) | Two (f a) (f a)--a standard 'Read' instance may be defined as--> instance (Read1 f, Read a) => Read (T f a) where-> readsPrec = readsData $-> readsUnary "Zero" Zero `mappend`-> readsUnary1 "One" One `mappend`-> readsBinary1 "Two" Two--and the corresponding 'Show' instance as--> instance (Show1 f, Show a) => Show (T f a) where-> showsPrec d (Zero x) = showsUnary "Zero" d x-> showsPrec d (One x) = showsUnary1 "One" d x-> showsPrec d (Two x y) = showsBinary1 "Two" d x y---}
− Data/Functor/Compose.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709-{-# LANGUAGE AutoDeriveTypeable #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Functor.Compose--- Copyright : (c) Ross Paterson 2010--- License : BSD-style (see the file LICENSE)------ Maintainer : R.Paterson@city.ac.uk--- Stability : experimental--- Portability : portable------ Composition of functors.--------------------------------------------------------------------------------module Data.Functor.Compose (- Compose(..),- ) where--import Data.Functor.Classes--import Control.Applicative-import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable(traverse))--infixr 9 `Compose`---- | Right-to-left composition of functors.--- The composition of applicative functors is always applicative,--- but the composition of monads is not always a monad.-newtype Compose f g a = Compose { getCompose :: f (g a) }---- Instances of Prelude classes---- kludge to get type with the same instances as g a-newtype Apply g a = Apply (g a)--getApply :: Apply g a -> g a-getApply (Apply x) = x--instance (Eq1 g, Eq a) => Eq (Apply g a) where- Apply x == Apply y = eq1 x y--instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y--instance (Read1 g, Read a) => Read (Apply g a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]--instance (Show1 g, Show a) => Show (Apply g a) where- showsPrec d (Apply x) = showsPrec1 d x--instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where- Compose x == Compose y = eq1 (fmap Apply x) (fmap Apply y)--instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where- compare (Compose x) (Compose y) = compare1 (fmap Apply x) (fmap Apply y)--instance (Functor f, Read1 f, Read1 g, Read a) => Read (Compose f g a) where- readsPrec = readsData $ readsUnary1 "Compose" (Compose . fmap getApply)--instance (Functor f, Show1 f, Show1 g, Show a) => Show (Compose f g a) where- showsPrec d (Compose x) = showsUnary1 "Compose" d (fmap Apply x)--instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Compose f g) where eq1 = (==)-instance (Functor f, Ord1 f, Ord1 g) => Ord1 (Compose f g) where- compare1 = compare-instance (Functor f, Read1 f, Read1 g) => Read1 (Compose f g) where- readsPrec1 = readsPrec-instance (Functor f, Show1 f, Show1 g) => Show1 (Compose f g) where- showsPrec1 = showsPrec---- Functor instances--instance (Functor f, Functor g) => Functor (Compose f g) where- fmap f (Compose x) = Compose (fmap (fmap f) x)--instance (Foldable f, Foldable g) => Foldable (Compose f g) where- foldMap f (Compose t) = foldMap (foldMap f) t--instance (Traversable f, Traversable g) => Traversable (Compose f g) where- traverse f (Compose t) = Compose <$> traverse (traverse f) t--instance (Applicative f, Applicative g) => Applicative (Compose f g) where- pure x = Compose (pure (pure x))- Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)--instance (Alternative f, Applicative g) => Alternative (Compose f g) where- empty = Compose empty- Compose x <|> Compose y = Compose (x <|> y)
Data/Functor/Constant.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -25,6 +31,9 @@ import Data.Foldable (Foldable(foldMap)) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse))+#if MIN_VERSION_base(4,8,0)+import Data.Bifunctor (Bifunctor(..))+#endif -- | Constant functor. newtype Constant a b = Constant { getConstant :: a }@@ -34,16 +43,36 @@ -- newtype if the field were removed. instance (Read a) => Read (Constant a b) where- readsPrec = readsData $ readsUnary "Constant" Constant+ readsPrec = readsData $+ readsUnaryWith readsPrec "Constant" Constant instance (Show a) => Show (Constant a b) where- showsPrec d (Constant x) = showsUnary "Constant" d x+ showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x -instance (Eq a) => Eq1 (Constant a) where eq1 = (==)-instance (Ord a) => Ord1 (Constant a) where compare1 = compare-instance (Read a) => Read1 (Constant a) where readsPrec1 = readsPrec-instance (Show a) => Show1 (Constant a) where showsPrec1 = showsPrec+-- Instances of lifted Prelude classes +instance Eq2 Constant where+ liftEq2 eq _ (Constant x) (Constant y) = eq x y++instance Ord2 Constant where+ liftCompare2 comp _ (Constant x) (Constant y) = comp x y++instance Read2 Constant where+ liftReadsPrec2 rp _ _ _ = readsData $+ readsUnaryWith rp "Constant" Constant++instance Show2 Constant where+ liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x++instance (Eq a) => Eq1 (Constant a) where+ liftEq = liftEq2 (==)+instance (Ord a) => Ord1 (Constant a) where+ liftCompare = liftCompare2 compare+instance (Read a) => Read1 (Constant a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Show a) => Show1 (Constant a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+ instance Functor (Constant a) where fmap _ (Constant x) = Constant x @@ -56,3 +85,13 @@ instance (Monoid a) => Applicative (Constant a) where pure _ = Constant mempty Constant x <*> Constant y = Constant (x `mappend` y)++instance (Monoid a) => Monoid (Constant a b) where+ mempty = Constant mempty+ Constant x `mappend` Constant y = Constant (x `mappend` y)++#if MIN_VERSION_base(4,8,0)+instance Bifunctor Constant where+ first f (Constant x) = Constant (f x)+ second _ (Constant x) = Constant x+#endif
− Data/Functor/Product.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709-{-# LANGUAGE AutoDeriveTypeable #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Functor.Product--- Copyright : (c) Ross Paterson 2010--- License : BSD-style (see the file LICENSE)------ Maintainer : R.Paterson@city.ac.uk--- Stability : experimental--- Portability : portable------ Products, lifted to functors.--------------------------------------------------------------------------------module Data.Functor.Product (- Product(..),- ) where--import Control.Applicative-import Control.Monad (MonadPlus(..))-import Control.Monad.Fix (MonadFix(..))-import Data.Foldable (Foldable(foldMap))-import Data.Functor.Classes-import Data.Monoid (mappend)-import Data.Traversable (Traversable(traverse))---- | Lifted product of functors.-data Product f g a = Pair (f a) (g a)--instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) where- Pair x1 y1 == Pair x2 y2 = eq1 x1 x2 && eq1 y1 y2--instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where- compare (Pair x1 y1) (Pair x2 y2) =- compare1 x1 x2 `mappend` compare1 y1 y2--instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where- readsPrec = readsData $ readsBinary1 "Pair" Pair--instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where- showsPrec d (Pair x y) = showsBinary1 "Pair" d x y--instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where eq1 = (==)-instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where compare1 = compare-instance (Read1 f, Read1 g) => Read1 (Product f g) where readsPrec1 = readsPrec-instance (Show1 f, Show1 g) => Show1 (Product f g) where showsPrec1 = showsPrec--instance (Functor f, Functor g) => Functor (Product f g) where- fmap f (Pair x y) = Pair (fmap f x) (fmap f y)--instance (Foldable f, Foldable g) => Foldable (Product f g) where- foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y--instance (Traversable f, Traversable g) => Traversable (Product f g) where- traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y--instance (Applicative f, Applicative g) => Applicative (Product f g) where- pure x = Pair (pure x) (pure x)- Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)--instance (Alternative f, Alternative g) => Alternative (Product f g) where- empty = Pair empty empty- Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)--instance (Monad f, Monad g) => Monad (Product f g) where- return x = Pair (return x) (return x)- Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)- where- fstP (Pair a _) = a- sndP (Pair _ b) = b--instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where- mzero = Pair mzero mzero- Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)--instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where- mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))- where- fstP (Pair a _) = a- sndP (Pair _ b) = b
Data/Functor/Reverse.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -33,22 +39,24 @@ -- that process the elements in the reverse order. newtype Reverse f a = Reverse { getReverse :: f a } -instance (Eq1 f, Eq a) => Eq (Reverse f a) where- Reverse x == Reverse y = eq1 x y+instance (Eq1 f) => Eq1 (Reverse f) where+ liftEq eq (Reverse x) (Reverse y) = liftEq eq x y -instance (Ord1 f, Ord a) => Ord (Reverse f a) where- compare (Reverse x) (Reverse y) = compare1 x y+instance (Ord1 f) => Ord1 (Reverse f) where+ liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y -instance (Read1 f, Read a) => Read (Reverse f a) where- readsPrec = readsData $ readsUnary1 "Reverse" Reverse+instance (Read1 f) => Read1 (Reverse f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse -instance (Show1 f, Show a) => Show (Reverse f a) where- showsPrec d (Reverse x) = showsUnary1 "Reverse" d x+instance (Show1 f) => Show1 (Reverse f) where+ liftShowsPrec sp sl d (Reverse x) =+ showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x -instance (Eq1 f) => Eq1 (Reverse f) where eq1 = (==)-instance (Ord1 f) => Ord1 (Reverse f) where compare1 = compare-instance (Read1 f) => Read1 (Reverse f) where readsPrec1 = readsPrec-instance (Show1 f) => Show1 (Reverse f) where showsPrec1 = showsPrec+instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1+instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1+instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1+instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 -- | Derived instance. instance (Functor f) => Functor (Reverse f) where
− Data/Functor/Sum.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 709-{-# LANGUAGE AutoDeriveTypeable #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Functor.Sum--- Copyright : (c) Ross Paterson 2014--- License : BSD-style (see the file LICENSE)------ Maintainer : R.Paterson@city.ac.uk--- Stability : experimental--- Portability : portable------ Sums, lifted to functors.--------------------------------------------------------------------------------module Data.Functor.Sum (- Sum(..),- ) where--import Control.Applicative-import Data.Foldable (Foldable(foldMap))-import Data.Functor.Classes-import Data.Monoid (mappend)-import Data.Traversable (Traversable(traverse))---- | Lifted sum of functors.-data Sum f g a = InL (f a) | InR (g a)--instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where- InL x1 == InL x2 = eq1 x1 x2- InR y1 == InR y2 = eq1 y1 y2- _ == _ = False--instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where- compare (InL x1) (InL x2) = compare1 x1 x2- compare (InL _) (InR _) = LT- compare (InR _) (InL _) = GT- compare (InR y1) (InR y2) = compare1 y1 y2--instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where- readsPrec = readsData $- readsUnary1 "InL" InL `mappend` readsUnary1 "InR" InR--instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where- showsPrec d (InL x) = showsUnary1 "InL" d x- showsPrec d (InR y) = showsUnary1 "InR" d y--instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where eq1 = (==)-instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where compare1 = compare-instance (Read1 f, Read1 g) => Read1 (Sum f g) where readsPrec1 = readsPrec-instance (Show1 f, Show1 g) => Show1 (Sum f g) where showsPrec1 = showsPrec--instance (Functor f, Functor g) => Functor (Sum f g) where- fmap f (InL x) = InL (fmap f x)- fmap f (InR y) = InR (fmap f y)--instance (Foldable f, Foldable g) => Foldable (Sum f g) where- foldMap f (InL x) = foldMap f x- foldMap f (InR y) = foldMap f y--instance (Traversable f, Traversable g) => Traversable (Sum f g) where- traverse f (InL x) = InL <$> traverse f x- traverse f (InR y) = InR <$> traverse f y
changelog view
@@ -1,5 +1,12 @@ -*-change-log-*- +0.5.0.0 Ross Paterson <R.Paterson@city.ac.uk> Dec 2015+ * Control.Monad.IO.Class in base for GHC >= 8.0+ * Data.Functor.{Classes,Compose,Product,Sum} in base for GHC >= 8.0+ * Added PolyKinds for GHC >= 7.4+ * Added instances of base classes MonadZip and MonadFail+ * Changed liftings of Prelude classes to use explicit dictionaries+ 0.4.3.0 Ross Paterson <R.Paterson@city.ac.uk> Mar 2015 * Added Eq1, Ord1, Show1 and Read1 instances for Const
+ legacy/pre709/Data/Functor/Identity.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 612+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Identity+-- Copyright : (c) Andy Gill 2001,+-- (c) Oregon Graduate Institute of Science and Technology 2001+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : ross@soi.city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- The identity functor and monad.+--+-- This trivial type constructor serves two purposes:+--+-- * It can be used with functions parameterized by functor or monad classes.+--+-- * It can be used as a base monad to which a series of monad+-- transformers may be applied to construct a composite monad.+-- Most monad transformer modules include the special case of+-- applying the transformer to 'Identity'. For example, @State s@+-- is an abbreviation for @StateT s 'Identity'@.+-----------------------------------------------------------------------------++module Data.Functor.Identity (+ Identity(..),+ ) where++import Control.Applicative+import Control.Monad.Fix+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith, munzip))+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(mempty, mappend))+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 612+import Data.Data+#endif+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++-- | Identity functor and monad. (a non-strict monad)+newtype Identity a = Identity { runIdentity :: a }+ deriving ( Eq, Ord+#if __GLASGOW_HASKELL__ >= 612+ , Data, Typeable+#endif+#if __GLASGOW_HASKELL__ >= 702+ , Generic+#endif+#if __GLASGOW_HASKELL__ >= 706+ , Generic1+#endif+ )++instance (Monoid a) => Monoid (Identity a) where+ mempty = Identity mempty+ mappend (Identity x) (Identity y) = Identity (mappend x y)++-- These instances would be equivalent to the derived instances of the+-- newtype if the field were removed.++instance (Read a) => Read (Identity a) where+ readsPrec d = readParen (d > 10) $ \ r ->+ [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s]++instance (Show a) => Show (Identity a) where+ showsPrec d (Identity x) = showParen (d > 10) $+ showString "Identity " . showsPrec 11 x++-- ---------------------------------------------------------------------------+-- Identity instances for Functor and Monad++instance Functor Identity where+ fmap f m = Identity (f (runIdentity m))++instance Foldable Identity where+ foldMap f (Identity x) = f x++instance Traversable Identity where+ traverse f (Identity x) = Identity <$> f x++instance Applicative Identity where+ pure a = Identity a+ Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+ return a = Identity a+ m >>= k = k (runIdentity m)++instance MonadFix Identity where+ mfix f = Identity (fix (runIdentity . f))++#if MIN_VERSION_base(4,4,0)+instance MonadZip Identity where+ mzipWith f (Identity x) (Identity y) = Identity (f x y)+ munzip (Identity (a, b)) = (Identity a, Identity b)+#endif
+ legacy/pre711/Control/Monad/IO/Class.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.IO.Class+-- Copyright : (c) Andy Gill 2001,+-- (c) Oregon Graduate Institute of Science and Technology, 2001+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Class of monads based on @IO@.+-----------------------------------------------------------------------------++module Control.Monad.IO.Class (+ MonadIO(..)+ ) where++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++-- | Monads in which 'IO' computations may be embedded.+-- Any monad built by applying a sequence of monad transformers to the+-- 'IO' monad will be an instance of this class.+--+-- Instances should satisfy the following laws, which state that 'liftIO'+-- is a transformer of monads:+--+-- * @'liftIO' . 'return' = 'return'@+--+-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@++class (Monad m) => MonadIO m where+ -- | Lift a computation from the 'IO' monad.+ liftIO :: IO a -> m a++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable MonadIO+#endif++instance MonadIO IO where+ liftIO = id
+ legacy/pre711/Data/Functor/Classes.hs view
@@ -0,0 +1,511 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Classes+-- Copyright : (c) Ross Paterson 2013+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to+-- unary and binary type constructors.+--+-- These classes are needed to express the constraints on arguments of+-- transformers in portable Haskell. Thus for a new transformer @T@,+-- one might write instances like+--+-- > instance (Eq1 f) => Eq1 (T f) where ...+-- > instance (Ord1 f) => Ord1 (T f) where ...+-- > instance (Read1 f) => Read1 (T f) where ...+-- > instance (Show1 f) => Show1 (T f) where ...+--+-- If these instances can be defined, defining instances of the base+-- classes is mechanical:+--+-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1+-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1+-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1+-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1+--+-----------------------------------------------------------------------------++module Data.Functor.Classes (+ -- * Liftings of Prelude classes+ -- ** For unary constructors+ Eq1(..), eq1,+ Ord1(..), compare1,+ Read1(..), readsPrec1,+ Show1(..), showsPrec1,+ -- ** For binary constructors+ Eq2(..), eq2,+ Ord2(..), compare2,+ Read2(..), readsPrec2,+ Show2(..), showsPrec2,+ -- * Helper functions+ -- $example+ readsData,+ readsUnaryWith,+ readsBinaryWith,+ showsUnaryWith,+ showsBinaryWith,+ -- ** Obsolete helpers+ readsUnary,+ readsUnary1,+ readsBinary1,+ showsUnary,+ showsUnary1,+ showsBinary1,+ ) where++import Control.Applicative (Const(Const))+import Data.Functor.Identity (Identity(Identity))+import Data.Monoid (mappend)+#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+import Text.Show (showListWith)++-- | Lifting of the 'Eq' class to unary type constructors.+class Eq1 f where+ -- | Lift an equality test through the type constructor.+ --+ -- The function will usually be applied to an equality function,+ -- but the more general type ensures that the implementation uses+ -- it to compare elements of the first container with elements of+ -- the second.+ liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Eq1+#endif++-- | Lift the standard @('==')@ function through the type constructor.+eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool+eq1 = liftEq (==)++-- | Lifting of the 'Ord' class to unary type constructors.+class (Eq1 f) => Ord1 f where+ -- | Lift a 'compare' function through the type constructor.+ --+ -- The function will usually be applied to a comparison function,+ -- but the more general type ensures that the implementation uses+ -- it to compare elements of the first container with elements of+ -- the second.+ liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Ord1+#endif++-- | Lift the standard 'compare' function through the type constructor.+compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering+compare1 = liftCompare compare++-- | Lifting of the 'Read' class to unary type constructors.+class Read1 f where+ -- | 'readsPrec' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument type.+ liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)++ -- | 'readList' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument type.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]+ liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Read1+#endif++-- | Read a list (using square brackets and commas), given a function+-- for reading elements.+readListWith :: ReadS a -> ReadS [a]+readListWith rp =+ readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])+ where+ readl s = [([],t) | ("]",t) <- lex s] +++ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]+ readl' s = [([],t) | ("]",t) <- lex s] +++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]++-- | Lift the standard 'readsPrec' and 'readList' functions through the+-- type constructor.+readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)+readsPrec1 = liftReadsPrec readsPrec readList++-- | Lifting of the 'Show' class to unary type constructors.+class Show1 f where+ -- | 'showsPrec' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument type.+ liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ Int -> f a -> ShowS++ -- | 'showList' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument type.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ [f a] -> ShowS+ liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Show1+#endif++-- | Lift the standard 'showsPrec' and 'showList' functions through the+-- type constructor.+showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS+showsPrec1 = liftShowsPrec showsPrec showList++-- | Lifting of the 'Eq' class to binary type constructors.+class Eq2 f where+ -- | Lift equality tests through the type constructor.+ --+ -- The function will usually be applied to equality functions,+ -- but the more general type ensures that the implementation uses+ -- them to compare elements of the first container with elements of+ -- the second.+ liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Eq2+#endif++-- | Lift the standard @('==')@ function through the type constructor.+eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool+eq2 = liftEq2 (==) (==)++-- | Lifting of the 'Ord' class to binary type constructors.+class (Eq2 f) => Ord2 f where+ -- | Lift 'compare' functions through the type constructor.+ --+ -- The function will usually be applied to comparison functions,+ -- but the more general type ensures that the implementation uses+ -- them to compare elements of the first container with elements of+ -- the second.+ liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->+ f a c -> f b d -> Ordering++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Ord2+#endif++-- | Lift the standard 'compare' function through the type constructor.+compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering+compare2 = liftCompare2 compare compare++-- | Lifting of the 'Read' class to binary type constructors.+class Read2 f where+ -- | 'readsPrec' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument types.+ liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->+ (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)++ -- | 'readList' function for an application of the type constructor+ -- based on 'readsPrec' and 'readList' functions for the argument types.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->+ (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]+ liftReadList2 rp1 rl1 rp2 rl2 =+ readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Read2+#endif++-- | Lift the standard 'readsPrec' function through the type constructor.+readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)+readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList++-- | Lifting of the 'Show' class to binary type constructors.+class Show2 f where+ -- | 'showsPrec' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument types.+ liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS++ -- | 'showList' function for an application of the type constructor+ -- based on 'showsPrec' and 'showList' functions for the argument types.+ -- The default implementation using standard list syntax is correct+ -- for most types.+ liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS+ liftShowList2 sp1 sl1 sp2 sl2 =+ showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Show2+#endif++-- | Lift the standard 'showsPrec' function through the type constructor.+showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS+showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList++-- Instances for Prelude type constructors++instance Eq1 Maybe where+ liftEq _ Nothing Nothing = True+ liftEq _ Nothing (Just _) = False+ liftEq _ (Just _) Nothing = False+ liftEq eq (Just x) (Just y) = eq x y++instance Ord1 Maybe where+ liftCompare _ Nothing Nothing = EQ+ liftCompare _ Nothing (Just _) = LT+ liftCompare _ (Just _) Nothing = GT+ liftCompare comp (Just x) (Just y) = comp x y++instance Read1 Maybe where+ liftReadsPrec rp _ d =+ readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])+ `mappend`+ readsData (readsUnaryWith rp "Just" Just) d++instance Show1 Maybe where+ liftShowsPrec _ _ _ Nothing = showString "Nothing"+ liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x++instance Eq1 [] where+ liftEq _ [] [] = True+ liftEq _ [] (_:_) = False+ liftEq _ (_:_) [] = False+ liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys++instance Ord1 [] where+ liftCompare _ [] [] = EQ+ liftCompare _ [] (_:_) = LT+ liftCompare _ (_:_) [] = GT+ liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys++instance Read1 [] where+ liftReadsPrec _ rl _ = rl++instance Show1 [] where+ liftShowsPrec _ sl _ = sl++instance Eq2 (,) where+ liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2++instance Ord2 (,) where+ liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =+ comp1 x1 x2 `mappend` comp2 y1 y2++instance Read2 (,) where+ liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->+ [((x,y), w) | ("(",s) <- lex r,+ (x,t) <- rp1 0 s,+ (",",u) <- lex t,+ (y,v) <- rp2 0 u,+ (")",w) <- lex v]++instance Show2 (,) where+ liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =+ showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'++instance (Eq a) => Eq1 ((,) a) where+ liftEq = liftEq2 (==)++instance (Ord a) => Ord1 ((,) a) where+ liftCompare = liftCompare2 compare++instance (Read a) => Read1 ((,) a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance (Show a) => Show1 ((,) a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Eq2 Either where+ liftEq2 e1 _ (Left x) (Left y) = e1 x y+ liftEq2 _ _ (Left _) (Right _) = False+ liftEq2 _ _ (Right _) (Left _) = False+ liftEq2 _ e2 (Right x) (Right y) = e2 x y++instance Ord2 Either where+ liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y+ liftCompare2 _ _ (Left _) (Right _) = LT+ liftCompare2 _ _ (Right _) (Left _) = GT+ liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y++instance Read2 Either where+ liftReadsPrec2 rp1 _ rp2 _ = readsData $+ readsUnaryWith rp1 "Left" Left `mappend`+ readsUnaryWith rp2 "Right" Right++instance Show2 Either where+ liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x+ liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x++instance (Eq a) => Eq1 (Either a) where+ liftEq = liftEq2 (==)++instance (Ord a) => Ord1 (Either a) where+ liftCompare = liftCompare2 compare++instance (Read a) => Read1 (Either a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++instance (Show a) => Show1 (Either a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++-- Instances for other functors defined in the base package++instance Eq1 Identity where+ liftEq eq (Identity x) (Identity y) = eq x y++instance Ord1 Identity where+ liftCompare comp (Identity x) (Identity y) = comp x y++instance Read1 Identity where+ liftReadsPrec rp _ = readsData $+ readsUnaryWith rp "Identity" Identity++instance Show1 Identity where+ liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x++instance Eq2 Const where+ liftEq2 eq _ (Const x) (Const y) = eq x y++instance Ord2 Const where+ liftCompare2 comp _ (Const x) (Const y) = comp x y++instance Read2 Const where+ liftReadsPrec2 rp _ _ _ = readsData $+ readsUnaryWith rp "Const" Const++instance Show2 Const where+ liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x++instance (Eq a) => Eq1 (Const a) where+ liftEq = liftEq2 (==)+instance (Ord a) => Ord1 (Const a) where+ liftCompare = liftCompare2 compare+instance (Read a) => Read1 (Const a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList+instance (Show a) => Show1 (Const a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++-- Building blocks++-- | @'readsData' p d@ is a parser for datatypes where each alternative+-- begins with a data constructor. It parses the constructor and+-- passes it to @p@. Parsers for various constructors can be constructed+-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with+-- @mappend@ from the @Monoid@ class.+readsData :: (String -> ReadS a) -> Int -> ReadS a+readsData reader d =+ readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]++-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor+-- and then parses its argument using @rp@.+readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t+readsUnaryWith rp name cons kw s =+ [(cons x,t) | kw == name, (x,t) <- rp 11 s]++-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary+-- data constructor and then parses its arguments using @rp1@ and @rp2@+-- respectively.+readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->+ String -> (a -> b -> t) -> String -> ReadS t+readsBinaryWith rp1 rp2 name cons kw s =+ [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]++-- | @'showsUnaryWith' sp n d x@ produces the string representation of a+-- unary data constructor with name @n@ and argument @x@, in precedence+-- context @d@.+showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS+showsUnaryWith sp name d x = showParen (d > 10) $+ showString name . showChar ' ' . sp 11 x++-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string+-- representation of a binary data constructor with name @n@ and arguments+-- @x@ and @y@, in precedence context @d@.+showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->+ String -> Int -> a -> b -> ShowS+showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $+ showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y++-- Obsolete building blocks++-- | @'readsUnary' n c n'@ matches the name of a unary data constructor+-- and then parses its argument using 'readsPrec'.+{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-}+readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t+readsUnary name cons kw s =+ [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]++-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor+-- and then parses its argument using 'readsPrec1'.+{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-}+readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t+readsUnary1 name cons kw s =+ [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]++-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor+-- and then parses its arguments using 'readsPrec1'.+{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-}+readsBinary1 :: (Read1 f, Read1 g, Read a) =>+ String -> (f a -> g a -> t) -> String -> ReadS t+readsBinary1 name cons kw s =+ [(cons x y,u) | kw == name,+ (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]++-- | @'showsUnary' n d x@ produces the string representation of a unary data+-- constructor with name @n@ and argument @x@, in precedence context @d@.+{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-}+showsUnary :: (Show a) => String -> Int -> a -> ShowS+showsUnary name d x = showParen (d > 10) $+ showString name . showChar ' ' . showsPrec 11 x++-- | @'showsUnary1' n d x@ produces the string representation of a unary data+-- constructor with name @n@ and argument @x@, in precedence context @d@.+{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-}+showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS+showsUnary1 name d x = showParen (d > 10) $+ showString name . showChar ' ' . showsPrec1 11 x++-- | @'showsBinary1' n d x y@ produces the string representation of a binary+-- data constructor with name @n@ and arguments @x@ and @y@, in precedence+-- context @d@.+{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-}+showsBinary1 :: (Show1 f, Show1 g, Show a) =>+ String -> Int -> f a -> g a -> ShowS+showsBinary1 name d x y = showParen (d > 10) $+ showString name . showChar ' ' . showsPrec1 11 x .+ showChar ' ' . showsPrec1 11 y++{- $example+These functions can be used to assemble 'Read' and 'Show' instances for+new algebraic types. For example, given the definition++> data T f a = Zero a | One (f a) | Two a (f a)++a standard 'Read1' instance may be defined as++> instance (Read1 f) => Read1 (T f) where+> liftReadsPrec rp rl = readsData $+> readsUnaryWith rp "Zero" Zero `mappend`+> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`+> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two++and the corresponding 'Show1' instance as++> instance (Show1 f) => Show1 (T f) where+> liftShowsPrec sp _ d (Zero x) =+> showsUnaryWith sp "Zero" d x+> liftShowsPrec sp sl d (One x) =+> showsUnaryWith (liftShowsPrec sp sl) "One" d x+> liftShowsPrec sp sl d (Two x y) =+> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y++-}
+ legacy/pre711/Data/Functor/Compose.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Compose+-- Copyright : (c) Ross Paterson 2010+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Composition of functors.+-----------------------------------------------------------------------------++module Data.Functor.Compose (+ Compose(..),+ ) where++import Data.Functor.Classes++import Control.Applicative+#if __GLASGOW_HASKELL__ >= 708+import Data.Data+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++infixr 9 `Compose`++-- | Right-to-left composition of functors.+-- The composition of applicative functors is always applicative,+-- but the composition of monads is not always a monad.+newtype Compose f g a = Compose { getCompose :: f (g a) }++#if __GLASGOW_HASKELL__ >= 702+deriving instance Generic (Compose f g a)++instance Functor f => Generic1 (Compose f g) where+ type Rep1 (Compose f g) =+ D1 MDCompose+ (C1 MCCompose+ (S1 MSCompose (f :.: Rec1 g)))+ from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x))))+ to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x))++data MDCompose+data MCCompose+data MSCompose++instance Datatype MDCompose where+ datatypeName _ = "Compose"+ moduleName _ = "Data.Functor.Compose"+# if __GLASGOW_HASKELL__ >= 708+ isNewtype _ = True+# endif++instance Constructor MCCompose where+ conName _ = "Compose"+ conIsRecord _ = True++instance Selector MSCompose where+ selName _ = "getCompose"+#endif++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Compose+deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)+ => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))+#endif++-- Instances of lifted Prelude classes++instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where+ liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y++instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where+ liftCompare comp (Compose x) (Compose y) =+ liftCompare (liftCompare comp) x y++instance (Read1 f, Read1 g) => Read1 (Compose f g) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl++instance (Show1 f, Show1 g) => Show1 (Compose f g) where+ liftShowsPrec sp sl d (Compose x) =+ showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++-- Instances of Prelude classes++instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where+ (==) = eq1++instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where+ compare = compare1++instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where+ readsPrec = readsPrec1++instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where+ showsPrec = showsPrec1++-- Functor instances++instance (Functor f, Functor g) => Functor (Compose f g) where+ fmap f (Compose x) = Compose (fmap (fmap f) x)++instance (Foldable f, Foldable g) => Foldable (Compose f g) where+ foldMap f (Compose t) = foldMap (foldMap f) t++instance (Traversable f, Traversable g) => Traversable (Compose f g) where+ traverse f (Compose t) = Compose <$> traverse (traverse f) t++instance (Applicative f, Applicative g) => Applicative (Compose f g) where+ pure x = Compose (pure (pure x))+ Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)++instance (Alternative f, Applicative g) => Alternative (Compose f g) where+ empty = Compose empty+ Compose x <|> Compose y = Compose (x <|> y)
+ legacy/pre711/Data/Functor/Product.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Product+-- Copyright : (c) Ross Paterson 2010+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Products, lifted to functors.+-----------------------------------------------------------------------------++module Data.Functor.Product (+ Product(..),+ ) where++import Control.Applicative+import Control.Monad (MonadPlus(..))+import Control.Monad.Fix (MonadFix(..))+#if MIN_VERSION_base(4,4,0)+import Control.Monad.Zip (MonadZip(mzipWith))+#endif+#if __GLASGOW_HASKELL__ >= 708+import Data.Data+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Classes+import Data.Monoid (mappend)+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++-- | Lifted product of functors.+data Product f g a = Pair (f a) (g a)++#if __GLASGOW_HASKELL__ >= 702+deriving instance Generic (Product f g a)++instance Generic1 (Product f g) where+ type Rep1 (Product f g) =+ D1 MDProduct+ (C1 MCPair+ (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g)))+ from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))+ to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)++data MDProduct+data MCPair++instance Datatype MDProduct where+ datatypeName _ = "Product"+ moduleName _ = "Data.Functor.Product"++instance Constructor MCPair where+ conName _ = "Pair"+#endif++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Product+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+ => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))+#endif++instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where+ liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2++instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where+ liftCompare comp (Pair x1 y1) (Pair x2 y2) =+ liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2++instance (Read1 f, Read1 g) => Read1 (Product f g) where+ liftReadsPrec rp rl = readsData $+ readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair++instance (Show1 f, Show1 g) => Show1 (Product f g) where+ liftShowsPrec sp sl d (Pair x y) =+ showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y++instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)+ where (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where+ compare = compare1+instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where+ readsPrec = readsPrec1+instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where+ showsPrec = showsPrec1++instance (Functor f, Functor g) => Functor (Product f g) where+ fmap f (Pair x y) = Pair (fmap f x) (fmap f y)++instance (Foldable f, Foldable g) => Foldable (Product f g) where+ foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y++instance (Traversable f, Traversable g) => Traversable (Product f g) where+ traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y++instance (Applicative f, Applicative g) => Applicative (Product f g) where+ pure x = Pair (pure x) (pure x)+ Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)++instance (Alternative f, Alternative g) => Alternative (Product f g) where+ empty = Pair empty empty+ Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)++instance (Monad f, Monad g) => Monad (Product f g) where+#if !(MIN_VERSION_base(4,8,0))+ return x = Pair (return x) (return x)+#endif+ Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)+ where+ fstP (Pair a _) = a+ sndP (Pair _ b) = b++instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where+ mzero = Pair mzero mzero+ Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)++instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where+ mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))+ where+ fstP (Pair a _) = a+ sndP (Pair _ b) = b++#if MIN_VERSION_base(4,4,0)+instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where+ mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)+#endif
+ legacy/pre711/Data/Functor/Sum.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE PolyKinds #-}+#endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Sum+-- Copyright : (c) Ross Paterson 2014+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : R.Paterson@city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Sums, lifted to functors.+-----------------------------------------------------------------------------++module Data.Functor.Sum (+ Sum(..),+ ) where++import Control.Applicative+#if __GLASGOW_HASKELL__ >= 708+import Data.Data+#endif+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Classes+import Data.Monoid (mappend)+import Data.Traversable (Traversable(traverse))+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++-- | Lifted sum of functors.+data Sum f g a = InL (f a) | InR (g a)++#if __GLASGOW_HASKELL__ >= 702+deriving instance Generic (Sum f g a)++instance Generic1 (Sum f g) where+ type Rep1 (Sum f g) =+ D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))+ :+: C1 MCInR (S1 NoSelector (Rec1 g)))+ from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))+ from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))+ to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)+ to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g)++data MDSum+data MCInL+data MCInR++instance Datatype MDSum where+ datatypeName _ = "Sum"+ moduleName _ = "Data.Functor.Sum"++instance Constructor MCInL where+ conName _ = "InL"++instance Constructor MCInR where+ conName _ = "InR"+#endif++#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Sum+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)+ => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))+#endif++instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where+ liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2+ liftEq _ (InL _) (InR _) = False+ liftEq _ (InR _) (InL _) = False+ liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2++instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where+ liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2+ liftCompare _ (InL _) (InR _) = LT+ liftCompare _ (InR _) (InL _) = GT+ liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2++instance (Read1 f, Read1 g) => Read1 (Sum f g) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend`+ readsUnaryWith (liftReadsPrec rp rl) "InR" InR++instance (Show1 f, Show1 g) => Show1 (Sum f g) where+ liftShowsPrec sp sl d (InL x) =+ showsUnaryWith (liftShowsPrec sp sl) "InL" d x+ liftShowsPrec sp sl d (InR y) =+ showsUnaryWith (liftShowsPrec sp sl) "InR" d y++instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where+ (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where+ compare = compare1+instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where+ readsPrec = readsPrec1+instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where+ showsPrec = showsPrec1++instance (Functor f, Functor g) => Functor (Sum f g) where+ fmap f (InL x) = InL (fmap f x)+ fmap f (InR y) = InR (fmap f y)++instance (Foldable f, Foldable g) => Foldable (Sum f g) where+ foldMap f (InL x) = foldMap f x+ foldMap f (InR y) = foldMap f y++instance (Traversable f, Traversable g) => Traversable (Sum f g) where+ traverse f (InL x) = InL <$> traverse f x+ traverse f (InR y) = InR <$> traverse f y
− oldsrc/Data/Functor/Identity.hs
@@ -1,70 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Functor.Identity--- Copyright : (c) Andy Gill 2001,--- (c) Oregon Graduate Institute of Science and Technology 2001--- License : BSD-style (see the file LICENSE)------ Maintainer : ross@soi.city.ac.uk--- Stability : experimental--- Portability : portable------ The identity functor and monad.------ This trivial type constructor serves two purposes:------ * It can be used with functions parameterized by functor or monad classes.------ * It can be used as a base monad to which a series of monad--- transformers may be applied to construct a composite monad.--- Most monad transformer modules include the special case of--- applying the transformer to 'Identity'. For example, @State s@--- is an abbreviation for @StateT s 'Identity'@.--------------------------------------------------------------------------------module Data.Functor.Identity (- Identity(..),- ) where--import Control.Applicative-import Control.Monad.Fix-import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable(traverse))---- | Identity functor and monad. (a non-strict monad)-newtype Identity a = Identity { runIdentity :: a }- deriving (Eq, Ord)---- These instances would be equivalent to the derived instances of the--- newtype if the field were removed.--instance (Read a) => Read (Identity a) where- readsPrec d = readParen (d > 10) $ \ r ->- [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s]--instance (Show a) => Show (Identity a) where- showsPrec d (Identity x) = showParen (d > 10) $- showString "Identity " . showsPrec 11 x---- ------------------------------------------------------------------------------ Identity instances for Functor and Monad--instance Functor Identity where- fmap f m = Identity (f (runIdentity m))--instance Foldable Identity where- foldMap f (Identity x) = f x--instance Traversable Identity where- traverse f (Identity x) = Identity <$> f x--instance Applicative Identity where- pure a = Identity a- Identity f <*> Identity x = Identity (f x)--instance Monad Identity where- return a = Identity a- m >>= k = k (runIdentity m)--instance MonadFix Identity where- mfix f = Identity (fix (runIdentity . f))
transformers.cabal view
@@ -1,9 +1,10 @@ name: transformers-version: 0.4.3.0+version: 0.5.0.0 license: BSD3 license-file: LICENSE author: Andy Gill, Ross Paterson maintainer: Ross Paterson <R.Paterson@city.ac.uk>+bug-reports: http://hub.darcs.net/ross/transformers/issues category: Control synopsis: Concrete functor and monad transformers description:@@ -44,12 +45,25 @@ -- Data.Functor.Identity was moved into base-4.8.0.0 (GHC 7.10) -- see also https://ghc.haskell.org/trac/ghc/ticket/9664 -- NB: using impl(ghc>=7.9) instead of fragile Cabal flags- hs-source-dirs: oldsrc+ hs-source-dirs: legacy/pre709 exposed-modules: Data.Functor.Identity+ if !impl(ghc>=7.11)+ -- modules moved into base-4.9.0 (GHC 8.0)+ -- see https://ghc.haskell.org/trac/ghc/ticket/10773+ -- see https://ghc.haskell.org/trac/ghc/ticket/11135+ hs-source-dirs: legacy/pre711+ exposed-modules:+ Control.Monad.IO.Class+ Data.Functor.Classes+ Data.Functor.Compose+ Data.Functor.Product+ Data.Functor.Sum+ if impl(ghc>=7.2 && <7.5)+ -- Prior to GHC 7.5, GHC.Generics lived in ghc-prim+ build-depends: ghc-prim exposed-modules: Control.Applicative.Backwards Control.Applicative.Lift- Control.Monad.IO.Class Control.Monad.Signatures Control.Monad.Trans.Class Control.Monad.Trans.Cont@@ -68,9 +82,5 @@ Control.Monad.Trans.Writer Control.Monad.Trans.Writer.Lazy Control.Monad.Trans.Writer.Strict- Data.Functor.Classes- Data.Functor.Compose Data.Functor.Constant- Data.Functor.Product Data.Functor.Reverse- Data.Functor.Sum