constrained-monads-0.5.0.0: src/Control/Monad/Constrained.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | A module for constrained monads. This module is intended to be imported
-- with the @-XRebindableSyntax@ extension turned on: everything from the
-- "Prelude" (that doesn't conflict with the new 'Functor', 'Applicative', etc) is
-- reexported, so these type classes can be used the same way that the "Prelude"
-- classes are used.
module Control.Monad.Constrained
(
-- * Basic Classes
Functor(..)
,Applicative(..)
,Monad(..)
,Alternative(..)
,Traversable(..)
,MonadFail(..)
,
-- * Unconstrained applicative stuff
ap
,
-- * Useful functions
guard
,ensure
,(<**>)
,(<$>)
,(=<<)
,(<=<)
,(>=>)
,foldM
,traverse_
,sequenceA
,sequenceA_
,mapAccumL
,replicateM
,void
,forever
,for_
,join
,
-- * Syntax
ifThenElse
,(>>)
,return
,module RestPrelude)
where
import GHC.Exts
import Prelude as RestPrelude hiding (Applicative (..),
Functor (..),
Monad (..),
Traversable (..),
(<$>), (=<<))
import qualified Control.Applicative
import qualified Prelude
import Data.Functor.Identity (Identity (..))
import Data.IntMap.Strict (IntMap)
import Data.Map.Strict (Map)
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree (Tree (..))
import Control.Monad.ST (ST)
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Identity (IdentityT (..))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.Reader (ReaderT (..), mapReaderT)
import Control.Monad.Trans.State (StateT (..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT (..))
import Data.Functor.Compose (Compose (..))
import Data.Functor.Const (Const)
import Data.Functor.Product (Product (..))
import Data.Functor.Sum (Sum (..))
import Control.Arrow (first)
import Control.Monad.Trans.State.Strict (runState, state)
import Data.Tuple
import Control.Applicative.Free (Ap (Ap, Pure))
import qualified Control.Applicative.Free as Initial
import Control.Monad.Constrained.Internal.Unconstrained
-- import qualified Control.Applicative.Free.Final as Final
--------------------------------------------------------------------------------
-- Standard classes
--------------------------------------------------------------------------------
-- | This is the same class as 'Prelude.Functor' from the Prelude. Most of the
-- functions here are simply rewritten versions of those, with one difference:
-- types can indicate /which/ types they can contain. This allows
-- 'Data.Set.Set' to be made into a monad, as well as some other exotic types.
-- (but, to be fair, 'Data.Set.Set' is kind of the poster child for this
-- technique).
--
-- The way that types indicate what they can contain is with the 'Suitable'
-- associated type.
--
-- The default implementation is for types which conform to the "Prelude"'s
-- 'Prelude.Functor'. The way to make a standard 'Prelude.Functor' conform
-- is by indicating that it has no constraints. For instance, for @[]@:
--
-- @
-- instance 'Functor' [] where
-- fmap = map
-- (<$) = (Prelude.<$)
-- @
--
-- Monomorphic types can also conform, using GADT aliases. For instance,
-- if you create an alias for 'Data.IntSet.IntSet' of kind @* -> *@:
--
-- @
-- data IntSet a where
-- IntSet :: IntSet.'Data.IntSet.IntSet' -> IntSet 'Int'
-- @
--
-- It can be made to conform to 'Functor' like so:
--
-- @
-- instance 'Functor' IntSet where
-- type 'Suitable' IntSet a = a ~ 'Int'
-- 'fmap' f (IntSet xs) = IntSet (IntSet.'Data.IntSet.map' f xs)
-- x '<$' xs = if 'null' xs then 'empty' else 'pure' x
-- @
--
-- It can also be made conform to 'Foldable', etc. This type is provided in
-- "Control.Monad.Constrained.IntSet".
class Functor f where
{-# MINIMAL fmap #-}
-- | Indicate which types can be contained by 'f'. For instance,
-- 'Data.Set.Set' conforms like so:
--
-- @instance 'Functor' 'Set' where
-- type 'Suitable' 'Set' a = 'Ord' a
-- 'fmap' = Set.'Set.map'
-- x '<$' xs = if Set.'Set.null' xs then Set.'Set.empty' else Set.'Set.singleton' x@
type Suitable f a :: Constraint
type Suitable f a = ()
-- | Maps a function over a functor
fmap
:: (Suitable f b)
=> (a -> b) -> f a -> f b
-- | Replace all values in the input with a default value.
infixl 4 <$
(<$) :: (Suitable f a) => a -> f b -> f a
(<$) = fmap . const
{-# INLINE (<$) #-}
-- | A functor with application.
--
-- This class is slightly different (although equivalent) to the class
-- provided in the Prelude. This is to facilitate the lifting of functions
-- to arbitrary numbers of arguments.
--
-- A minimal complete definition must include implementations of 'reflect' and
-- 'reify' which convert to and from a law-abiding applicative, such that they
-- form an isomorphism. Alternatively, you can conform to the standard prelude
-- classes, and satisfy the following laws:
--
-- [/identity/]
--
-- @'pure' 'id' '<*>' v = v@
--
-- [/composition/]
--
-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
--
-- [/homomorphism/]
--
-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
--
-- [/interchange/]
--
-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
--
-- The other methods have the following default definitions, which may
-- be overridden with equivalent specialized implementations:
--
-- * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
--
-- * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
--
-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
--
-- * @'fmap' f x = 'pure' f '<*>' x@
--
-- If @f@ is also a 'Monad', it should satisfy
--
-- * @'pure' = 'return'@
--
-- * @('<*>') = 'ap'@
--
-- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
class (Prelude.Applicative (Unconstrained f), Functor f) =>
Applicative f where
type Unconstrained f :: * -> *
type Unconstrained f = f
{-# MINIMAL reflect , reify #-}
reflect :: f a -> Unconstrained f a
reify
:: Suitable f a
=> Unconstrained f a -> f a
-- | Lift a value.
pure
:: Suitable f a
=> a -> f a
pure = reify . Prelude.pure
{-# INLINE pure #-}
infixl 4 <*>
-- | Sequential application.
(<*>)
:: Suitable f b
=> f (a -> b) -> f a -> f b
(<*>) fs xs = reify (reflect fs Prelude.<*> reflect xs)
{-# INLINE (<*>) #-}
infixl 4 *>
-- | Sequence actions, discarding the value of the first argument.
(*>)
:: Suitable f b
=> f a -> f b -> f b
(*>) = liftA2 (const id)
{-# INLINE (*>) #-}
infixl 4 <*
-- | Sequence actions, discarding the value of the second argument.
(<*)
:: Suitable f a
=> f a -> f b -> f a
(<*) = liftA2 const
{-# INLINE (<*) #-}
liftA2
:: (Suitable f c)
=> (a -> b -> c) -> f a -> f b -> f c
liftA2 f xs ys = reify (Control.Applicative.liftA2 f (reflect xs) (reflect ys))
{-# INLINE liftA2 #-}
liftA3
:: (Suitable f d)
=> (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 f xs ys zs =
reify (Control.Applicative.liftA3 f (reflect xs) (reflect ys) (reflect zs))
{-# INLINE liftA3 #-}
infixl 4 <**>
-- | A variant of '<*>' with the arguments reversed.
(<**>) :: (Applicative f, Suitable f b) => f a -> f (a -> b) -> f b
(<**>) = liftA2 (flip ($))
{-# INLINE (<**>) #-}
-- | A definition of 'reify' that uses monadic operations. This is actually
-- the instance of applicative for codensity in disguise.
ap
:: (Monad f, Suitable f a)
=> (a -> f a) -> Initial.Ap f a -> f a
ap = flip runAp
where
runAp :: (Suitable f b, Monad f) => Ap f a -> (a -> f b) -> f b
runAp (Pure x) = \c -> c x
runAp (Ap xs fs) = \c -> xs >>= \x -> runAp fs (\g -> (c . g) x)
{-# INLINE ap #-}
{- | The 'Monad' class defines the basic operations over a /monad/,
a concept from a branch of mathematics known as /category theory/.
From the perspective of a Haskell programmer, however, it is best to
think of a monad as an /abstract datatype/ of actions.
Haskell's @do@ expressions provide a convenient syntax for writing
monadic expressions.
Instances of 'Monad' should satisfy the following laws:
* @'return' a '>>=' k = k a@
* @m '>>=' 'return' = m@
* @m '>>=' (\\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@
Furthermore, the 'Monad' and 'Applicative' operations should relate as follows:
* @'pure' = 'return'@
* @('<*>') = 'ap'@
The above laws imply:
* @'fmap' f xs = xs '>>=' 'return' . f@
* @('>>') = ('*>')@
and that 'pure' and ('<*>') satisfy the applicative functor laws.
The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
defined in the ""Prelude"" satisfy these laws.
-}
class Applicative f =>
Monad f where
infixl 1 >>=
-- | Sequentially compose two actions, passing any value produced
-- by the first as an argument to the second.
(>>=)
:: Suitable f b
=> f a -> (a -> f b) -> f b
-- | See
-- <https://hackage.haskell.org/package/base-4.9.1.0/docs/Control-Monad-Fail.html here>
-- for more details.
class Monad f => MonadFail f where
-- | Called when a pattern match fails in do-notation.
fail :: Suitable f a => String -> f a
-- | A monoid on applicative functors.
--
-- If defined, 'some' and 'many' should be the least solutions
-- of the equations:
--
-- * @some v = (:) '<$>' v '<*>' many v@
--
-- * @many v = some v '<|>' 'pure' []@
class Applicative f =>
Alternative f where
{-# MINIMAL empty, (<|>) #-}
-- | The identity of '<|>'
empty :: Suitable f a => f a
infixl 3 <|>
-- | An associative binary operation
(<|>)
:: Suitable f a
=> f a -> f a -> f a
-- | One or more.
some :: Suitable f [a] => f a -> f [a]
some v = some_v
where
many_v = some_v <|> pure []
some_v = liftA2 (:) v many_v
-- | Zero or more.
many :: Suitable f [a] => f a -> f [a]
many v = many_v
where
many_v = some_v <|> pure []
some_v = liftA2 (:) v many_v
-- | Functors representing data structures that can be traversed from
-- left to right.
--
-- A definition of 'traverse' must satisfy the following laws:
--
-- [/naturality/]
-- @t . 'traverse' f = 'traverse' (t . f)@
-- for every applicative transformation @t@
--
-- [/identity/]
-- @'traverse' Identity = Identity@
--
-- [/composition/]
-- @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@
--
-- A definition of 'sequenceA' must satisfy the following laws:
--
-- [/naturality/]
-- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@
-- for every applicative transformation @t@
--
-- [/identity/]
-- @'sequenceA' . 'fmap' Identity = Identity@
--
-- [/composition/]
-- @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@
--
-- where an /applicative transformation/ is a function
--
-- @t :: (Applicative f, Applicative g) => f a -> g a@
--
-- preserving the 'Applicative' operations, i.e.
--
-- * @t ('pure' x) = 'pure' x@
--
-- * @t (x '<*>' y) = t x '<*>' t y@
--
-- and the identity functor @Identity@ and composition of functors @Compose@
-- are defined as
--
-- > newtype Identity a = Identity a
-- >
-- > instance Functor Identity where
-- > fmap f (Identity x) = Identity (f x)
-- >
-- > instance Applicative Identity where
-- > pure x = Identity x
-- > Identity f <*> Identity x = Identity (f x)
-- >
-- > newtype Compose f g a = Compose (f (g a))
-- >
-- > instance (Functor f, Functor g) => Functor (Compose f g) where
-- > fmap f (Compose x) = Compose (fmap (fmap f) x)
-- >
-- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where
-- > pure x = Compose (pure (pure x))
-- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)
--
-- (The naturality law is implied by parametricity.)
--
-- Instances are similar to 'Functor', e.g. given a data type
--
-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
--
-- a suitable instance would be
--
-- > instance Traversable Tree where
-- > traverse f Empty = pure Empty
-- > traverse f (Leaf x) = Leaf <$> f x
-- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r
--
-- This is suitable even for abstract types, as the laws for '<*>'
-- imply a form of associativity.
--
-- The superclass instances should satisfy the following:
--
-- * In the 'Functor' instance, 'fmap' should be equivalent to traversal
-- with the identity applicative functor ('fmapDefault').
--
-- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be
-- equivalent to traversal with a constant applicative functor
-- ('foldMapDefault').
--
class (Foldable t, Functor t) =>
Traversable t where
-- | Map each element of a structure to an action, evaluate these actions
-- from left to right, and collect the results. For a version that ignores
-- the results see 'traverse_'.
traverse
:: (Suitable t b, Applicative f, Suitable f (t b), Suitable f b)
=> (a -> f b) -> t a -> f (t b)
--------------------------------------------------------------------------------
-- useful functions
--------------------------------------------------------------------------------
infixl 4 <$>
-- | An infix synonym for 'fmap'.
--
-- The name of this operator is an allusion to '$'.
-- Note the similarities between their types:
--
-- > ($) :: (a -> b) -> a -> b
-- > (<$>) :: Functor f => (a -> b) -> f a -> f b
--
-- Whereas '$' is function application, '<$>' is function
-- application lifted over a 'Functor'.
--
-- ==== __Examples__
--
-- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show':
--
-- >>> show <$> Nothing
-- Nothing
-- >>> show <$> Just 3
-- Just "3"
--
-- Convert from an @'Either' 'Int' 'Int'@ to an @'Either' 'Int'@
-- 'String' using 'show':
--
-- >>> show <$> Left 17
-- Left 17
-- >>> show <$> Right 17
-- Right "17"
--
-- Double each element of a list:
--
-- >>> (*2) <$> [1,2,3]
-- [2,4,6]
--
-- Apply 'even' to the second element of a pair:
--
-- >>> even <$> (2,2)
-- (2,True)
--
(<$>) :: (Functor f, Suitable f b) => (a -> b) -> f a -> f b
(<$>) = fmap
{-# INLINE (<$>) #-}
infixr 1 =<<, <=<
-- | A flipped version of '>>='
(=<<) :: (Monad f, Suitable f b) => (a -> f b) -> f a -> f b
(=<<) = flip (>>=)
{-# INLINE (=<<) #-}
-- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped.
--
-- Note how this operator resembles function composition @('.')@:
--
-- > (.) :: (b -> c) -> (a -> b) -> a -> c
-- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c
(<=<) :: (Monad f, Suitable f c) => (b -> f c) -> (a -> f b) -> a -> f c
(f <=< g) x = f =<< g x
{-# INLINE (<=<) #-}
infixl 1 >=>
-- | Left-to-right Kleisli composition of monads.
(>=>) :: (Monad f, Suitable f c) => (a -> f b) -> (b -> f c) -> a -> f c
{-# INLINE (>=>) #-}
(f >=> g) x = f x >>= g
-- | @'forever' act@ repeats the action infinitely.
forever :: (Applicative f, Suitable f b) => f a -> f b
{-# INLINE forever #-}
forever a = let a' = a *> a' in a'
-- | Monadic fold over the elements of a structure,
-- associating to the left, i.e. from left to right.
foldM
:: (Foldable t, Monad m, Suitable m b)
=> (b -> a -> m b) -> b -> t a -> m b
foldM f z0 xs = foldr f' pure xs z0
where f' x k z = f z x >>= k
-- | 'for_' is 'traverse_' with its arguments flipped. For a version
-- that doesn't ignore the results see 'Data.Traversable.for'.
--
-- >>> for_ [1..4] print
-- 1
-- 2
-- 3
-- 4
for_
:: (Foldable t, Applicative f, Suitable f ())
=> t a -> (a -> f b) -> f ()
{-# INLINE for_ #-}
for_ = flip traverse_
-- | Map each element of a structure to an action, evaluate these
-- actions from left to right, and ignore the results. For a version
-- that doesn't ignore the results see 'traverse'.
traverse_
:: (Applicative f, Foldable t, Suitable f ())
=> (a -> f b) -> t a -> f ()
traverse_ f =
foldr (\e a -> f e *> a) (pure ())
{-# INLINE traverse_ #-}
-- | Evaluate each action in the structure from left to right, and
-- ignore the results. For a version that doesn't ignore the results
-- see 'Data.Traversable.sequenceA'.
sequenceA_ :: (Foldable t, Applicative f, Suitable f ()) => t (f a) -> f ()
sequenceA_ = foldr (*>) (pure ())
{-# INLINE sequenceA_ #-}
-- | @'guard' b@ is @'pure' ()@ if @b@ is 'True',
-- and 'empty' if @b@ is 'False'.
guard :: (Alternative f, Suitable f ()) => Bool -> f ()
guard True = pure ()
guard False = empty
{-# INLINE guard #-}
-- | @'ensure' b x@ is @x@ if @b@ is 'True',
-- and 'empty' if @b@ is 'False'.
ensure :: (Alternative f, Suitable f a) => Bool -> f a -> f a
ensure True x = x
ensure False _ = empty
{-# INLINE ensure #-}
-- | Evaluate each action in the structure from left to right, and
-- and collect the results. For a version that ignores the results
-- see 'sequenceA_'.
sequenceA
:: (Applicative f
,Suitable t a
,Suitable f (t a)
,Traversable t
,Suitable f a)
=> t (f a) -> f (t a)
sequenceA = traverse id
{-# INLINE sequenceA #-}
-- |The 'mapAccumL' function behaves like a combination of 'fmap'
-- and 'foldl'; it applies a function to each element of a structure,
-- passing an accumulating parameter from left to right, and returning
-- a final value of this accumulator together with the new structure.
mapAccumL
:: (Traversable t, Suitable t c)
=> (a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL f s t = swap $ runState (traverse (state . (swap .: flip f)) t) s
where
(.:) = (.) . (.)
{-# INLINE mapAccumL #-}
-- | @'replicateM' n act@ performs the action @n@ times,
-- gathering the results.
replicateM :: (Applicative m, Suitable m [a]) => Int -> m a -> m [a]
{-# INLINEABLE replicateM #-}
{-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-}
{-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-}
replicateM cnt0 f =
loop cnt0
where
loop cnt
| cnt <= 0 = pure []
| otherwise = liftA2 (:) f (loop (cnt - 1))
-- | @'void' value@ discards or ignores the result of evaluation, such
-- as the return value of an 'System.IO.IO' action.
--
-- ==== __Examples__
--
-- Replace the contents of a @'Maybe' 'Int'@ with unit:
--
-- >>> void Nothing
-- Nothing
-- >>> void (Just 3)
-- Just ()
--
-- Replace the contents of an @'Either' 'Int' 'Int'@ with unit,
-- resulting in an @'Either' 'Int' '()'@:
--
-- >>> void (Left 8675309)
-- Left 8675309
-- >>> void (Right 8675309)
-- Right ()
--
-- Replace every element of a list with unit:
--
-- >>> void [1,2,3]
-- [(),(),()]
--
-- Replace the second element of a pair with unit:
--
-- >>> void (1,2)
-- (1,())
--
-- Discard the result of an 'System.IO.IO' action:
--
-- >>> traverse print [1,2]
-- 1
-- 2
-- [(),()]
-- >>> void $ traverse print [1,2]
-- 1
-- 2
void :: (Functor f, Suitable f ()) => f a -> f ()
void = (<$) ()
{-# INLINE void #-}
-- | Collapse one monadic layer.
join :: (Monad f, Suitable f a) => f (f a) -> f a
join x = x >>= id
{-# INLINE join #-}
--------------------------------------------------------------------------------
-- syntax
--------------------------------------------------------------------------------
-- | Function to which the @if ... then ... else@ syntax desugars to
ifThenElse :: Bool -> a -> a -> a
ifThenElse True t _ = t
ifThenElse False _ f = f
{-# INLINE ifThenElse #-}
infixl 1 >>
-- | Sequence two actions, discarding the result of the first. Alias for
-- @('*>')@.
(>>)
:: (Applicative f, Suitable f b)
=> f a -> f b -> f b
(>>) = (*>)
{-# INLINE (>>) #-}
-- | Alias for 'pure'.
return
:: (Applicative f, Suitable f a)
=> a -> f a
return = pure
{-# INLINE return #-}
--------------------------------------------------------------------------------
-- instances
--------------------------------------------------------------------------------
instance Functor [] where
type Suitable [] a = ()
fmap = map
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative [] where
type Unconstrained [] = []
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Alternative [] where
empty = []
(<|>) = (++)
{-# INLINE empty #-}
{-# INLINE (<|>) #-}
instance Monad [] where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance MonadFail [] where
fail _ = []
{-# INLINE fail #-}
instance Traversable [] where
traverse f = foldr (liftA2 (:) . f) (pure [])
{-# INLINE traverse #-}
instance Functor Maybe where
type Suitable Maybe a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative Maybe where
reify = id
{-# INLINE reify #-}
reflect = id
{-# INLINE reflect #-}
(<*>) = (Prelude.<*>)
{-# INLINE (<*>) #-}
(*>) = (Prelude.*>)
{-# INLINE (*>) #-}
(<*) = (Prelude.<*)
{-# INLINE (<*) #-}
pure = Prelude.pure
{-# INLINE pure #-}
liftA2 = Control.Applicative.liftA2
{-# INLINE liftA2 #-}
liftA3 = Control.Applicative.liftA3
{-# INLINE liftA3 #-}
instance Alternative Maybe where
empty = Control.Applicative.empty
(<|>) = (Control.Applicative.<|>)
{-# INLINE empty #-}
{-# INLINE (<|>) #-}
instance Monad Maybe where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance MonadFail Maybe where
fail _ = Nothing
{-# INLINE fail #-}
instance Traversable Maybe where
traverse _ Nothing = pure Nothing
traverse f (Just x) = fmap Just (f x)
{-# INLINE traverse #-}
instance Functor IO where
type Suitable IO a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative IO where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Alternative IO where
empty = Control.Applicative.empty
(<|>) = (Control.Applicative.<|>)
{-# INLINE empty #-}
{-# INLINE (<|>) #-}
instance Monad IO where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance MonadFail IO where
fail = Prelude.fail
{-# INLINE fail #-}
instance Functor Identity where
type Suitable Identity a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative Identity where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monad Identity where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance Traversable Identity where
traverse f (Identity x) = fmap Identity (f x)
instance Functor (Either e) where
type Suitable (Either e) a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative (Either a) where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monad (Either a) where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance IsString a =>
MonadFail (Either a) where
fail = Left . fromString
{-# INLINE fail #-}
instance Traversable (Either a) where
traverse f = either (pure . Left) (fmap Right . f)
{-# INLINE traverse #-}
instance Functor Set where
type Suitable Set a = Ord a
fmap = Set.map
{-# INLINE fmap #-}
x <$ xs = if null xs then Set.empty else Set.singleton x
{-# INLINE (<$) #-}
instance Applicative Set where
type Unconstrained Set = StrictLeftFold
pure = Set.singleton
{-# INLINE pure #-}
xs *> ys = if null xs then Set.empty else ys
{-# INLINE (*>) #-}
xs <* ys = if null ys then Set.empty else xs
{-# INLINE (<*) #-}
reify (StrictLeftFold xs) = xs (flip Set.insert) Set.empty
{-# INLINE reify #-}
reflect xs = StrictLeftFold (\f b -> Set.foldl' f b xs)
{-# INLINE reflect #-}
instance Monad Set where
(>>=) = flip foldMap
{-# INLINE (>>=) #-}
instance MonadFail Set where
fail _ = Set.empty
{-# INLINE fail #-}
instance Alternative Set where
empty = Set.empty
(<|>) = Set.union
{-# INLINE empty #-}
{-# INLINE (<|>) #-}
instance Functor (Map a) where
type Suitable (Map a) b = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Functor ((,) a) where
type Suitable ((,) a) b = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Monoid a => Applicative ((,) a) where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monoid a => Monad ((,) a) where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance Traversable ((,) a) where
traverse f (x,y) = fmap ((,) x) (f y)
{-# INLINE traverse #-}
instance Functor IntMap where
type Suitable IntMap a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Functor Seq where
type Suitable Seq a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative Seq where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Alternative Seq where
empty = Control.Applicative.empty
(<|>) = (Control.Applicative.<|>)
{-# INLINE empty #-}
{-# INLINE (<|>) #-}
instance Monad Seq where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance MonadFail Seq where
fail _ = empty
{-# INLINE fail #-}
instance Functor Tree where
type Suitable Tree a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative Tree where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monad Tree where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance Traversable Tree where
traverse f (Node x ts) =
let g = (reflect . f)
in reify
(Node Prelude.<$> g x Prelude.<*>
Prelude.traverse (Prelude.traverse g) ts)
{-# INLINE traverse #-}
instance Functor ((->) a) where
type Suitable ((->) a) b = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative ((->) a) where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monad ((->) a) where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance Functor (ContT r m) where
type Suitable (ContT r m) a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative (ContT r m) where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monad (ContT r m) where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance Functor Control.Applicative.ZipList where
type Suitable Control.Applicative.ZipList a = ()
fmap = Prelude.fmap
(<$) = (Prelude.<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative Control.Applicative.ZipList where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Functor m =>
Functor (Strict.StateT s m) where
type Suitable (Strict.StateT s m) a = Suitable m (a, s)
fmap f m =
Strict.StateT $
\s ->
(\(!a,!s') ->
(f a, s')) <$>
Strict.runStateT m s
{-# INLINE fmap #-}
x <$ xs = Strict.StateT ((fmap . first) (const x) . Strict.runStateT xs)
{-# INLINE (<$) #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Applicative (Strict.StateT s m) where
type Unconstrained (Strict.StateT s m)
= Strict.StateT s (Unconstrained m)
reflect (Strict.StateT xs) = Strict.StateT (reflect . xs)
{-# INLINE reflect #-}
pure a =
Strict.StateT $
\ !s ->
pure (a, s)
{-# INLINE pure #-}
Strict.StateT mf <*> Strict.StateT mx =
Strict.StateT $
\ !s -> do
(f,!s') <- mf s
(x,!s'') <- mx s'
pure (f x, s'')
{-# INLINE (<*>) #-}
Strict.StateT xs *> Strict.StateT ys =
Strict.StateT $
\ !s -> do
(_,!s') <- xs s
ys s'
{-# INLINE (*>) #-}
Strict.StateT xs <* Strict.StateT ys =
Strict.StateT $
\ !s -> do
(x,!s') <- xs s
(_,!s'') <- ys s'
pure (x, s'')
{-# INLINE (<*) #-}
reify (Strict.StateT xs) = Strict.StateT (reify . xs)
{-# INLINE reify #-}
instance (Monad m, Alternative m, Prelude.Monad (Unconstrained m)) =>
Alternative (Strict.StateT s m) where
empty = Strict.StateT (const empty)
{-# INLINE empty #-}
Strict.StateT m <|> Strict.StateT n =
Strict.StateT $
\ !s ->
m s <|> n s
{-# INLINE (<|>) #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Monad (Strict.StateT s m) where
m >>= k =
Strict.StateT $
\ !s -> do
(a, !s') <- Strict.runStateT m s
Strict.runStateT (k a) s'
{-# INLINE (>>=) #-}
instance Functor m => Functor (StateT s m) where
type Suitable (StateT s m) a = Suitable m (a, s)
fmap f m = StateT $ \ s ->
(\ ~(a, s') -> (f a, s')) <$> runStateT m s
{-# INLINE fmap #-}
x <$ StateT xs = StateT ((fmap.first) (const x) . xs)
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Applicative (StateT s m) where
type Unconstrained (StateT s m) = StateT s (Unconstrained m)
reflect (StateT xs) = StateT (reflect . xs)
{-# INLINE reflect #-}
pure a =
StateT $
\s ->
pure (a, s)
{-# INLINE pure #-}
StateT mf <*> StateT mx =
StateT $
\s -> do
~(f,s') <- mf s
~(x,s'') <- mx s'
pure (f x, s'')
StateT xs *> StateT ys =
StateT $
\s -> do
~(_,s') <- xs s
ys s'
StateT xs <* StateT ys =
StateT $
\s -> do
~(x,s') <- xs s
~(_,s'') <- ys s'
pure (x,s'')
reify (StateT xs) = StateT (reify . xs)
instance (Monad m, Alternative m, Prelude.Monad (Unconstrained m)) =>
Alternative (StateT s m) where
empty = StateT (const empty)
{-# INLINE empty #-}
StateT m <|> StateT n =
StateT $
\s ->
m s <|> n s
{-# INLINE (<|>) #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) => Monad (StateT s m) where
m >>= k = StateT $ \ s -> do
~(a, s') <- runStateT m s
runStateT (k a) s'
{-# INLINE (>>=) #-}
instance (Functor m) => Functor (ReaderT r m) where
type Suitable (ReaderT r m) a = Suitable m a
fmap f = mapReaderT (fmap f)
{-# INLINE fmap #-}
x <$ ReaderT xs = ReaderT (\r -> x <$ xs r)
{-# INLINE (<$) #-}
instance (Applicative m) => Applicative (ReaderT r m) where
type Unconstrained (ReaderT r m)
= ReaderT r (Unconstrained m)
pure = liftReaderT . pure
reflect (ReaderT f) = ReaderT (reflect . f)
{-# INLINE reflect #-}
{-# INLINE pure #-}
f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r
{-# INLINE (<*>) #-}
reify ys = ReaderT (reify . runReaderT ys)
{-# INLINE reify #-}
ReaderT xs *> ReaderT ys = ReaderT (\c -> xs c *> ys c)
ReaderT xs <* ReaderT ys = ReaderT (\c -> xs c <* ys c)
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
instance (Alternative m) => Alternative (ReaderT r m) where
empty = liftReaderT empty
{-# INLINE empty #-}
m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r
{-# INLINE (<|>) #-}
instance MonadFail m =>
MonadFail (ReaderT r m) where
fail = ReaderT . const . fail
{-# INLINE fail #-}
instance (Monad m) => Monad (ReaderT r m) where
m >>= k = ReaderT $ \ r -> do
a <- runReaderT m r
runReaderT (k a) r
{-# INLINE (>>=) #-}
liftReaderT :: m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)
{-# INLINE liftReaderT #-}
instance Functor m =>
Functor (MaybeT m) where
type Suitable (MaybeT m) a = (Suitable m (Maybe a), Suitable m a)
fmap f (MaybeT xs) = MaybeT ((fmap . fmap) f xs)
{-# INLINE fmap #-}
x <$ MaybeT xs = MaybeT (fmap (x <$) xs)
{-# INLINE (<$) #-}
instance (Prelude.Monad (Unconstrained m), Monad m) =>
Applicative (MaybeT m) where
type Unconstrained (MaybeT m) = MaybeT (Unconstrained m)
reflect (MaybeT x) = MaybeT (reflect x)
{-# INLINE reflect #-}
pure x = MaybeT (pure (Just x))
{-# INLINE pure #-}
MaybeT fs <*> MaybeT xs = MaybeT (liftA2 (<*>) fs xs)
reify (MaybeT x) = MaybeT (reify x)
{-# INLINE reify #-}
MaybeT xs *> MaybeT ys = MaybeT (liftA2 (*>) xs ys)
MaybeT xs <* MaybeT ys = MaybeT (liftA2 (<*) xs ys)
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Monad (MaybeT m) where
MaybeT x >>= f = MaybeT (x >>= maybe (pure Nothing) (runMaybeT . f))
{-# INLINE (>>=) #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
MonadFail (MaybeT m) where
fail _ = empty
{-# INLINE fail #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Alternative (MaybeT m) where
empty = MaybeT (pure Nothing)
{-# INLINE empty #-}
MaybeT x <|> MaybeT y = MaybeT (x >>= maybe y (pure . Just))
{-# INLINE (<|>) #-}
instance Functor m =>
Functor (ExceptT e m) where
type Suitable (ExceptT e m) a = Suitable m (Either e a)
fmap f (ExceptT xs) = ExceptT ((fmap . fmap) f xs)
{-# INLINE fmap #-}
x <$ ExceptT xs = ExceptT (fmap (x <$) xs)
{-# INLINE (<$) #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Applicative (ExceptT e m) where
type Unconstrained (ExceptT e m) = ExceptT e (Unconstrained m)
reflect (ExceptT x) = ExceptT (reflect x)
{-# INLINE reflect #-}
pure x = ExceptT (pure (Right x))
{-# INLINE pure #-}
ExceptT fs <*> ExceptT xs = ExceptT (liftA2 (<*>) fs xs)
reify (ExceptT xs) = ExceptT (reify xs)
{-# INLINE reify #-}
ExceptT xs *> ExceptT ys = ExceptT (xs *> ys)
ExceptT xs <* ExceptT ys = ExceptT (xs <* ys)
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
instance (Monad m, IsString e, Prelude.Monad (Unconstrained m)) =>
MonadFail (ExceptT e m) where
fail = ExceptT . pure . Left . fromString
{-# INLINE fail #-}
instance (Monad m, Prelude.Monad (Unconstrained m)) =>
Monad (ExceptT e m) where
ExceptT xs >>= f = ExceptT (xs >>= either (pure . Left) (runExceptT . f))
{-# INLINE (>>=) #-}
instance (Monad m, Monoid e, Prelude.Monad (Unconstrained m)) =>
Alternative (ExceptT e m) where
empty = ExceptT (pure (Left mempty))
{-# INLINE empty #-}
ExceptT xs <|> ExceptT ys =
ExceptT (xs >>= either (const ys) (pure . Right))
{-# INLINE (<|>) #-}
instance Functor m =>
Functor (IdentityT m) where
type Suitable (IdentityT m) a = Suitable m a
fmap =
(coerce :: ((a -> b) -> f a -> f b) -> (a -> b) -> IdentityT f a -> IdentityT f b)
fmap
(<$) =
(coerce :: (a -> f b -> f a) -> a -> IdentityT f b -> IdentityT f a)
(<$)
{-# INLINE fmap #-}
{-# INLINE (<$) #-}
instance Applicative m =>
Applicative (IdentityT m) where
type Unconstrained (IdentityT m) = IdentityT (Unconstrained m)
reflect (IdentityT x) = IdentityT (reflect x)
{-# INLINE reflect #-}
pure = (coerce :: (a -> f a) -> a -> IdentityT f a) pure
{-# INLINE pure #-}
(<*>) =
(coerce :: (f (a -> b) -> f a -> f b) -> IdentityT f (a -> b) -> IdentityT f a -> IdentityT f b)
(<*>)
reify =
(coerce :: (Unconstrained f b -> f b) -> (IdentityT (Unconstrained f) b -> IdentityT f b))
reify
{-# INLINE reify #-}
IdentityT xs *> IdentityT ys = IdentityT (xs *> ys)
IdentityT xs <* IdentityT ys = IdentityT (xs <* ys)
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
instance Monad m =>
Monad (IdentityT m) where
(>>=) =
(coerce :: (f a -> (a -> f b) -> f b) -> IdentityT f a -> (a -> IdentityT f b) -> IdentityT f b)
(>>=)
{-# INLINE (>>=) #-}
instance MonadFail m =>
MonadFail (IdentityT m) where
fail = IdentityT . fail
{-# INLINE fail #-}
instance Functor (ST s) where
type Suitable (ST s) a = ()
fmap = Prelude.fmap
{-# INLINE fmap #-}
(<$) = (Prelude.<$)
{-# INLINE (<$) #-}
instance Applicative (ST s) where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance Monad (ST s) where
(>>=) = (Prelude.>>=)
{-# INLINE (>>=) #-}
instance Functor (Const a) where
type Suitable (Const a) b = ()
fmap = Prelude.fmap
{-# INLINE fmap #-}
(<$) = (Prelude.<$)
{-# INLINE (<$) #-}
instance Monoid a => Applicative (Const a) where
reify = id
reflect = id
(<*>) = (Prelude.<*>)
(*>) = (Prelude.*>)
(<*) = (Prelude.<*)
pure = Prelude.pure
liftA2 = Control.Applicative.liftA2
liftA3 = Control.Applicative.liftA3
{-# INLINE reify #-}
{-# INLINE reflect #-}
{-# INLINE (<*>) #-}
{-# INLINE (*>) #-}
{-# INLINE (<*) #-}
{-# INLINE pure #-}
{-# INLINE liftA2 #-}
{-# INLINE liftA3 #-}
instance (Functor f, Functor g) =>
Functor (Compose f g) where
type Suitable (Compose f g) a = (Suitable g a, Suitable f (g a))
fmap f (Compose xs) = Compose ((fmap . fmap) f xs)
{-# INLINE fmap #-}
instance (Applicative f, Applicative g) =>
Applicative (Compose f g) where
type Unconstrained (Compose f g) =
Compose (Unconstrained f) (Unconstrained g)
reify (Compose xs) = Compose (reify (Prelude.fmap reify xs))
{-# INLINE reify #-}
reflect (Compose xs) = Compose (Prelude.fmap reflect (reflect xs))
{-# INLINE reflect #-}
instance (Alternative f, Applicative g) => Alternative (Compose f g) where
empty = Compose empty
{-# INLINE empty #-}
Compose x <|> Compose y = Compose (x <|> y)
{-# INLINE (<|>) #-}
instance (Functor f, Functor g) => Functor (Product f g) where
type Suitable (Product f g) a = (Suitable f a, Suitable g a)
fmap f (Pair x y) = Pair (fmap f x) (fmap f y)
{-# INLINE fmap #-}
instance (Applicative f, Applicative g) =>
Applicative (Product f g) where
type Unconstrained (Product f g) =
Product (Unconstrained f) (Unconstrained g)
pure x = Pair (pure x) (pure x)
{-# INLINE pure #-}
Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)
{-# INLINE (<*>) #-}
reify (Pair xs ys) = Pair (reify xs) (reify ys)
{-# INLINE reify #-}
reflect (Pair xs ys) = Pair (reflect xs) (reflect ys)
{-# INLINE reflect #-}
instance (Alternative f, Alternative g) => Alternative (Product f g) where
empty = Pair empty empty
{-# INLINE empty #-}
Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)
{-# INLINE (<|>) #-}
instance (Monad f, Monad g) => Monad (Product f g) where
Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)
where
fstP (Pair a _) = a
sndP (Pair _ b) = b
{-# INLINE (>>=) #-}
instance (Functor f, Functor g) => Functor (Sum f g) where
type Suitable (Sum f g) a = (Suitable f a, Suitable g a)
fmap f (InL x) = InL (fmap f x)
fmap f (InR y) = InR (fmap f y)
{-# INLINE fmap #-}