-- |
-- Module      : Control.Monad.Freer.Church
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- The church-encoded "Freer" Monad.  Basically provides the free monad in
-- a way that is compatible with 'Data.Functor.HFunctor.HFunctor' and
-- 'Data.Functor.HFunctor.Interpret'.  We also have the "semigroup" version
-- 'Free1', which is the free  'Bind'.
--
-- The module also provides a version of 'GHC.Generics.:.:' (or
-- 'Data.Functor.Compose'), 'Comp', in a way that is compatible with
-- 'Data.Functor.Tensor.HBifunctor' and the related typeclasses.
module Control.Monad.Freer.Church (
  -- * 'Free'
    Free(..), reFree
  -- ** Interpretation
  , liftFree, interpretFree, retractFree, hoistFree
  -- ** Folding
  , foldFree, foldFree', foldFreeC
  -- * 'Free1'
  , Free1(.., DoneF1, MoreF1)
  , reFree1, toFree
  -- ** Interpretation
  , liftFree1, interpretFree1, retractFree1, hoistFree1
  -- ** Conversion
  , free1Comp, matchFree1
  -- ** Folding
  , foldFree1, foldFree1', foldFree1C
  -- * 'Comp'
  , Comp(.., Comp, unComp), comp
  ) where

import           Control.Applicative
import           Data.Functor.Plus
import           Control.Monad
import           Control.Natural
import           Data.Foldable
import           Data.Functor
import           Data.Functor.Bind
import           Data.Functor.Classes
import           Data.Functor.Coyoneda
import           Data.Pointed
import           Data.Semigroup.Foldable
import           Data.Semigroup.Traversable
import           GHC.Generics
import           Text.Read
import qualified Control.Monad.Free         as M

-- | A @'Free' f@ is @f@ enhanced with "sequential binding" capabilities.
-- It allows you to sequence multiple @f@s one after the other, and also to
-- determine "what @f@ to sequence" based on the result of the computation
-- so far.
--
-- Essentially, you can think of this as "giving @f@ a 'Monad' instance",
-- with all that that entails ('return', '>>=', etc.).
--
-- Lift @f@ into it with @'Data.Functor.HFunctor.inject' :: f a -> Free
-- f a@.  When you finally want to "use" it, you can interpret it into any
-- monadic context:
--
-- @
-- 'Data.Functor.HFunctor.interpret'
--     :: 'Monad' g
--     => (forall x. f x -> g x)
--     -> 'Free' f a
--     -> g a
-- @
--
-- Structurally, this is equivalent to many "nested" f's.  A value of type
-- @'Free' f a@ is either:
--
-- *   @a@
-- *   @f a@
-- *   @f (f a)@
-- *   @f (f (f a))@
-- *   .. etc.
--
-- Under the hood, this is the Church-encoded Freer monad.  It's
-- 'Control.Monad.Free.Free', or 'Control.Monad.Free.Church.F', but in
-- a way that is compatible with 'Data.Functor.HFunctor.HFunctor' and
-- 'Data.Functor.HFunctor.Interpret'.
newtype Free f a = Free
    { forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree :: forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
    }

instance Functor (Free f) where
    fmap :: forall a b. (a -> b) -> Free f a -> Free f b
fmap a -> b
f Free f a
x = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \b -> r
p forall s. f s -> (s -> r) -> r
b -> forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree Free f a
x (b -> r
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) forall s. f s -> (s -> r) -> r
b

instance Apply (Free f) where
    <.> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
(<.>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Applicative (Free f) where
    pure :: forall a. a -> Free f a
pure a
x = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \a -> r
p forall s. f s -> (s -> r) -> r
_ -> a -> r
p a
x
    <*> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
(<*>) = forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>)

instance Pointed (Free f) where
    point :: forall a. a -> Free f a
point = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Bind (Free f) where
    Free f a
x >>- :: forall a b. Free f a -> (a -> Free f b) -> Free f b
>>- a -> Free f b
f  = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \b -> r
p forall s. f s -> (s -> r) -> r
b -> forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree Free f a
x (\a
y -> forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree (a -> Free f b
f a
y) b -> r
p forall s. f s -> (s -> r) -> r
b) forall s. f s -> (s -> r) -> r
b

instance Monad (Free f) where
    >>= :: forall a b. Free f a -> (a -> Free f b) -> Free f b
(>>=)    = forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
(>>-)

instance M.MonadFree f (Free f) where
    wrap :: forall a. f (Free f a) -> Free f a
wrap f (Free f a)
x = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \a -> r
p forall s. f s -> (s -> r) -> r
b -> forall s. f s -> (s -> r) -> r
b f (Free f a)
x forall a b. (a -> b) -> a -> b
$ \Free f a
y -> forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree Free f a
y a -> r
p forall s. f s -> (s -> r) -> r
b

instance Foldable f => Foldable (Free f) where
    foldMap :: forall m a. Monoid m => (a -> m) -> Free f a -> m
foldMap a -> m
f = forall a r (f :: * -> *).
(a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
foldFreeC a -> m
f forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

instance Traversable f => Traversable (Free f) where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Free f a -> f (Free f b)
traverse a -> f b
f = forall (f :: * -> *) a r.
Functor f =>
(a -> r) -> (f r -> r) -> Free f a -> r
foldFree (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure   forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f        )
                          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA)

instance (Functor f, Eq1 f) => Eq1 (Free f) where
    liftEq :: forall a b. (a -> b -> Bool) -> Free f a -> Free f b -> Bool
liftEq a -> b -> Bool
eq Free f a
x Free f b
y = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq @(M.Free f) a -> b -> Bool
eq (forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f a
x) (forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f b
y)

instance (Functor f, Ord1 f) => Ord1 (Free f) where
    liftCompare :: forall a b.
(a -> b -> Ordering) -> Free f a -> Free f b -> Ordering
liftCompare a -> b -> Ordering
c Free f a
x Free f b
y = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare @(M.Free f) a -> b -> Ordering
c (forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f a
x) (forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f b
y)

instance (Functor f, Eq1 f, Eq a) => Eq (Free f a) where
    == :: Free f a -> Free f a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Functor f, Ord1 f, Ord a) => Ord (Free f a) where
    compare :: Free f a -> Free f a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Functor f, Show1 f) => Show1 (Free f) where
    liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d Free f a
x = case forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f a
x of
        M.Pure a
y  -> forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
sp String
"pure" Int
d a
y
        M.Free f (Free f a)
ys -> forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> Free f a -> ShowS
sp' [Free f a] -> ShowS
sl') String
"wrap" Int
d f (Free f a)
ys
      where
        sp' :: Int -> Free f a -> ShowS
sp' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl
        sl' :: [Free f a] -> ShowS
sl' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl

-- | Show in terms of 'pure' and 'M.wrap'.
instance (Functor f, Show1 f, Show a) => Show (Free f a) where
    showsPrec :: Int -> Free f a -> ShowS
showsPrec = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec forall a. Show a => Int -> a -> ShowS
showsPrec forall a. Show a => [a] -> ShowS
showList

instance (Functor f, Read1 f) => Read1 (Free f) where
    liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Free f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = Int -> ReadS (Free f a)
go
      where
        go :: Int -> ReadS (Free f a)
go = forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
            forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rp String
"pure" forall (f :: * -> *) a. Applicative f => a -> f a
pure
         forall a. Semigroup a => a -> a -> a
<> forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (Free f a)
go (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl)) String
"wrap" forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap

-- | Read in terms of 'pure' and 'M.wrap'.
instance (Functor f, Read1 f, Read a) => Read (Free f a) where
    readPrec :: ReadPrec (Free f a)
readPrec = forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
    readListPrec :: ReadPrec [Free f a]
readListPrec = forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Free f a]
readList = forall a. Read a => ReadS [a]
readListDefault

-- | Convert a @'Free' f@ into any instance of @'M.MonadFree' f@.
reFree
    :: (M.MonadFree f m, Functor f)
    => Free f a
    -> m a
reFree :: forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree = forall (f :: * -> *) a r.
Functor f =>
(a -> r) -> (f r -> r) -> Free f a -> r
foldFree forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap

-- | Lift an @f@ into @'Free' f@, so you can use it as a 'Monad'.
--
-- This is 'Data.HFunctor.inject'.
liftFree :: f ~> Free f
liftFree :: forall (f :: * -> *). f ~> Free f
liftFree f x
x = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \x -> r
p forall s. f s -> (s -> r) -> r
b -> forall s. f s -> (s -> r) -> r
b f x
x x -> r
p

-- | Interpret a @'Free' f@ into a context @g@, provided that @g@ has
-- a 'Monad' instance.
--
-- This is 'Data.HFunctor.Interpret.interpret'.
interpretFree :: Monad g => (f ~> g) -> Free f ~> g
interpretFree :: forall (g :: * -> *) (f :: * -> *).
Monad g =>
(f ~> g) -> Free f ~> g
interpretFree f ~> g
f = forall a r (f :: * -> *).
(a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
foldFree' forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f ~> g
f)

-- | Extract the @f@s back "out" of a @'Free' f@, utilizing its 'Monad'
-- instance.
--
-- This is 'Data.HFunctor.Interpret.retract'.
retractFree :: Monad f => Free f ~> f
retractFree :: forall (f :: * -> *). Monad f => Free f ~> f
retractFree = forall a r (f :: * -> *).
(a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
foldFree' forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)

-- | Swap out the underlying functor over a 'Free'.  This preserves all of
-- the structure of the 'Free'.
hoistFree :: (f ~> g) -> Free f ~> Free g
hoistFree :: forall (f :: * -> *) (g :: * -> *). (f ~> g) -> Free f ~> Free g
hoistFree f ~> g
f Free f x
x = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \x -> r
p forall s. g s -> (s -> r) -> r
b -> forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree Free f x
x x -> r
p (forall s. g s -> (s -> r) -> r
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. f ~> g
f)

-- | A version of 'foldFree' that doesn't require @'Functor' f@, by taking
-- a RankN folding function.  This is essentially a flipped 'runFree'.
foldFree'
    :: (a -> r)
    -> (forall s. f s -> (s -> r) -> r)
    -> Free f a
    -> r
foldFree' :: forall a r (f :: * -> *).
(a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
foldFree' a -> r
f forall s. f s -> (s -> r) -> r
g Free f a
x = forall (f :: * -> *) a.
Free f a
-> forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
runFree Free f a
x a -> r
f forall s. f s -> (s -> r) -> r
g

-- | A version of 'foldFree' that doesn't require @'Functor' f@, by folding
-- over a 'Coyoneda' instead.
foldFreeC
    :: (a -> r)                 -- ^ handle 'pure'
    -> (Coyoneda f r -> r)      -- ^ handle 'M.wrap'
    -> Free f a
    -> r
foldFreeC :: forall a r (f :: * -> *).
(a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
foldFreeC a -> r
f Coyoneda f r -> r
g = forall a r (f :: * -> *).
(a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
foldFree' a -> r
f (\f s
y s -> r
n -> Coyoneda f r -> r
g (forall b a (f :: * -> *). (b -> a) -> f b -> Coyoneda f a
Coyoneda s -> r
n f s
y))

-- | Recursively fold down a 'Free' by handling the 'pure' case and the
-- nested/wrapped case.
--
-- This is a catamorphism.
--
-- This requires @'Functor' f@; see 'foldFree'' and 'foldFreeC' for
-- a version that doesn't require @'Functor' f@.
foldFree
    :: Functor f
    => (a -> r)                 -- ^ handle 'pure'
    -> (f r -> r)               -- ^ handle 'M.wrap'
    -> Free f a
    -> r
foldFree :: forall (f :: * -> *) a r.
Functor f =>
(a -> r) -> (f r -> r) -> Free f a -> r
foldFree a -> r
f f r -> r
g = forall a r (f :: * -> *).
(a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
foldFreeC a -> r
f (f r -> r
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => Coyoneda f a -> f a
lowerCoyoneda)

-- | The Free 'Bind'.  Imbues any functor @f@ with a 'Bind' instance.
--
-- Conceptually, this is "'Free' without pure".  That is, while normally
-- @'Free' f a@ is an @a@, a @f a@, a @f (f a)@, etc., a @'Free1' f a@ is
-- an @f a@, @f (f a)@, @f (f (f a))@, etc.  It's a 'Free' with "at least
-- one layer of @f@", excluding the @a@ case.
--
-- It can be useful as the semigroup formed by ':.:' (functor composition):
-- Sometimes we want an @f :.: f@, or an @f :.: f :.: f@, or an @f :.:
-- f :.: f :.: f@...just as long as we have at least one @f@.
newtype Free1 f a = Free1
    { forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 :: forall r. (forall s. f s -> (s -> a) -> r)
                         -> (forall s. f s -> (s -> r) -> r)
                         -> r
    }

instance Functor (Free1 f) where
    fmap :: forall a b. (a -> b) -> Free1 f a -> Free1 f b
fmap a -> b
f Free1 f a
x = forall (f :: * -> *) a.
(forall r.
 (forall s. f s -> (s -> a) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f a
Free1 forall a b. (a -> b) -> a -> b
$ \forall s. f s -> (s -> b) -> r
p forall s. f s -> (s -> r) -> r
b -> forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 Free1 f a
x (\f s
y s -> a
c -> forall s. f s -> (s -> b) -> r
p f s
y (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a
c)) forall s. f s -> (s -> r) -> r
b

instance Apply (Free1 f) where
    <.> :: forall a b. Free1 f (a -> b) -> Free1 f a -> Free1 f b
(<.>) = forall (f :: * -> *) a b. Bind f => f (a -> b) -> f a -> f b
apDefault

instance Bind (Free1 f) where
    Free1 f a
x >>- :: forall a b. Free1 f a -> (a -> Free1 f b) -> Free1 f b
>>- a -> Free1 f b
f = forall (f :: * -> *) a.
(forall r.
 (forall s. f s -> (s -> a) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f a
Free1 forall a b. (a -> b) -> a -> b
$ \forall s. f s -> (s -> b) -> r
p forall s. f s -> (s -> r) -> r
b ->
        forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 Free1 f a
x (\f s
y s -> a
c -> forall s. f s -> (s -> r) -> r
b f s
y ((\Free1 f b
q -> forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 Free1 f b
q forall s. f s -> (s -> b) -> r
p forall s. f s -> (s -> r) -> r
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Free1 f b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a
c)) forall s. f s -> (s -> r) -> r
b

instance Foldable f => Foldable (Free1 f) where
    foldMap :: forall m a. Monoid m => (a -> m) -> Free1 f a -> m
foldMap a -> m
f = forall (f :: * -> *) a r.
(Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

instance Traversable f => Traversable (Free1 f) where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Free1 f a -> f (Free1 f b)
traverse a -> f b
f = forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> Free1 f a
DoneF1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f)
                           (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f (Free1 f a) -> Free1 f a
MoreF1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA )

instance Foldable1 f => Foldable1 (Free1 f) where
    foldMap1 :: forall m a. Semigroup m => (a -> m) -> Free1 f a -> m
foldMap1 a -> m
f = forall (f :: * -> *) a r.
(Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C (forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 a -> m
f) forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1

instance Traversable1 f => Traversable1 (Free1 f) where
    traverse1 :: forall (f :: * -> *) a b.
Apply f =>
(a -> f b) -> Free1 f a -> f (Free1 f b)
traverse1 a -> f b
f = forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> Free1 f a
DoneF1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
traverse1 a -> f b
f)
                            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f (Free1 f a) -> Free1 f a
MoreF1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) b.
(Traversable1 t, Apply f) =>
t (f b) -> f (t b)
sequence1  )

instance (Functor f, Eq1 f) => Eq1 (Free1 f) where
    liftEq :: forall a b. (a -> b -> Bool) -> Free1 f a -> Free1 f b -> Bool
liftEq a -> b -> Bool
eq Free1 f a
x Free1 f b
y = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq @(Free f) a -> b -> Bool
eq (forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f a
x) (forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f b
y)

instance (Functor f, Ord1 f) => Ord1 (Free1 f) where
    liftCompare :: forall a b.
(a -> b -> Ordering) -> Free1 f a -> Free1 f b -> Ordering
liftCompare a -> b -> Ordering
c Free1 f a
x Free1 f b
y = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare @(Free f) a -> b -> Ordering
c (forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f a
x) (forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f b
y)

instance (Functor f, Eq1 f, Eq a) => Eq (Free1 f a) where
    == :: Free1 f a -> Free1 f a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Functor f, Ord1 f, Ord a) => Ord (Free1 f a) where
    compare :: Free1 f a -> Free1 f a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Functor f, Show1 f) => Show1 (Free1 f) where
    liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free1 f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d = \case
        DoneF1 f a
x -> forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp  [a] -> ShowS
sl ) String
"DoneF1" Int
d f a
x
        MoreF1 f (Free1 f a)
x -> forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> Free1 f a -> ShowS
sp' [Free1 f a] -> ShowS
sl') String
"MoreF1" Int
d f (Free1 f a)
x
      where
        sp' :: Int -> Free1 f a -> ShowS
sp' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl
        sl' :: [Free1 f a] -> ShowS
sl' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl

-- | Show in terms of 'DoneF1' and 'MoreF1'.
instance (Functor f, Show1 f, Show a) => Show (Free1 f a) where
    showsPrec :: Int -> Free1 f a -> ShowS
showsPrec = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec forall a. Show a => Int -> a -> ShowS
showsPrec forall a. Show a => [a] -> ShowS
showList

instance (Functor f, Read1 f) => Read1 (Free1 f) where
    liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Free1 f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = Int -> ReadS (Free1 f a)
go
      where
        go :: Int -> ReadS (Free1 f a)
go = forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
            forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) String
"DoneF1" forall (f :: * -> *) a. Functor f => f a -> Free1 f a
DoneF1
         forall a. Semigroup a => a -> a -> a
<> forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (Free1 f a)
go (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl)) String
"MoreF1" forall (f :: * -> *) a. Functor f => f (Free1 f a) -> Free1 f a
MoreF1

-- | Read in terms of 'DoneF1' and 'MoreF1'.
instance (Functor f, Read1 f, Read a) => Read (Free1 f a) where
    readPrec :: ReadPrec (Free1 f a)
readPrec = forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
    readListPrec :: ReadPrec [Free1 f a]
readListPrec = forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Free1 f a]
readList = forall a. Read a => ReadS [a]
readListDefault

-- | Constructor matching on the case that a @'Free1' f@ consists of just
-- a single un-nested @f@.  Used as a part of the 'Show' and 'Read'
-- instances.
pattern DoneF1 :: Functor f => f a -> Free1 f a
pattern $bDoneF1 :: forall (f :: * -> *) a. Functor f => f a -> Free1 f a
$mDoneF1 :: forall {r} {f :: * -> *} {a}.
Functor f =>
Free1 f a -> (f a -> r) -> ((# #) -> r) -> r
DoneF1 x <- (matchFree1 -> L1 x)
  where
    DoneF1 f a
x = forall (f :: * -> *). f ~> Free1 f
liftFree1 f a
x

-- | Constructor matching on the case that a @'Free1' f@ is a nested @f
-- ('Free1' f a)@.  Used as a part of the 'Show' and 'Read' instances.
--
-- As a constructor, this is equivalent to 'M.wrap'.
pattern MoreF1 :: Functor f => f (Free1 f a) -> Free1 f a
pattern $bMoreF1 :: forall (f :: * -> *) a. Functor f => f (Free1 f a) -> Free1 f a
$mMoreF1 :: forall {r} {f :: * -> *} {a}.
Functor f =>
Free1 f a -> (f (Free1 f a) -> r) -> ((# #) -> r) -> r
MoreF1 x <- (matchFree1 -> R1 (Comp x))
  where
    MoreF1 f (Free1 f a)
x = forall (f :: * -> *). f ~> Free1 f
liftFree1 f (Free1 f a)
x forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- forall a. a -> a
id
{-# COMPLETE DoneF1, MoreF1 #-}

-- | Convert a @'Free1' f@ into any instance of @'M.MonadFree' f@.
reFree1
    :: (M.MonadFree f m, Functor f)
    => Free1 f a
    -> m a
reFree1 :: forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free1 f a -> m a
reFree1 = forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 (forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap

-- | @'Free1' f@ is a special subset of @'Free' f@ that consists of at least one
-- nested @f@.  This converts it back into the "bigger" type.
--
-- See 'free1Comp' for a version that preserves the "one nested layer"
-- property.
toFree :: Free1 f ~> Free f
toFree :: forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f x
x = forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free forall a b. (a -> b) -> a -> b
$ \x -> r
p forall s. f s -> (s -> r) -> r
b -> forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 Free1 f x
x (\f s
y s -> x
c -> forall s. f s -> (s -> r) -> r
b f s
y (x -> r
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> x
c)) forall s. f s -> (s -> r) -> r
b

-- | Map the underlying functor under a 'Free1'.
hoistFree1 :: (f ~> g) -> Free1 f ~> Free1 g
hoistFree1 :: forall (f :: * -> *) (g :: * -> *). (f ~> g) -> Free1 f ~> Free1 g
hoistFree1 f ~> g
f Free1 f x
x = forall (f :: * -> *) a.
(forall r.
 (forall s. f s -> (s -> a) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f a
Free1 forall a b. (a -> b) -> a -> b
$ \forall s. g s -> (s -> x) -> r
p forall s. g s -> (s -> r) -> r
b -> forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 Free1 f x
x (forall s. g s -> (s -> x) -> r
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. f ~> g
f) (forall s. g s -> (s -> r) -> r
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. f ~> g
f)

-- | Because a @'Free1' f@ is just a @'Free' f@ with at least one nested
-- layer of @f@, this function converts it back into the one-nested-@f@
-- format.
free1Comp :: Free1 f ~> Comp f (Free f)
free1Comp :: forall (f :: * -> *). Free1 f ~> Comp f (Free f)
free1Comp = forall (f :: * -> *) a r.
(forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r) -> Free1 f a -> r
foldFree1' (\f s
y s -> x
c -> f s
y forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> x
c)) forall a b. (a -> b) -> a -> b
$ \f s
y s -> Comp f (Free f) x
n ->
    f s
y forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= \s
z -> case s -> Comp f (Free f) x
n s
z of
      f x
q :>>= x -> Free f x
m -> forall (f :: * -> *). f ~> Free f
liftFree f x
q forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> Free f x
m

-- | Inject an @f@ into a @'Free1' f@
liftFree1 :: f ~> Free1 f
liftFree1 :: forall (f :: * -> *). f ~> Free1 f
liftFree1 f x
x = forall (f :: * -> *) a.
(forall r.
 (forall s. f s -> (s -> a) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f a
Free1 forall a b. (a -> b) -> a -> b
$ \forall s. f s -> (s -> x) -> r
p forall s. f s -> (s -> r) -> r
_ -> forall s. f s -> (s -> x) -> r
p f x
x forall a. a -> a
id

-- | Retract the @f@ out of a @'Free1' f@, as long as the @f@ implements
-- 'Bind'.  Since we always have at least one @f@, we do not need a full
-- 'Monad' constraint.
retractFree1 :: Bind f => Free1 f ~> f
retractFree1 :: forall (f :: * -> *). Bind f => Free1 f ~> f
retractFree1 = forall (f :: * -> *) a r.
(forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r) -> Free1 f a -> r
foldFree1' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
(<&>) forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
(>>-)

-- | Interpret the @'Free1' f@ in some context @g@, provided that @g@ has
-- a 'Bind' instance.  Since we always have at least one @f@, we will
-- always have at least one @g@, so we do not need a full 'Monad'
-- constraint.
interpretFree1 :: Bind g => (f ~> g) -> Free1 f ~> g
interpretFree1 :: forall (g :: * -> *) (f :: * -> *).
Bind g =>
(f ~> g) -> Free1 f ~> g
interpretFree1 f ~> g
f = forall (f :: * -> *) a r.
(forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r) -> Free1 f a -> r
foldFree1' (\f s
y s -> x
c -> s -> x
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ~> g
f f s
y)
                              (\f s
y s -> g x
n -> f ~> g
f f s
y forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- s -> g x
n)

-- | A @'Free1' f@ is either a single un-nested @f@, or a @f@ nested with
-- another @'Free1' f@.  This decides which is the case.
matchFree1 :: forall f. Functor f => Free1 f ~> f :+: Comp f (Free1 f)
matchFree1 :: forall (f :: * -> *).
Functor f =>
Free1 f ~> (f :+: Comp f (Free1 f))
matchFree1 = forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: * -> *) (g :: k -> *) (a :: k).
Functor f =>
f (g a) -> Comp f g a
Comp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f :+: Comp f (Free1 f)) ~> Free1 f
shuffle)
  where
    shuffle :: f :+: Comp f (Free1 f) ~> Free1 f
    shuffle :: (f :+: Comp f (Free1 f)) ~> Free1 f
shuffle (L1 f x
y         ) = forall (f :: * -> *). f ~> Free1 f
liftFree1 f x
y
    shuffle (R1 (f x
y :>>= x -> Free1 f x
n)) = forall (f :: * -> *). f ~> Free1 f
liftFree1 f x
y forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- x -> Free1 f x
n

-- | A version of 'foldFree1' that doesn't require @'Functor' f@, by taking
-- a RankN folding function.  This is essentially a flipped 'runFree'.
foldFree1'
    :: (forall s. f s -> (s -> a) -> r)
    -> (forall s. f s -> (s -> r) -> r)
    -> Free1 f a
    -> r
foldFree1' :: forall (f :: * -> *) a r.
(forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r) -> Free1 f a -> r
foldFree1' forall s. f s -> (s -> a) -> r
f forall s. f s -> (s -> r) -> r
g Free1 f a
x = forall (f :: * -> *) a.
Free1 f a
-> forall r.
   (forall s. f s -> (s -> a) -> r)
   -> (forall s. f s -> (s -> r) -> r) -> r
runFree1 Free1 f a
x forall s. f s -> (s -> a) -> r
f forall s. f s -> (s -> r) -> r
g

-- | A version of 'foldFree1' that doesn't require @'Functor' f@, by
-- folding over a 'Coyoneda' instead.
foldFree1C
    :: (Coyoneda f a -> r)
    -> (Coyoneda f r -> r)
    -> Free1 f a
    -> r
foldFree1C :: forall (f :: * -> *) a r.
(Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C Coyoneda f a -> r
f Coyoneda f r -> r
g = forall (f :: * -> *) a r.
(forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r) -> Free1 f a -> r
foldFree1' (\f s
y s -> a
c -> Coyoneda f a -> r
f (forall b a (f :: * -> *). (b -> a) -> f b -> Coyoneda f a
Coyoneda s -> a
c f s
y))
                            (\f s
y s -> r
n -> Coyoneda f r -> r
g (forall b a (f :: * -> *). (b -> a) -> f b -> Coyoneda f a
Coyoneda s -> r
n f s
y))

-- | Recursively fold down a 'Free1' by handling the single @f@ case and
-- the nested/wrapped case.
--
-- This is a catamorphism.
--
-- This requires @'Functor' f@; see 'foldFree'' and 'foldFreeC' for
-- a version that doesn't require @'Functor' f@.
foldFree1
    :: Functor f
    => (f a -> r)       -- ^ handle @'DoneF1'@.
    -> (f r -> r)       -- ^ handle @'MoreF1'@.
    -> Free1 f a
    -> r
foldFree1 :: forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 f a -> r
f f r -> r
g = forall (f :: * -> *) a r.
(Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C (f a -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => Coyoneda f a -> f a
lowerCoyoneda)
                           (f r -> r
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => Coyoneda f a -> f a
lowerCoyoneda)

-- | Functor composition.  @'Comp' f g a@ is equivalent to @f (g a)@, and
-- the 'Comp' pattern synonym is a way of getting the @f (g a)@ in
-- a @'Comp' f g a@.
--
-- For example, @'Maybe' ('IO' 'Bool')@ is @'Comp' 'Maybe' 'IO' 'Bool'@.
--
-- This is mostly useful for its typeclass instances: in particular,
-- 'Functor', 'Applicative', 'Data.Functor.Tensor.HBifunctor', and
-- 'Data.Functor.Tensor.Monoidal'.
--
-- This is essentially a version of 'GHC.Generics.:.:' and
-- 'Data.Functor.Compose.Compose' that allows for an
-- 'Data.Functor.Tensor.HBifunctor' instance.
--
-- It is slightly less performant.  Using @'comp' . 'unComp'@ every once in
-- a while will concretize a 'Comp' value (if you have @'Functor' f@)
-- and remove some indirection if you have a lot of chained operations.
--
-- The "free monoid" over 'Comp' is 'Free', and the "free semigroup" over
-- 'Comp' is 'Free1'.
data Comp f g a =
    forall x. f x :>>= (x -> g a)

instance Functor g => Functor (Comp f g) where
    fmap :: forall a b. (a -> b) -> Comp f g a -> Comp f g b
fmap a -> b
f (f x
x :>>= x -> g a
h) = f x
x forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> g a
h)

-- | @since 0.3.6.0
instance (Apply f, Apply g) => Apply (Comp f g) where
    (f x
x :>>= x -> g (a -> b)
f) <.> :: forall a b. Comp f g (a -> b) -> Comp f g a -> Comp f g b
<.> (f x
y :>>= x -> g a
g) = ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f x
y)
                           forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (\(x
x', x
y') -> x -> g (a -> b)
f x
x' forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> x -> g a
g x
y')
    liftF2 :: forall a b c.
(a -> b -> c) -> Comp f g a -> Comp f g b -> Comp f g c
liftF2 a -> b -> c
h (f x
x :>>= x -> g a
f) (f x
y :>>= x -> g b
g)
            = ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f x
y)
         forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (\(x
x', x
y') -> forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 a -> b -> c
h (x -> g a
f x
x') (x -> g b
g x
y'))

instance (Applicative f, Applicative g) => Applicative (Comp f g) where
    pure :: forall a. a -> Comp f g a
pure a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure () forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const a
x)
    (f x
x :>>= x -> g (a -> b)
f) <*> :: forall a b. Comp f g (a -> b) -> Comp f g a -> Comp f g b
<*> (f x
y :>>= x -> g a
g) = ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f x
y)
                           forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (\(x
x', x
y') -> x -> g (a -> b)
f x
x' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> x -> g a
g x
y')
    liftA2 :: forall a b c.
(a -> b -> c) -> Comp f g a -> Comp f g b -> Comp f g c
liftA2 a -> b -> c
h (f x
x :>>= x -> g a
f) (f x
y :>>= x -> g b
g)
            = ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f x
y)
         forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (\(x
x', x
y') -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
h (x -> g a
f x
x') (x -> g b
g x
y'))

instance (Foldable f, Foldable g) => Foldable (Comp f g) where
    foldMap :: forall m a. Monoid m => (a -> m) -> Comp f g a -> m
foldMap a -> m
f (f x
x :>>= x -> g a
h) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> g a
h) f x
x

instance (Traversable f, Traversable g) => Traversable (Comp f g) where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Comp f g a -> f (Comp f g b)
traverse a -> f b
f (f x
x :>>= x -> g a
h) = (forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= forall a. a -> a
id)
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> g a
h) f x
x

instance (Alternative f, Alternative g) => Alternative (Comp f g) where
    empty :: forall a. Comp f g a
empty = forall (f :: * -> *) a. Alternative f => f a
empty forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= forall a. a -> a
id
    (f x
x :>>= x -> g a
f) <|> :: forall a. Comp f g a -> Comp f g a -> Comp f g a
<|> (f x
y :>>= x -> g a
g) = ((x -> g a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (x -> g a
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
y)) forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= forall a. a -> a
id

-- | @since 0.3.6.0
instance (Alt f, Alt g) => Alt (Comp f g) where
    (f x
x :>>= x -> g a
f) <!> :: forall a. Comp f g a -> Comp f g a -> Comp f g a
<!> (f x
y :>>= x -> g a
g) = ((x -> g a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x) forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> (x -> g a
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
y)) forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= forall a. a -> a
id

-- | @since 0.3.6.0
instance (Plus f, Plus g) => Plus (Comp f g) where
    zero :: forall a. Comp f g a
zero = forall (f :: * -> *) a. Plus f => f a
zero forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= forall a. a -> a
id

instance (Functor f, Show1 f, Show1 g) => Show1 (Comp f g) where
    liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Comp f g a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (Comp f (g a)
x) =
        forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> g a -> ShowS
sp' [g a] -> ShowS
sl') String
"Comp" Int
d f (g a)
x
      where
        sp' :: Int -> g a -> ShowS
sp' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl
        sl' :: [g a] -> ShowS
sl' = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl

instance (Functor f, Show1 f, Show1 g, Show a) => Show (Comp f g a) where
    showsPrec :: Int -> Comp f g a -> ShowS
showsPrec = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec forall a. Show a => Int -> a -> ShowS
showsPrec forall a. Show a => [a] -> ShowS
showList

instance (Functor f, Read1 f, Read1 g) => Read1 (Comp f g) where
    liftReadPrec :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec (Comp f g a)
liftReadPrec ReadPrec a
rp ReadPrec [a]
rl = forall a. ReadPrec a -> ReadPrec a
readData forall a b. (a -> b) -> a -> b
$
        forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith (forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec (g a)
rp' ReadPrec [g a]
rl') String
"Comp" forall {k} (f :: * -> *) (g :: k -> *) (a :: k).
Functor f =>
f (g a) -> Comp f g a
Comp
      where
        rp' :: ReadPrec (g a)
rp' = forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec a
rp ReadPrec [a]
rl
        rl' :: ReadPrec [g a]
rl' = forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
liftReadListPrec ReadPrec a
rp ReadPrec [a]
rl

instance (Functor f, Read1 f, Read1 g, Read a) => Read (Comp f g a) where
    readPrec :: ReadPrec (Comp f g a)
readPrec = forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
    readListPrec :: ReadPrec [Comp f g a]
readListPrec = forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Comp f g a]
readList = forall a. Read a => ReadS [a]
readListDefault

instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Comp f g) where
    liftEq :: forall a b. (a -> b -> Bool) -> Comp f g a -> Comp f g b -> Bool
liftEq a -> b -> Bool
eq (Comp f (g a)
x) (Comp f (g b)
y) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq) f (g a)
x f (g b)
y

instance (Functor f, Ord1 f, Ord1 g) => Ord1 (Comp f g) where
    liftCompare :: forall a b.
(a -> b -> Ordering) -> Comp f g a -> Comp f g b -> Ordering
liftCompare a -> b -> Ordering
c (Comp f (g a)
x) (Comp f (g b)
y) = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
c) f (g a)
x f (g b)
y

instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (Comp f g a) where
    == :: Comp f g a -> Comp f g a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord (Comp f g a) where
    compare :: Comp f g a -> Comp f g a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

-- | "Smart constructor" for 'Comp' that doesn't require @'Functor' f@.
comp :: f (g a) -> Comp f g a
comp :: forall {k} (f :: * -> *) (g :: k -> *) (a :: k).
f (g a) -> Comp f g a
comp = (forall {k} (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= forall a. a -> a
id)

-- | Pattern match on and construct a @'Comp' f g a@ as if it were @f
-- (g a)@.
pattern Comp :: Functor f => f (g a) -> Comp f g a
pattern $bComp :: forall {k} (f :: * -> *) (g :: k -> *) (a :: k).
Functor f =>
f (g a) -> Comp f g a
$mComp :: forall {r} {k} {f :: * -> *} {g :: k -> *} {a :: k}.
Functor f =>
Comp f g a -> (f (g a) -> r) -> ((# #) -> r) -> r
Comp { forall {k} (f :: * -> *) (g :: k -> *) (a :: k).
Functor f =>
Comp f g a -> f (g a)
unComp } <- ((\case f x
x :>>= x -> g a
f -> x -> g a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x)->unComp)
  where
    Comp f (g a)
x = forall {k} (f :: * -> *) (g :: k -> *) (a :: k).
f (g a) -> Comp f g a
comp f (g a)
x
{-# COMPLETE Comp #-}