-- |
-- 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
    { 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 :: (a -> b) -> Free f a -> Free f b
fmap a -> b
f Free f a
x = (forall r. (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f b
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free f b)
-> (forall r. (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f b
forall a b. (a -> b) -> a -> b
$ \b -> r
p forall s. f s -> (s -> r) -> r
b -> Free f a -> (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
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 (b -> r) -> (a -> b) -> a -> r
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
    <.> :: Free f (a -> b) -> Free f a -> Free f 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 :: a -> Free f a
pure  = a -> Free f a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: Free f (a -> b) -> Free f a -> Free f 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 :: a -> Free f a
point = a -> Free f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Bind (Free f) where
    Free f a
x >>- :: Free f a -> (a -> Free f b) -> Free f b
>>- a -> Free f b
f  = (forall r. (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f b
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free f b)
-> (forall r. (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f b
forall a b. (a -> b) -> a -> b
$ \b -> r
p forall s. f s -> (s -> r) -> r
b -> Free f a -> (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
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 -> Free f b -> (b -> r) -> (forall s. f s -> (s -> r) -> r) -> r
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
    return :: a -> Free f a
return a
x = (forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free f a)
-> (forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
forall a b. (a -> b) -> a -> b
$ \a -> r
p forall s. f s -> (s -> r) -> r
_ -> a -> r
p a
x
    >>= :: Free f a -> (a -> Free f b) -> Free f 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 :: f (Free f a) -> Free f a
wrap f (Free f a)
x = (forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free f a)
-> (forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
forall a b. (a -> b) -> a -> b
$ \a -> r
p forall s. f s -> (s -> r) -> r
b -> f (Free f a) -> (Free f a -> r) -> r
forall s. f s -> (s -> r) -> r
b f (Free f a)
x ((Free f a -> r) -> r) -> (Free f a -> r) -> r
forall a b. (a -> b) -> a -> b
$ \Free f a
y -> Free f a -> (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
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 :: (a -> m) -> Free f a -> m
foldMap a -> m
f = (a -> m) -> (Coyoneda f m -> m) -> Free f a -> m
forall a r (f :: * -> *).
(a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
foldFreeC a -> m
f Coyoneda f m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

instance Traversable f => Traversable (Free f) where
    traverse :: (a -> f b) -> Free f a -> f (Free f b)
traverse a -> f b
f = (a -> f (Free f b))
-> (f (f (Free f b)) -> f (Free f b)) -> Free f a -> f (Free f b)
forall (f :: * -> *) a r.
Functor f =>
(a -> r) -> (f r -> r) -> Free f a -> r
foldFree ((b -> Free f b) -> f b -> f (Free f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Free f b
forall (f :: * -> *) a. Applicative f => a -> f a
pure   (f b -> f (Free f b)) -> (a -> f b) -> a -> f (Free f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f        )
                          ((f (Free f b) -> Free f b) -> f (f (Free f b)) -> f (Free f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Free f b) -> Free f b
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap (f (f (Free f b)) -> f (Free f b))
-> (f (f (Free f b)) -> f (f (Free f b)))
-> f (f (Free f b))
-> f (Free f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (f (Free f b)) -> f (f (Free f b))
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 :: (a -> b -> Bool) -> Free f a -> Free f b -> Bool
liftEq a -> b -> Bool
eq Free f a
x Free f b
y = (a -> b -> Bool) -> Free f a -> Free f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq @(M.Free f) a -> b -> Bool
eq (Free f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f a
x) (Free f b -> Free f b
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 :: (a -> b -> Ordering) -> Free f a -> Free f b -> Ordering
liftCompare a -> b -> Ordering
c Free f a
x Free f b
y = (a -> b -> Ordering) -> Free f a -> Free f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare @(M.Free f) a -> b -> Ordering
c (Free f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f a
x) (Free f b -> Free f b
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
(==) = 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 = Free f a -> Free f a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Functor f, Show1 f) => Show1 (Free f) where
    liftShowsPrec :: (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 Free f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a.
(MonadFree f m, Functor f) =>
Free f a -> m a
reFree Free f a
x of
        M.Pure a
y  -> (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
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 -> (Int -> f (Free f a) -> ShowS)
-> String -> Int -> f (Free f a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> Free f a -> ShowS)
-> ([Free f a] -> ShowS) -> Int -> f (Free f a) -> ShowS
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' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free f a -> ShowS
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' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> [Free f a] -> ShowS
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 = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList

instance (Functor f, Read1 f) => Read1 (Free f) where
    liftReadsPrec :: (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 = (String -> ReadS (Free f a)) -> Int -> ReadS (Free f a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Free f a)) -> Int -> ReadS (Free f a))
-> (String -> ReadS (Free f a)) -> Int -> ReadS (Free f a)
forall a b. (a -> b) -> a -> b
$
            (Int -> ReadS a)
-> String -> (a -> Free f a) -> String -> ReadS (Free f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rp String
"pure" a -> Free f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
         (String -> ReadS (Free f a))
-> (String -> ReadS (Free f a)) -> String -> ReadS (Free f a)
forall a. Semigroup a => a -> a -> a
<> (Int -> ReadS (f (Free f a)))
-> String
-> (f (Free f a) -> Free f a)
-> String
-> ReadS (Free f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS (Free f a))
-> ReadS [Free f a] -> Int -> ReadS (f (Free f a))
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (Free f a)
go ((Int -> ReadS a) -> ReadS [a] -> ReadS [Free f a]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl)) String
"wrap" f (Free f a) -> Free f a
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 = ReadPrec (Free f a)
forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
    readListPrec :: ReadPrec [Free f a]
readListPrec = ReadPrec [Free f a]
forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Free f a]
readList = ReadS [Free f a]
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 :: Free f a -> m a
reFree = (a -> m a) -> (f (m a) -> m a) -> Free f a -> m a
forall (f :: * -> *) a r.
Functor f =>
(a -> r) -> (f r -> r) -> Free f a -> r
foldFree a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f (m a) -> m a
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 :: f x -> Free f x
liftFree f x
x = (forall r. (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f x
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free f x)
-> (forall r. (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f x
forall a b. (a -> b) -> a -> b
$ \x -> r
p forall s. f s -> (s -> r) -> r
b -> f x -> (x -> r) -> r
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 :: (f ~> g) -> Free f ~> g
interpretFree f ~> g
f = (x -> g x)
-> (forall s. f s -> (s -> g x) -> g x) -> Free f x -> g x
forall a r (f :: * -> *).
(a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
foldFree' x -> g x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (g s -> (s -> g x) -> g x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) (g s -> (s -> g x) -> g x)
-> (f s -> g s) -> f s -> (s -> g x) -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> g s
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 :: Free f ~> f
retractFree = (x -> f x)
-> (forall s. f s -> (s -> f x) -> f x) -> Free f x -> f x
forall a r (f :: * -> *).
(a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
foldFree' x -> f x
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall s. f s -> (s -> f x) -> f x
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 :: (f ~> g) -> Free f ~> Free g
hoistFree f ~> g
f Free f x
x = (forall r. (x -> r) -> (forall s. g s -> (s -> r) -> r) -> r)
-> Free g x
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (x -> r) -> (forall s. g s -> (s -> r) -> r) -> r)
 -> Free g x)
-> (forall r. (x -> r) -> (forall s. g s -> (s -> r) -> r) -> r)
-> Free g x
forall a b. (a -> b) -> a -> b
$ \x -> r
p forall s. g s -> (s -> r) -> r
b -> Free f x -> (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r
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 (g s -> (s -> r) -> r
forall s. g s -> (s -> r) -> r
b (g s -> (s -> r) -> r) -> (f s -> g s) -> f s -> (s -> r) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> g s
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' :: (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 = Free f a -> (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
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 :: (a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
foldFreeC a -> r
f Coyoneda f r -> r
g = (a -> r) -> (forall s. f s -> (s -> r) -> r) -> Free f a -> r
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 ((s -> r) -> f s -> Coyoneda f r
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 :: (a -> r) -> (f r -> r) -> Free f a -> r
foldFree a -> r
f f r -> r
g = (a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
forall a r (f :: * -> *).
(a -> r) -> (Coyoneda f r -> r) -> Free f a -> r
foldFreeC a -> r
f (f r -> r
g (f r -> r) -> (Coyoneda f r -> f r) -> Coyoneda f r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coyoneda f r -> f r
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
    { 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 :: (a -> b) -> Free1 f a -> Free1 f b
fmap a -> b
f Free1 f a
x = (forall r.
 (forall s. f s -> (s -> b) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f b
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 r.
  (forall s. f s -> (s -> b) -> r)
  -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free1 f b)
-> (forall r.
    (forall s. f s -> (s -> b) -> r)
    -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f b
forall a b. (a -> b) -> a -> b
$ \forall s. f s -> (s -> b) -> r
p forall s. f s -> (s -> r) -> r
b -> Free1 f a
-> (forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
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 -> f s -> (s -> b) -> r
forall s. f s -> (s -> b) -> r
p f s
y (a -> b
f (a -> b) -> (s -> a) -> s -> b
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
    <.> :: Free1 f (a -> b) -> Free1 f a -> Free1 f 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 >>- :: Free1 f a -> (a -> Free1 f b) -> Free1 f b
>>- a -> Free1 f b
f = (forall r.
 (forall s. f s -> (s -> b) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f b
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 r.
  (forall s. f s -> (s -> b) -> r)
  -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free1 f b)
-> (forall r.
    (forall s. f s -> (s -> b) -> r)
    -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f b
forall a b. (a -> b) -> a -> b
$ \forall s. f s -> (s -> b) -> r
p forall s. f s -> (s -> r) -> r
b ->
        Free1 f a
-> (forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
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 -> f s -> (s -> r) -> r
forall s. f s -> (s -> r) -> r
b f s
y ((\Free1 f b
q -> Free1 f b
-> (forall s. f s -> (s -> b) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
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) (Free1 f b -> r) -> (s -> Free1 f b) -> s -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Free1 f b
f (a -> Free1 f b) -> (s -> a) -> s -> Free1 f b
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 :: (a -> m) -> Free1 f a -> m
foldMap a -> m
f = (Coyoneda f a -> m) -> (Coyoneda f m -> m) -> Free1 f a -> m
forall (f :: * -> *) a r.
(Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C ((a -> m) -> Coyoneda f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) Coyoneda f m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

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

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

instance Traversable1 f => Traversable1 (Free1 f) where
    traverse1 :: (a -> f b) -> Free1 f a -> f (Free1 f b)
traverse1 a -> f b
f = (f a -> f (Free1 f b))
-> (f (f (Free1 f b)) -> f (Free1 f b))
-> Free1 f a
-> f (Free1 f b)
forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 ((f b -> Free1 f b) -> f (f b) -> f (Free1 f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f b -> Free1 f b
forall (f :: * -> *) a. Functor f => f a -> Free1 f a
DoneF1 (f (f b) -> f (Free1 f b))
-> (f a -> f (f b)) -> f a -> f (Free1 f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
traverse1 a -> f b
f)
                            ((f (Free1 f b) -> Free1 f b) -> f (f (Free1 f b)) -> f (Free1 f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Free1 f b) -> Free1 f b
forall (f :: * -> *) a. Functor f => f (Free1 f a) -> Free1 f a
MoreF1 (f (f (Free1 f b)) -> f (Free1 f b))
-> (f (f (Free1 f b)) -> f (f (Free1 f b)))
-> f (f (Free1 f b))
-> f (Free1 f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (f (Free1 f b)) -> f (f (Free1 f b))
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 :: (a -> b -> Bool) -> Free1 f a -> Free1 f b -> Bool
liftEq a -> b -> Bool
eq Free1 f a
x Free1 f b
y = (a -> b -> Bool) -> Free f a -> Free f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq @(Free f) a -> b -> Bool
eq (Free1 f a -> Free f a
forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f a
x) (Free1 f b -> Free f b
forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f b
y)

instance (Functor f, Ord1 f) => Ord1 (Free1 f) where
    liftCompare :: (a -> b -> Ordering) -> Free1 f a -> Free1 f b -> Ordering
liftCompare a -> b -> Ordering
c Free1 f a
x Free1 f b
y = (a -> b -> Ordering) -> Free f a -> Free f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare @(Free f) a -> b -> Ordering
c (Free1 f a -> Free f a
forall (f :: * -> *). Free1 f ~> Free f
toFree Free1 f a
x) (Free1 f b -> Free f b
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
(==) = 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 = Free1 f a -> Free1 f a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Functor f, Show1 f) => Show1 (Free1 f) where
    liftShowsPrec :: (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 -> (Int -> f a -> ShowS) -> String -> Int -> f a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
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 -> (Int -> f (Free1 f a) -> ShowS)
-> String -> Int -> f (Free1 f a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> Free1 f a -> ShowS)
-> ([Free1 f a] -> ShowS) -> Int -> f (Free1 f a) -> ShowS
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' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free1 f a -> ShowS
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' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> [Free1 f a] -> ShowS
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 = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free1 f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList

instance (Functor f, Read1 f) => Read1 (Free1 f) where
    liftReadsPrec :: (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 = (String -> ReadS (Free1 f a)) -> Int -> ReadS (Free1 f a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Free1 f a)) -> Int -> ReadS (Free1 f a))
-> (String -> ReadS (Free1 f a)) -> Int -> ReadS (Free1 f a)
forall a b. (a -> b) -> a -> b
$
            (Int -> ReadS (f a))
-> String -> (f a -> Free1 f a) -> String -> ReadS (Free1 f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) String
"DoneF1" f a -> Free1 f a
forall (f :: * -> *) a. Functor f => f a -> Free1 f a
DoneF1
         (String -> ReadS (Free1 f a))
-> (String -> ReadS (Free1 f a)) -> String -> ReadS (Free1 f a)
forall a. Semigroup a => a -> a -> a
<> (Int -> ReadS (f (Free1 f a)))
-> String
-> (f (Free1 f a) -> Free1 f a)
-> String
-> ReadS (Free1 f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS (Free1 f a))
-> ReadS [Free1 f a] -> Int -> ReadS (f (Free1 f a))
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (Free1 f a)
go ((Int -> ReadS a) -> ReadS [a] -> ReadS [Free1 f a]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl)) String
"MoreF1" f (Free1 f a) -> Free1 f a
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 = ReadPrec (Free1 f a)
forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
    readListPrec :: ReadPrec [Free1 f a]
readListPrec = ReadPrec [Free1 f a]
forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Free1 f a]
readList = ReadS [Free1 f a]
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 :: f a -> Free1 f a
$mDoneF1 :: forall r (f :: * -> *) a.
Functor f =>
Free1 f a -> (f a -> r) -> (Void# -> r) -> r
DoneF1 x <- (matchFree1 -> L1 x)
  where
    DoneF1 f a
x = f a -> Free1 f a
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 :: f (Free1 f a) -> Free1 f a
$mMoreF1 :: forall r (f :: * -> *) a.
Functor f =>
Free1 f a -> (f (Free1 f a) -> r) -> (Void# -> r) -> r
MoreF1 x <- (matchFree1 -> R1 (Comp x))
  where
    MoreF1 f (Free1 f a)
x = f (Free1 f a) -> Free1 f (Free1 f a)
forall (f :: * -> *). f ~> Free1 f
liftFree1 f (Free1 f a)
x Free1 f (Free1 f a) -> (Free1 f a -> Free1 f a) -> Free1 f a
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- Free1 f a -> Free1 f a
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 :: Free1 f a -> m a
reFree1 = (f a -> m a) -> (f (m a) -> m a) -> Free1 f a -> m a
forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 (f (m a) -> m a
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
M.wrap (f (m a) -> m a) -> (f a -> f (m a)) -> f a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m a) -> f a -> f (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) f (m a) -> m a
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 :: Free1 f x -> Free f x
toFree Free1 f x
x = (forall r. (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f x
forall (f :: * -> *) a.
(forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f a
Free ((forall r. (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free f x)
-> (forall r. (x -> r) -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free f x
forall a b. (a -> b) -> a -> b
$ \x -> r
p forall s. f s -> (s -> r) -> r
b -> Free1 f x
-> (forall s. f s -> (s -> x) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
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 -> f s -> (s -> r) -> r
forall s. f s -> (s -> r) -> r
b f s
y (x -> r
p (x -> r) -> (s -> x) -> s -> r
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 :: (f ~> g) -> Free1 f ~> Free1 g
hoistFree1 f ~> g
f Free1 f x
x = (forall r.
 (forall s. g s -> (s -> x) -> r)
 -> (forall s. g s -> (s -> r) -> r) -> r)
-> Free1 g 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 r.
  (forall s. g s -> (s -> x) -> r)
  -> (forall s. g s -> (s -> r) -> r) -> r)
 -> Free1 g x)
-> (forall r.
    (forall s. g s -> (s -> x) -> r)
    -> (forall s. g s -> (s -> r) -> r) -> r)
-> Free1 g x
forall a b. (a -> b) -> a -> b
$ \forall s. g s -> (s -> x) -> r
p forall s. g s -> (s -> r) -> r
b -> Free1 f x
-> (forall s. f s -> (s -> x) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
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 (g s -> (s -> x) -> r
forall s. g s -> (s -> x) -> r
p (g s -> (s -> x) -> r) -> (f s -> g s) -> f s -> (s -> x) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> g s
f ~> g
f) (g s -> (s -> r) -> r
forall s. g s -> (s -> r) -> r
b (g s -> (s -> r) -> r) -> (f s -> g s) -> f s -> (s -> r) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> g s
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 :: Free1 f x -> Comp f (Free f) x
free1Comp = (forall s. f s -> (s -> x) -> Comp f (Free f) x)
-> (forall s. f s -> (s -> Comp f (Free f) x) -> Comp f (Free f) x)
-> Free1 f x
-> Comp f (Free f) x
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 f s -> (s -> Free f x) -> Comp f (Free f) x
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (x -> Free f x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Free f x) -> (s -> x) -> s -> Free f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> x
c)) ((forall s. f s -> (s -> Comp f (Free f) x) -> Comp f (Free f) x)
 -> Free1 f x -> Comp f (Free f) x)
-> (forall s. f s -> (s -> Comp f (Free f) x) -> Comp f (Free f) x)
-> Free1 f x
-> Comp f (Free f) x
forall a b. (a -> b) -> a -> b
$ \f s
y s -> Comp f (Free f) x
n ->
    f s
y f s -> (s -> Free f x) -> Comp f (Free f) x
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
      q :>>= m -> f x -> Free f x
forall (f :: * -> *). f ~> Free f
liftFree f x
q Free f x -> (x -> Free f x) -> Free f x
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 :: f x -> Free1 f x
liftFree1 f x
x = (forall r.
 (forall s. f s -> (s -> x) -> r)
 -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f 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 r.
  (forall s. f s -> (s -> x) -> r)
  -> (forall s. f s -> (s -> r) -> r) -> r)
 -> Free1 f x)
-> (forall r.
    (forall s. f s -> (s -> x) -> r)
    -> (forall s. f s -> (s -> r) -> r) -> r)
-> Free1 f x
forall a b. (a -> b) -> a -> b
$ \forall s. f s -> (s -> x) -> r
p forall s. f s -> (s -> r) -> r
_ -> f x -> (x -> x) -> r
forall s. f s -> (s -> x) -> r
p f x
x 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 :: Free1 f ~> f
retractFree1 = (forall s. f s -> (s -> x) -> f x)
-> (forall s. f s -> (s -> f x) -> f x) -> Free1 f x -> f x
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 -> x) -> f x
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
(<&>) forall s. f s -> (s -> f x) -> f x
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 :: (f ~> g) -> Free1 f ~> g
interpretFree1 f ~> g
f = (forall s. f s -> (s -> x) -> g x)
-> (forall s. f s -> (s -> g x) -> g x) -> Free1 f x -> g x
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 (s -> x) -> g s -> g x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f s -> g s
f ~> g
f f s
y)
                              (\f s
y s -> g x
n -> f s -> g s
f ~> g
f f s
y g s -> (s -> g x) -> g x
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 :: Free1 f ~> (f :+: Comp f (Free1 f))
matchFree1 = (f x -> (:+:) f (Comp f (Free1 f)) x)
-> (f ((:+:) f (Comp f (Free1 f)) x)
    -> (:+:) f (Comp f (Free1 f)) x)
-> Free1 f x
-> (:+:) f (Comp f (Free1 f)) x
forall (f :: * -> *) a r.
Functor f =>
(f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 f x -> (:+:) f (Comp f (Free1 f)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Comp f (Free1 f) x -> (:+:) f (Comp f (Free1 f)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Comp f (Free1 f) x -> (:+:) f (Comp f (Free1 f)) x)
-> (f ((:+:) f (Comp f (Free1 f)) x) -> Comp f (Free1 f) x)
-> f ((:+:) f (Comp f (Free1 f)) x)
-> (:+:) f (Comp f (Free1 f)) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Free1 f x) -> Comp f (Free1 f) x
forall k (f :: * -> *) (g :: k -> *) (a :: k).
Functor f =>
f (g a) -> Comp f g a
Comp (f (Free1 f x) -> Comp f (Free1 f) x)
-> (f ((:+:) f (Comp f (Free1 f)) x) -> f (Free1 f x))
-> f ((:+:) f (Comp f (Free1 f)) x)
-> Comp f (Free1 f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((:+:) f (Comp f (Free1 f)) x -> Free1 f x)
-> f ((:+:) f (Comp f (Free1 f)) x) -> f (Free1 f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (:+:) f (Comp f (Free1 f)) x -> Free1 f x
(f :+: Comp f (Free1 f)) ~> Free1 f
shuffle)
  where
    shuffle :: f :+: Comp f (Free1 f) ~> Free1 f
    shuffle :: (:+:) f (Comp f (Free1 f)) x -> Free1 f x
shuffle (L1 f x
y         ) = f x -> Free1 f x
forall (f :: * -> *). f ~> Free1 f
liftFree1 f x
y
    shuffle (R1 (f x
y :>>= x -> Free1 f x
n)) = f x -> Free1 f x
forall (f :: * -> *). f ~> Free1 f
liftFree1 f x
y Free1 f x -> (x -> Free1 f x) -> Free1 f x
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 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 = Free1 f a
-> (forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
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 :: (Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C Coyoneda f a -> r
f Coyoneda f r -> r
g = (forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r) -> Free1 f a -> r
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 ((s -> a) -> f s -> Coyoneda f a
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 ((s -> r) -> f s -> Coyoneda f r
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 :: (f a -> r) -> (f r -> r) -> Free1 f a -> r
foldFree1 f a -> r
f f r -> r
g = (Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
forall (f :: * -> *) a r.
(Coyoneda f a -> r) -> (Coyoneda f r -> r) -> Free1 f a -> r
foldFree1C (f a -> r
f (f a -> r) -> (Coyoneda f a -> f a) -> Coyoneda f a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coyoneda f a -> f a
forall (f :: * -> *) a. Functor f => Coyoneda f a -> f a
lowerCoyoneda)
                           (f r -> r
g (f r -> r) -> (Coyoneda f r -> f r) -> Coyoneda f r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coyoneda f r -> f r
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 :: (a -> b) -> Comp f g a -> Comp f g b
fmap a -> b
f (f x
x :>>= x -> g a
h) = f x
x f x -> (x -> g b) -> Comp f g b
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= ((a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (g a -> g b) -> (x -> g a) -> x -> g b
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) <.> :: Comp f g (a -> b) -> Comp f g a -> Comp f g b
<.> (f x
y :>>= x -> g a
g) = ((,) (x -> x -> (x, x)) -> f x -> f (x -> (x, x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x f (x -> (x, x)) -> f x -> f (x, x)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f x
y)
                           f (x, x) -> ((x, x) -> g b) -> Comp f g b
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' g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> x -> g a
g x
y')
    liftF2 :: (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)
            = ((,) (x -> x -> (x, x)) -> f x -> f (x -> (x, x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x f (x -> (x, x)) -> f x -> f (x, x)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f x
y)
         f (x, x) -> ((x, x) -> g c) -> Comp f g c
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (\(x
x', x
y') -> (a -> b -> c) -> g a -> g b -> g c
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 :: a -> Comp f g a
pure a
x = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () f () -> (() -> g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> g a) -> (() -> a) -> () -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> () -> a
forall a b. a -> b -> a
const a
x)
    (f x
x :>>= x -> g (a -> b)
f) <*> :: Comp f g (a -> b) -> Comp f g a -> Comp f g b
<*> (f x
y :>>= x -> g a
g) = ((,) (x -> x -> (x, x)) -> f x -> f (x -> (x, x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x f (x -> (x, x)) -> f x -> f (x, x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f x
y)
                           f (x, x) -> ((x, x) -> g b) -> Comp f g b
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' g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> x -> g a
g x
y')
    liftA2 :: (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)
            = ((,) (x -> x -> (x, x)) -> f x -> f (x -> (x, x))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x f (x -> (x, x)) -> f x -> f (x, x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f x
y)
         f (x, x) -> ((x, x) -> g c) -> Comp f g c
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= (\(x
x', x
y') -> (a -> b -> c) -> g a -> g b -> g c
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 :: (a -> m) -> Comp f g a -> m
foldMap a -> m
f (f x
x :>>= x -> g a
h) = (x -> m) -> f x -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> g a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f (g a -> m) -> (x -> g a) -> x -> m
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 :: (a -> f b) -> Comp f g a -> f (Comp f g b)
traverse a -> f b
f (f x
x :>>= x -> g a
h) = (f (g b) -> (g b -> g b) -> Comp f g b
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= g b -> g b
forall a. a -> a
id)
                        (f (g b) -> Comp f g b) -> f (f (g b)) -> f (Comp f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (x -> f (g b)) -> f x -> f (f (g b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f (g a -> f (g b)) -> (x -> g a) -> x -> f (g b)
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 :: Comp f g a
empty = f (g a)
forall (f :: * -> *) a. Alternative f => f a
empty f (g a) -> (g a -> g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= g a -> g a
forall a. a -> a
id
    (f x
x :>>= x -> g a
f) <|> :: Comp f g a -> Comp f g a -> Comp f g a
<|> (f x
y :>>= x -> g a
g) = ((x -> g a
f (x -> g a) -> f x -> f (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x) f (g a) -> f (g a) -> f (g a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (x -> g a
g (x -> g a) -> f x -> f (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
y)) f (g a) -> (g a -> g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= g a -> 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) <!> :: Comp f g a -> Comp f g a -> Comp f g a
<!> (f x
y :>>= x -> g a
g) = ((x -> g a
f (x -> g a) -> f x -> f (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
x) f (g a) -> f (g a) -> f (g a)
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> (x -> g a
g (x -> g a) -> f x -> f (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
y)) f (g a) -> (g a -> g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= g a -> g a
forall a. a -> a
id

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

instance (Functor f, Show1 f, Show1 g) => Show1 (Comp f g) where
    liftShowsPrec :: (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) =
        (Int -> f (g a) -> ShowS) -> String -> Int -> f (g a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> g a -> ShowS)
-> ([g a] -> ShowS) -> Int -> f (g a) -> ShowS
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' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> g a -> ShowS
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' = (Int -> a -> ShowS) -> ([a] -> ShowS) -> [g a] -> ShowS
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 = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Comp f g a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList

instance (Functor f, Read1 f, Read1 g) => Read1 (Comp f g) where
    liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Comp f g a)
liftReadPrec ReadPrec a
rp ReadPrec [a]
rl = ReadPrec (Comp f g a) -> ReadPrec (Comp f g a)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Comp f g a) -> ReadPrec (Comp f g a))
-> ReadPrec (Comp f g a) -> ReadPrec (Comp f g a)
forall a b. (a -> b) -> a -> b
$
        ReadPrec (f (g a))
-> String -> (f (g a) -> Comp f g a) -> ReadPrec (Comp f g a)
forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith (ReadPrec (g a) -> ReadPrec [g a] -> ReadPrec (f (g a))
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec (g a)
rp' ReadPrec [g a]
rl') String
"Comp" f (g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k).
Functor f =>
f (g a) -> Comp f g a
Comp
      where
        rp' :: ReadPrec (g a)
rp' = ReadPrec a -> ReadPrec [a] -> ReadPrec (g a)
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec a
rp ReadPrec [a]
rl
        rl' :: ReadPrec [g a]
rl' = ReadPrec a -> ReadPrec [a] -> ReadPrec [g a]
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 = ReadPrec (Comp f g a)
forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
    readListPrec :: ReadPrec [Comp f g a]
readListPrec = ReadPrec [Comp f g a]
forall a. Read a => ReadPrec [a]
readListPrecDefault
    readList :: ReadS [Comp f g a]
readList = ReadS [Comp f g a]
forall a. Read a => ReadS [a]
readListDefault

instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Comp f g) where
    liftEq :: (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) = (g a -> g b -> Bool) -> f (g a) -> f (g b) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq ((a -> b -> Bool) -> g a -> g b -> Bool
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 :: (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) = (g a -> g b -> Ordering) -> f (g a) -> f (g b) -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare ((a -> b -> Ordering) -> g a -> g b -> Ordering
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
(==) = 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 = Comp f g a -> Comp f g a -> Ordering
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 :: f (g a) -> Comp f g a
comp = (f (g a) -> (g a -> g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= g a -> 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 :: 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) -> (Void# -> r) -> r
Comp { Comp f g a -> Functor f => f (g a)
unComp } <- ((\case x :>>= f -> f <$> x)->unComp)
  where
    Comp f (g a)
x = f (g a) -> Comp f g a
forall k (f :: * -> *) (g :: k -> *) (a :: k).
f (g a) -> Comp f g a
comp f (g a)
x
{-# COMPLETE Comp #-}