diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs')
-rw-r--r-- | third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs | 188 |
1 files changed, 188 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs new file mode 100644 index 000000000000..2a0db5e5a165 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Identity +-- Copyright : (c) 2007 Magnus Therning +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity monad transformer. +-- +-- This is useful for functions parameterized by a monad transformer. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Identity ( + -- * The identity monad transformer + IdentityT(..), + mapIdentityT, + -- * Lifting other operations + liftCatch, + liftCallCC, + ) where + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Signatures +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +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 +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) + +-- | The trivial monad transformer, which maps a monad to an equivalent monad. +newtype IdentityT f a = IdentityT { runIdentityT :: f a } + +instance (Eq1 f) => Eq1 (IdentityT f) where + liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y + {-# INLINE liftEq #-} + +instance (Ord1 f) => Ord1 (IdentityT f) where + liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y + {-# INLINE liftCompare #-} + +instance (Read1 f) => Read1 (IdentityT f) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT + +instance (Show1 f) => Show1 (IdentityT f) where + liftShowsPrec sp sl d (IdentityT m) = + showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m + +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) + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (IdentityT f) where + foldMap f (IdentityT t) = foldMap f t + {-# INLINE foldMap #-} + foldr f z (IdentityT t) = foldr f z t + {-# INLINE foldr #-} + foldl f z (IdentityT t) = foldl f z t + {-# INLINE foldl #-} + foldr1 f (IdentityT t) = foldr1 f t + {-# INLINE foldr1 #-} + foldl1 f (IdentityT t) = foldl1 f t + {-# INLINE foldl1 #-} +#if MIN_VERSION_base(4,8,0) + null (IdentityT t) = null t + length (IdentityT t) = length t +#endif + +instance (Traversable f) => Traversable (IdentityT f) where + traverse f (IdentityT a) = IdentityT <$> traverse f a + {-# INLINE traverse #-} + +instance (Applicative m) => Applicative (IdentityT m) where + pure x = IdentityT (pure x) + {-# INLINE pure #-} + (<*>) = lift2IdentityT (<*>) + {-# INLINE (<*>) #-} + (*>) = lift2IdentityT (*>) + {-# INLINE (*>) #-} + (<*) = lift2IdentityT (<*) + {-# INLINE (<*) #-} + +instance (Alternative m) => Alternative (IdentityT m) where + empty = IdentityT empty + {-# INLINE empty #-} + (<|>) = lift2IdentityT (<|>) + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (IdentityT m) where +#if !(MIN_VERSION_base(4,8,0)) + return = IdentityT . return + {-# INLINE return #-} +#endif + m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = IdentityT $ fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where + fail msg = IdentityT $ Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (MonadPlus m) => MonadPlus (IdentityT m) where + mzero = IdentityT mzero + {-# INLINE mzero #-} + mplus = lift2IdentityT mplus + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (IdentityT m) where + mfix f = IdentityT (mfix (runIdentityT . f)) + {-# INLINE mfix #-} + +instance (MonadIO m) => MonadIO (IdentityT m) where + liftIO = IdentityT . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (IdentityT m) where + mzipWith f = lift2IdentityT (mzipWith f) + {-# INLINE mzipWith #-} +#endif + +instance MonadTrans IdentityT where + lift = IdentityT + {-# INLINE lift #-} + +#if MIN_VERSION_base(4,12,0) +instance Contravariant f => Contravariant (IdentityT f) where + contramap f = IdentityT . contramap f . runIdentityT + {-# INLINE contramap #-} +#endif + +-- | Lift a unary operation to the new monad. +mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b +mapIdentityT f = IdentityT . f . runIdentityT +{-# INLINE mapIdentityT #-} + +-- | Lift a binary operation to the new monad. +lift2IdentityT :: + (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c +lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b)) +{-# INLINE lift2IdentityT #-} + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m a b -> CallCC (IdentityT m) a b +liftCallCC callCC f = + IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c)) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m a -> Catch e (IdentityT m) a +liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h) +{-# INLINE liftCatch #-} |