{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingVia #-}

-- | Monads in the cateogory of @Functor@s.
module FMonad
  ( type (~>),
    -- * FMonad

    FMonad (..),
    fjoin,
    
    -- * FMonad laws

    -- ** Laws
    --
    -- $fmonad_laws_in_fbind
    
    -- ** Laws (in terms of @fjoin@)
    --
    -- $fmonad_laws_in_fjoin
    
    
    -- * Re-export
    FFunctor (..)
  )
where

import Control.Comonad (Comonad (..), (=>=))
import Control.Monad (join)

import qualified Control.Applicative.Free as FreeAp
import qualified Control.Applicative.Free.Final as FreeApFinal
import Control.Applicative.Lift
import qualified Control.Applicative.Trans.FreeAp as FreeApT
import qualified Control.Monad.Free as FreeM
import qualified Control.Monad.Free.Church as FreeMChurch
import Control.Monad.Trans.Free (FreeT)
import Control.Monad.Trans.Free.Extra ( inr, fbindFreeT_ )

import Control.Monad.Trans.Identity
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Data.Functor.Compose
import Data.Functor.Day
import Data.Functor.Day.Comonoid hiding (Comonad(..))
import Data.Functor.Day.Curried
import Data.Functor.Day.Extra (uncurried)
import Data.Functor.Flip1
import Data.Functor.Kan.Lan
import Data.Functor.Kan.Ran
import Data.Functor.Product
import Data.Functor.Sum
import FFunctor

import qualified Data.Bifunctor.Product as Bi
import qualified Data.Bifunctor.Product.Extra as Bi
import GHC.Generics
import Data.Kind (Type)


{- $fmonad_laws_in_fbind

Like 'Monad', there is a set of laws which every instance of 'FMonad' should satisfy.

[fpure is natural in g]

   Let @g, h@ be arbitrary @Functor@s. For any natural transformation @n :: g ~> h@,

   > ffmap n . fpure = fpure . n

[fbind is natural in g,h]

   Let @g, g', h, h'@ be arbitrary @Functor@s. For all natural transformations
   @k :: g ~> ff h@, @nat_g :: g' ~> g@, and @nat_h :: h ~> h'@, the following holds.

   > fbind (ffmap nat_h . k . nat_g) = ffmap nat_h . fbind k . ffmap nat_g

[Left unit]

   > fbind k . fpure = k

[Right unit]

   > fbind fpure = id

[Associativity]

   > fbind k . fbind j = fbind (fbind k . j)
-}

{- $fmonad_laws_in_fjoin

Alternatively, 'FMonad' laws can be stated using 'fjoin' instead. 

[fpure is natural in g]

   For all @Functor g@, @Functor h@, and @n :: g ~> h@,

   > ffmap n . fpure = fpure . n

[fjoin is natural in g]

   For all @Functor g@, @Functor h@, and @n :: g ~> h@,

   > ffmap n . fjoin = fjoin . ffmap (ffmap n)

[Left unit]

   > fjoin . fpure = id

[Right unit]

   > fjoin . ffmap fpure = id

[Associativity]

   > fjoin . fjoin = fjoin . ffmap fjoin

-}

{- | @FMonad@ is to 'FFunctor' what 'Monad' is to 'Functor'.


+----------------+-----------------------------+------------------------------------+
|                | @'Monad' m@                 | @'FMonad'   mm@                    |
+================+=============================+====================================+
| Superclass     | @'Functor' m@               | @'FFunctor' mm@                    |
+----------------+-----------------------------+------------------------------------+
| Features       | @                           | @                                  |
|                | return = pure               | fpure                              |
|                |   :: a -> m a               |    :: (Functor g)                  |
|                | @                           |    => g ~> mm g                    |
|                |                             | @                                  |
+----------------+-----------------------------+------------------------------------+
|                | @                           | @                                  |
|                | (=<<)                       | fbind                              |
|                |   :: (a -> m b)             |   :: (Functor g, Functor h)        |
|                |   -> (m a -> m b)           |   => (g ~> mm h)                   |
|                | @                           |   -> (mm g ~> mm h)                |
|                |                             | @                                  |
+----------------+-----------------------------+------------------------------------+



-} 
class FFunctor ff => FMonad ff where
  fpure :: (Functor g) => g ~> ff g
  fbind :: (Functor g, Functor h) => (g ~> ff h) -> ff g a -> ff h a

-- | 'join' but for 'FMonad' instead of 'Monad'.
fjoin :: (FMonad ff, Functor g) => ff (ff g) ~> ff g
fjoin :: forall (ff :: FF) (g :: * -> *).
(FMonad ff, Functor g) =>
ff (ff g) ~> ff g
fjoin = (ff g ~> ff g) -> ff (ff g) x -> ff g x
forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> ff h) -> ff g a -> ff h a
forall (ff :: FF) (g :: * -> *) (h :: * -> *) a.
(FMonad ff, Functor g, Functor h) =>
(g ~> ff h) -> ff g a -> ff h a
fbind ff g x -> ff g x
forall a. a -> a
ff g ~> ff g
id

instance Functor f => FMonad (Sum f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> Sum f g
fpure = g x -> Sum f g x
forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR

  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Sum f h) -> Sum f g a -> Sum f h a
fbind g ~> Sum f h
_ (InL f a
fa) = f a -> Sum f h a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL f a
fa
  fbind g ~> Sum f h
k (InR g a
ga) = g a -> Sum f h a
g ~> Sum f h
k g a
ga

instance (Functor f, forall a. Monoid (f a)) => FMonad (Product f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> Product f g
fpure = f x -> g x -> Product f g x
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f x
forall a. Monoid a => a
mempty
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Product f h) -> Product f g a -> Product f h a
fbind g ~> Product f h
k (Pair f a
fa1 g a
ga) = case g a -> Product f h a
g ~> Product f h
k g a
ga of
    (Pair f a
fa2 h a
ha) -> f a -> h a -> Product f h a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a
fa1 f a -> f a -> f a
forall a. Semigroup a => a -> a -> a
<> f a
fa2) h a
ha

instance Monad f => FMonad (Compose f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> Compose f g
fpure = f (g x) -> Compose f g x
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f (g x) -> Compose f g x)
-> (g x -> f (g x)) -> g x -> Compose f g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> f (g x)
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Compose f h) -> Compose f g a -> Compose f h a
fbind g ~> Compose f h
k = f (h a) -> Compose f h a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f (h a) -> Compose f h a)
-> (Compose f g a -> f (h a)) -> Compose f g a -> Compose f h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (g a) -> (g a -> f (h a)) -> f (h a)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Compose f h a -> f (h a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose f h a -> f (h a))
-> (g a -> Compose f h a) -> g a -> f (h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> Compose f h a
g ~> Compose f h
k)) (f (g a) -> f (h a))
-> (Compose f g a -> f (g a)) -> Compose f g a -> f (h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose f g a -> f (g a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

instance Functor f => FMonad ((:+:) f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> (f :+: g)
fpure = g x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> (f :+: h)) -> (:+:) f g a -> (:+:) f h a
fbind g ~> (f :+: h)
k (:+:) f g a
ff = case (:+:) f g a
ff of
    L1 f a
fx -> f a -> (:+:) f h a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f a
fx
    R1 g a
gx -> g a -> (:+:) f h a
g ~> (f :+: h)
k g a
gx

instance (Functor f, forall a. Monoid (f a)) => FMonad ((:*:) f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> (f :*: g)
fpure = (f x
forall a. Monoid a => a
mempty f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:)
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> (f :*: h)) -> (:*:) f g a -> (:*:) f h a
fbind g ~> (f :*: h)
k (f a
fa :*: g a
ga) = case g a -> (:*:) f h a
g ~> (f :*: h)
k g a
ga of
    f a
fa' :*: h a
ha -> (f a
fa f a -> f a -> f a
forall a. Semigroup a => a -> a -> a
<> f a
fa') f a -> h a -> (:*:) f h a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: h a
ha

deriving
  via (Compose (f :: Type -> Type))
  instance Monad f => FMonad ((:.:) f)

deriving
  via IdentityT
  instance FMonad (M1 c m) 

deriving
  via IdentityT
  instance FMonad Rec1

instance FMonad Lift where
  fpure :: forall (g :: * -> *). Functor g => g ~> Lift g
fpure = g x -> Lift g x
forall (f :: * -> *) a. f a -> Lift f a
Other
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Lift h) -> Lift g a -> Lift h a
fbind g ~> Lift h
_ (Pure a
a)   = a -> Lift h a
forall (f :: * -> *) a. a -> Lift f a
Pure a
a
  fbind g ~> Lift h
k (Other g a
ga) = g a -> Lift h a
g ~> Lift h
k g a
ga

instance FMonad FreeM.Free where
  fpure :: forall (g :: * -> *). Functor g => g ~> Free g
fpure = g x -> Free g x
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
FreeM.liftF
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Free h) -> Free g a -> Free h a
fbind = (forall x. g x -> Free h x) -> Free g a -> Free h a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> Free f a -> m a
FreeM.foldFree

instance FMonad FreeMChurch.F where
  fpure :: forall (g :: * -> *). Functor g => g ~> F g
fpure = g x -> F g x
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
FreeMChurch.liftF
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> F h) -> F g a -> F h a
fbind = (forall x. g x -> F h x) -> F g a -> F h a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> F f a -> m a
FreeMChurch.foldF

instance FMonad FreeAp.Ap where
  fpure :: forall (g :: * -> *). Functor g => g ~> Ap g
fpure = g x -> Ap g x
forall (f :: * -> *) a. f a -> Ap f a
FreeAp.liftAp
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Ap h) -> Ap g a -> Ap h a
fbind = (forall x. g x -> Ap h x) -> Ap g a -> Ap h a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
FreeAp.runAp

instance FMonad FreeApFinal.Ap where
  fpure :: forall (g :: * -> *). Functor g => g ~> Ap g
fpure = g x -> Ap g x
forall (f :: * -> *) a. f a -> Ap f a
FreeApFinal.liftAp
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Ap h) -> Ap g a -> Ap h a
fbind = (forall x. g x -> Ap h x) -> Ap g a -> Ap h a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
FreeApFinal.runAp

instance FMonad IdentityT where
  fpure :: forall (g :: * -> *). Functor g => g ~> IdentityT g
fpure = g x -> IdentityT g x
forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> IdentityT h) -> IdentityT g a -> IdentityT h a
fbind g ~> IdentityT h
k = g a -> IdentityT h a
g ~> IdentityT h
k (g a -> IdentityT h a)
-> (IdentityT g a -> g a) -> IdentityT g a -> IdentityT h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT g a -> g a
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT

instance FMonad (ReaderT e) where
  -- See the similarity between 'Compose' @((->) e)@

  -- return :: x -> (e -> x)
  fpure :: forall (g :: * -> *). Functor g => g ~> ReaderT e g
fpure = (e -> g x) -> ReaderT e g x
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((e -> g x) -> ReaderT e g x)
-> (g x -> e -> g x) -> g x -> ReaderT e g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> e -> g x
forall a. a -> e -> a
forall (m :: * -> *) a. Monad m => a -> m a
return

  -- join :: (e -> e -> x) -> (e -> x)
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> ReaderT e h) -> ReaderT e g a -> ReaderT e h a
fbind g ~> ReaderT e h
k = (e -> h a) -> ReaderT e h a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((e -> h a) -> ReaderT e h a)
-> (ReaderT e g a -> e -> h a) -> ReaderT e g a -> ReaderT e h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((e -> g a) -> (g a -> e -> h a) -> e -> h a
forall a b. (e -> a) -> (a -> e -> b) -> e -> b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT e h a -> e -> h a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT e h a -> e -> h a)
-> (g a -> ReaderT e h a) -> g a -> e -> h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> ReaderT e h a
g ~> ReaderT e h
k) ((e -> g a) -> e -> h a)
-> (ReaderT e g a -> e -> g a) -> ReaderT e g a -> e -> h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT e g a -> e -> g a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

instance Monoid m => FMonad (WriterT m) where
  -- See the similarity between 'FlipCompose' @(Writer m)@

  -- fmap return :: f x -> f (Writer m x)
  fpure :: forall (g :: * -> *). Functor g => g ~> WriterT m g
fpure = g (x, m) -> WriterT m g x
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (g (x, m) -> WriterT m g x)
-> (g x -> g (x, m)) -> g x -> WriterT m g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> (x, m)) -> g x -> g (x, m)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,m
forall a. Monoid a => a
mempty)

  -- fmap join :: f (Writer m (Writer m x)) -> f (Writer m x)
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> WriterT m h) -> WriterT m g a -> WriterT m h a
fbind g ~> WriterT m h
k = h (a, m) -> WriterT m h a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (h (a, m) -> WriterT m h a)
-> (WriterT m g a -> h (a, m)) -> WriterT m g a -> WriterT m h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a, m), m) -> (a, m)) -> h ((a, m), m) -> h (a, m)
forall a b. (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((a
x, m
m1), m
m2) -> (a
x, m
m2 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
m1)) (h ((a, m), m) -> h (a, m))
-> (WriterT m g a -> h ((a, m), m)) -> WriterT m g a -> h (a, m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT m h (a, m) -> h ((a, m), m)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT m h (a, m) -> h ((a, m), m))
-> (WriterT m g a -> WriterT m h (a, m))
-> WriterT m g a
-> h ((a, m), m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT m (WriterT m h) a -> WriterT m h (a, m)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT m (WriterT m h) a -> WriterT m h (a, m))
-> (WriterT m g a -> WriterT m (WriterT m h) a)
-> WriterT m g a
-> WriterT m h (a, m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> WriterT m h) -> WriterT m g a -> WriterT m (WriterT m h) a
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> WriterT m g x -> WriterT m h x
forall (ff :: FF) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap g x -> WriterT m h x
g ~> WriterT m h
k

{-

If everything is unwrapped, FMonad @(StateT s)@ is

  fpure :: forall f. Functor f => f x -> s -> f (x, s)
  fjoin :: forall f. Functor f => (s -> s -> f ((x, s), s)) -> s -> f (x, s)

And if this type was generic in @s@ without any constraint like @Monoid s@,
the only possible implementations are

  -- fpure is uniquely:
  fpure fx s = (,s) <$> fx

  -- fjoin is one of the following three candidates
  fjoin1 stst s = (\((x,_),_) -> (x,s)) <$> stst s s
  fjoin2 stst s = (\((x,_),s) -> (x,s)) <$> stst s s
  fjoin3 stst s = (\((x,s),_) -> (x,s)) <$> stst s s

But none of them satisfy the FMonad law.

  (fjoin1 . fpure) st
    = fjoin1 $ \s1 s2 -> (,s1) <$> st s2
    = \s -> (\((x,_),_) -> (x,s)) <$> ((,s) <$> st s)
    = \s -> (\(x,_) -> (x,s)) <$> st s
    /= st
  (fjoin2 . fpure) st
    = fjoin2 $ \s1 s2 -> (,s1) <$> st s2
    = \s -> (\((x,_),s') -> (x,s')) <$> ((,s) <$> st s)
    = \s -> (\(x,_) -> (x,s)) <$> st s
    /= st
  (fjoin3 . ffmap fpure) st
    = fjoin2 $ \s1 s2 -> fmap (fmap (,s2)) . st s1
    = \s -> ((\((x,s'),_) -> (x,s')) . fmap (,s)) <$> st s
    = \s -> (\(x,_) -> (x,s)) <$> st s
    /= st

So the lawful @FMonad (StateT s)@ will utilize some structure
on @s@.

One way would be seeing StateT as the composision of Reader s and
Writer s:

  StateT s m ~ Reader s ∘ m ∘ Writer s
    where (∘) = Compose

By this way

  StateT s (StateT s m) ~ Reader s ∘ Reader s ∘ m ∘ Writer s ∘ Writer s

And you can collapse the nesting by applying @join@ for @Reader s ∘ Reader s@
and @Writer s ∘ Writer s@. To do so, it will need @Monoid s@ for @Monad (Writer s)@.

-}

instance Monoid s => FMonad (StateT s) where
  -- Note that this is different to @lift@ in 'MonadTrans',
  -- whilst having similar type and actually equal in
  -- several other 'FMonad' instances.
  --
  -- See the discussion below.
  fpure :: forall (g :: * -> *). Functor g => g ~> StateT s g
fpure g x
fa = (s -> g (x, s)) -> StateT s g x
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> g (x, s)) -> StateT s g x)
-> (s -> g (x, s)) -> StateT s g x
forall a b. (a -> b) -> a -> b
$ \s
_ -> (,s
forall a. Monoid a => a
mempty) (x -> (x, s)) -> g x -> g (x, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g x
fa

  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> StateT s h) -> StateT s g a -> StateT s h a
fbind g ~> StateT s h
k = (s -> h (a, s)) -> StateT s h a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> h (a, s)) -> StateT s h a)
-> (StateT s g a -> s -> h (a, s)) -> StateT s g a -> StateT s h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> h ((a, s), s)) -> s -> h (a, s)
forall (f :: * -> *) a.
Functor f =>
(s -> s -> f ((a, s), s)) -> s -> f (a, s)
fjoin_ ((s -> s -> h ((a, s), s)) -> s -> h (a, s))
-> (StateT s g a -> s -> s -> h ((a, s), s))
-> StateT s g a
-> s
-> h (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT s h (a, s) -> s -> h ((a, s), s))
-> (s -> StateT s h (a, s)) -> s -> s -> h ((a, s), s)
forall a b. (a -> b) -> (s -> a) -> s -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StateT s h (a, s) -> s -> h ((a, s), s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((s -> StateT s h (a, s)) -> s -> s -> h ((a, s), s))
-> (StateT s g a -> s -> StateT s h (a, s))
-> StateT s g a
-> s
-> s
-> h ((a, s), s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT s (StateT s h) a -> s -> StateT s h (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (StateT s (StateT s h) a -> s -> StateT s h (a, s))
-> (StateT s g a -> StateT s (StateT s h) a)
-> StateT s g a
-> s
-> StateT s h (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> StateT s h) -> StateT s g a -> StateT s (StateT s h) a
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> StateT s g x -> StateT s h x
forall (ff :: FF) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap g x -> StateT s h x
g ~> StateT s h
k
    where
      fjoin_ :: forall f a. (Functor f) => (s -> s -> f ((a, s), s)) -> s -> f (a, s)
      fjoin_ :: forall (f :: * -> *) a.
Functor f =>
(s -> s -> f ((a, s), s)) -> s -> f (a, s)
fjoin_ = (f ((a, s), s) -> f (a, s))
-> (s -> f ((a, s), s)) -> s -> f (a, s)
forall a b. (a -> b) -> (s -> a) -> s -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((((a, s), s) -> (a, s)) -> f ((a, s), s) -> f (a, s)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, s), s) -> (a, s)
forall x. ((x, s), s) -> (x, s)
joinWriter) ((s -> f ((a, s), s)) -> s -> f (a, s))
-> ((s -> s -> f ((a, s), s)) -> s -> f ((a, s), s))
-> (s -> s -> f ((a, s), s))
-> s
-> f (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s -> f ((a, s), s)) -> s -> f ((a, s), s)
forall x. (s -> s -> x) -> s -> x
joinReader
        where
          joinReader :: forall x. (s -> s -> x) -> s -> x
          joinReader :: forall x. (s -> s -> x) -> s -> x
joinReader = (s -> s -> x) -> s -> x
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

          joinWriter :: forall x. ((x, s), s) -> (x, s)
          joinWriter :: forall x. ((x, s), s) -> (x, s)
joinWriter ((x
a, s
s1), s
s2) = (x
a, s
s2 s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
s1)

{-

Note [About FMonad (StateT s) instance]

@fpure@ has a similar (Functor instead of Monad) type signature
with 'lift', but due to the different laws expected on them,
they aren't necessarily same.

@lift@ for @StateT s@ must be, by the 'MonadTrans' laws,
the one currently used. And this is not because the parameter @s@
is generic, so it applies if we have @Monoid s =>@ constraints like
the above instance.

One way to have @lift = fpure@ here is requiring @s@ to be a type with
group operations, @Monoid@ + @inv@ for inverse operator,
instead of just being a monoid.

> fpure fa = StateT $ \s -> (,s) <$> fa
> fjoin = StateT . fjoin_ . fmap runStateT . runStateT
>   where fjoin_ mma s = fmap (fmap (joinGroup s)) $ joinReader mma s
>         joinReader = join
>         joinGroup s ((x,s1),s2) = (x, s2 <> inv s <> s1)

-}

-- | @Ran w (Ran w f) ~ Ran ('Compose' w w) f@
instance (Comonad w) => FMonad (Ran w) where
  fpure ::
    forall f x.
    (Functor f) =>
    f x ->
    Ran w f x
  --       f x -> (forall b. (x -> w b) -> f b)
  fpure :: forall (f :: * -> *) x. Functor f => f x -> Ran w f x
fpure f x
f = (forall b. (x -> w b) -> f b) -> Ran w f x
forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran ((forall b. (x -> w b) -> f b) -> Ran w f x)
-> (forall b. (x -> w b) -> f b) -> Ran w f x
forall a b. (a -> b) -> a -> b
$ \x -> w b
k -> (x -> b) -> f x -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w b -> b
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract (w b -> b) -> (x -> w b) -> x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> w b
k) f x
f

  fbind :: (Functor g, Functor h) =>
     (g ~> Ran w h) -> (Ran w g ~> Ran w h)
  fbind :: forall (g :: * -> *) (h :: * -> *).
(Functor g, Functor h) =>
(g ~> Ran w h) -> Ran w g ~> Ran w h
fbind g ~> Ran w h
k Ran w g x
wg = (forall b. (x -> w b) -> h b) -> Ran w h x
forall {k} (g :: k -> *) (h :: k -> *) a.
(forall (b :: k). (a -> g b) -> h b) -> Ran g h a
Ran ((forall b. (x -> w b) -> h b) -> Ran w h x)
-> (forall b. (x -> w b) -> h b) -> Ran w h x
forall a b. (a -> b) -> a -> b
$ \x -> w b
xd -> Ran w h (w b) -> forall b. (w b -> w b) -> h b
forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan (g (w b) -> Ran w h (w b)
g ~> Ran w h
k (Ran w g x -> forall b. (x -> w b) -> g b
forall {k} (g :: k -> *) (h :: k -> *) a.
Ran g h a -> forall (b :: k). (a -> g b) -> h b
runRan Ran w g x
wg (w b -> w (w b)
forall a. w a -> w (w a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate (w b -> w (w b)) -> (x -> w b) -> x -> w (w b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> w b
xd))) w b -> w b
forall a. a -> a
id

-- | @Lan w (Lan w f) ~ Lan ('Compose' w w) f@
instance (Comonad w) => FMonad (Lan w) where
  fpure ::
    forall f x.
    (Functor f) =>
    f x ->
    Lan w f x
  --       f x -> exists b. (w b -> x, f b)
  fpure :: forall (f :: * -> *) x. Functor f => f x -> Lan w f x
fpure f x
f = (w x -> x) -> f x -> Lan w f x
forall {k} (g :: k -> *) (b :: k) a (h :: k -> *).
(g b -> a) -> h b -> Lan g h a
Lan w x -> x
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f x
f
  
  fbind :: (Functor g, Functor h) =>
    (g ~> Lan w h) -> (Lan w g ~> Lan w h)
  fbind :: forall (g :: * -> *) (h :: * -> *).
(Functor g, Functor h) =>
(g ~> Lan w h) -> Lan w g ~> Lan w h
fbind g ~> Lan w h
k (Lan w b -> x
j1 g b
g) = case g b -> Lan w h b
g ~> Lan w h
k g b
g of
    Lan w b -> b
j2 h b
h -> (w b -> x) -> h b -> Lan w h x
forall {k} (g :: k -> *) (b :: k) a (h :: k -> *).
(g b -> a) -> h b -> Lan g h a
Lan (w b -> b
j2 (w b -> b) -> (w b -> x) -> w b -> x
forall (w :: * -> *) a b c.
Comonad w =>
(w a -> b) -> (w b -> c) -> w a -> c
=>= w b -> x
j1) h b
h

instance (Applicative f) => FMonad (Day f) where
  fpure :: g ~> Day f g
  fpure :: forall (g :: * -> *) x. g x -> Day f g x
fpure = f (x -> x) -> g x -> Day f g x
forall (f :: * -> *) a b (g :: * -> *).
f (a -> b) -> g a -> Day f g b
day ((x -> x) -> f (x -> x)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> x
forall a. a -> a
id)

  {-
     day :: f (a -> b) -> g a -> Day f g b
  -}
  
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Day f h) -> Day f g a -> Day f h a
fbind g ~> Day f h
k = (forall x. Day f f x -> f x) -> Day (Day f f) h a -> Day f h a
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a.
(forall x. f x -> g x) -> Day f h a -> Day g h a
trans1 Day f f x -> f x
forall x. Day f f x -> f x
forall (f :: * -> *) a. Applicative f => Day f f a -> f a
dap (Day (Day f f) h a -> Day f h a)
-> (Day f g a -> Day (Day f f) h a) -> Day f g a -> Day f h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day f (Day f h) a -> Day (Day f f) h a
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a.
Day f (Day g h) a -> Day (Day f g) h a
assoc (Day f (Day f h) a -> Day (Day f f) h a)
-> (Day f g a -> Day f (Day f h) a)
-> Day f g a
-> Day (Day f f) h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> Day f h) -> Day f g a -> Day f (Day f h) a
forall (g :: * -> *) (h :: * -> *) (f :: * -> *) a.
(forall x. g x -> h x) -> Day f g a -> Day f h a
trans2 g x -> Day f h x
g ~> Day f h
k

{-
   trans2 k   :: Day f g ~> Day f (Day f h)
   assoc      ::            Day f (Day f h) ~> Day (Day f f) h
   trans1 dap ::                               Day (Day f f) h ~> Day f h
-}

instance Comonoid f => FMonad (Curried f) where
  fpure :: Functor g => g a -> Curried f g a
  fpure :: forall (g :: * -> *) a. Functor g => g a -> Curried f g a
fpure g a
g = (forall r. f (a -> r) -> g r) -> Curried f g a
forall (g :: * -> *) (h :: * -> *) a.
(forall r. g (a -> r) -> h r) -> Curried g h a
Curried ((forall r. f (a -> r) -> g r) -> Curried f g a)
-> (forall r. f (a -> r) -> g r) -> Curried f g a
forall a b. (a -> b) -> a -> b
$ \f (a -> r)
f -> f (a -> r) -> a -> r
forall a. f a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f (a -> r)
f (a -> r) -> g a -> g r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g a
g

  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Curried f h) -> Curried f g a -> Curried f h a
fbind g ~> Curried f h
k Curried f g a
m = (forall r. f (a -> r) -> h r) -> Curried f h a
forall (g :: * -> *) (h :: * -> *) a.
(forall r. g (a -> r) -> h r) -> Curried g h a
Curried ((forall r. f (a -> r) -> h r) -> Curried f h a)
-> (forall r. f (a -> r) -> h r) -> Curried f h a
forall a b. (a -> b) -> a -> b
$ \f (a -> r)
f -> Curried (Day f f) h a -> forall r. Day f f (a -> r) -> h r
forall (g :: * -> *) (h :: * -> *) a.
Curried g h a -> forall r. g (a -> r) -> h r
runCurried (Curried f (Curried f h) a -> Curried (Day f f) h a
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) c.
(Functor f, Functor g) =>
Curried f (Curried g h) c -> Curried (Day f g) h c
uncurried ((g ~> Curried f h) -> Curried f g a -> Curried f (Curried f h) a
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> Curried f g x -> Curried f h x
forall (ff :: FF) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap g x -> Curried f h x
g ~> Curried f h
k Curried f g a
m)) (f (a -> r) -> Day f f (a -> r)
forall a. f a -> Day f f a
forall (f :: * -> *) a. Comonoid f => f a -> Day f f a
coapply f (a -> r)
f)

instance FMonad (FreeApT.ApT f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> ApT f g
fpure = g x -> ApT f g x
forall (g :: * -> *) x (f :: * -> *). g x -> ApT f g x
FreeApT.liftT
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> ApT f h) -> ApT f g a -> ApT f h a
fbind g ~> ApT f h
k = ApT f (ApT f h) a -> ApT f h a
forall (f :: * -> *) (g :: * -> *) x.
ApT f (ApT f g) x -> ApT f g x
FreeApT.fjoinApTLeft (ApT f (ApT f h) a -> ApT f h a)
-> (ApT f g a -> ApT f (ApT f h) a) -> ApT f g a -> ApT f h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> ApT f h) -> ApT f g a -> ApT f (ApT f h) a
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ApT f g x -> ApT f h x
forall (ff :: FF) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap g x -> ApT f h x
g ~> ApT f h
k

instance Applicative g => FMonad (Flip1 FreeApT.ApT g) where
  fpure :: forall (g :: * -> *). Functor g => g ~> Flip1 ApT g g
fpure = ApT g g x -> Flip1 ApT g g x
forall k1 k2 k3 (t :: k1 -> k2 -> k3 -> *) (a :: k2) (b :: k1)
       (c :: k3).
t b a c -> Flip1 t a b c
Flip1 (ApT g g x -> Flip1 ApT g g x)
-> (g x -> ApT g g x) -> g x -> Flip1 ApT g g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> ApT g g x
forall (g :: * -> *) (f :: * -> *) x.
Applicative g =>
f x -> ApT f g x
FreeApT.liftF
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Flip1 ApT g h) -> Flip1 ApT g g a -> Flip1 ApT g h a
fbind g ~> Flip1 ApT g h
k = ApT h g a -> Flip1 ApT g h a
forall k1 k2 k3 (t :: k1 -> k2 -> k3 -> *) (a :: k2) (b :: k1)
       (c :: k3).
t b a c -> Flip1 t a b c
Flip1 (ApT h g a -> Flip1 ApT g h a)
-> (Flip1 ApT g g a -> ApT h g a)
-> Flip1 ApT g g a
-> Flip1 ApT g h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. g a -> ApT h g a)
-> (forall a. g a -> ApT h g a) -> ApT g g a -> ApT h g a
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) x.
Applicative h =>
(forall a. f a -> h a)
-> (forall a. g a -> h a) -> ApT f g x -> h x
FreeApT.foldApT (Flip1 ApT g h a -> ApT h g a
forall k1 k2 k3 (t :: k1 -> k2 -> k3 -> *) (a :: k2) (b :: k1)
       (c :: k3).
Flip1 t a b c -> t b a c
unFlip1 (Flip1 ApT g h a -> ApT h g a)
-> (g a -> Flip1 ApT g h a) -> g a -> ApT h g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> Flip1 ApT g h a
g ~> Flip1 ApT g h
k) g a -> ApT h g a
forall a. g a -> ApT h g a
forall (g :: * -> *) x (f :: * -> *). g x -> ApT f g x
FreeApT.liftT (ApT g g a -> ApT h g a)
-> (Flip1 ApT g g a -> ApT g g a) -> Flip1 ApT g g a -> ApT h g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip1 ApT g g a -> ApT g g a
forall k1 k2 k3 (t :: k1 -> k2 -> k3 -> *) (a :: k2) (b :: k1)
       (c :: k3).
Flip1 t a b c -> t b a c
unFlip1

instance Functor f => FMonad (FreeT f) where
  fpure :: forall (g :: * -> *). Functor g => g ~> FreeT f g
fpure = g x -> FreeT f g x
g ~> FreeT f g
forall (m :: * -> *) (f :: * -> *). Functor m => m ~> FreeT f m
inr
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> FreeT f h) -> FreeT f g a -> FreeT f h a
fbind = (g ~> FreeT f h) -> FreeT f g a -> FreeT f h a
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) a.
(Functor f, Functor m, Functor n) =>
(m ~> FreeT f n) -> FreeT f m a -> FreeT f n a
fbindFreeT_

instance (FMonad ff, FMonad gg) => FMonad (Bi.Product ff gg) where
  fpure :: forall (g :: * -> *). Functor g => g ~> Product ff gg g
fpure g x
h = ff g x -> gg g x -> Product ff gg g x
forall {k} {k1} (f :: k -> k1 -> *) (g :: k -> k1 -> *) (a :: k)
       (b :: k1).
f a b -> g a b -> Product f g a b
Bi.Pair (g x -> ff g x
g ~> ff g
forall (g :: * -> *). Functor g => g ~> ff g
forall (ff :: FF) (g :: * -> *).
(FMonad ff, Functor g) =>
g ~> ff g
fpure g x
h) (g x -> gg g x
g ~> gg g
forall (g :: * -> *). Functor g => g ~> gg g
forall (ff :: FF) (g :: * -> *).
(FMonad ff, Functor g) =>
g ~> ff g
fpure g x
h)
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> Product ff gg h) -> Product ff gg g a -> Product ff gg h a
fbind g ~> Product ff gg h
k (Bi.Pair ff g a
ff gg g a
gg) = ff h a -> gg h a -> Product ff gg h a
forall {k} {k1} (f :: k -> k1 -> *) (g :: k -> k1 -> *) (a :: k)
       (b :: k1).
f a b -> g a b -> Product f g a b
Bi.Pair ((g ~> ff h) -> ff g a -> ff h a
forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> ff h) -> ff g a -> ff h a
forall (ff :: FF) (g :: * -> *) (h :: * -> *) a.
(FMonad ff, Functor g, Functor h) =>
(g ~> ff h) -> ff g a -> ff h a
fbind (Product ff gg h x -> ff h x
forall {k} {k1} (p :: k -> k1 -> *) (q :: k -> k1 -> *) (a :: k)
       (b :: k1).
Product p q a b -> p a b
Bi.proj1 (Product ff gg h x -> ff h x)
-> (g x -> Product ff gg h x) -> g x -> ff h x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> Product ff gg h x
g ~> Product ff gg h
k) ff g a
ff) ((g ~> gg h) -> gg g a -> gg h a
forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> gg h) -> gg g a -> gg h a
forall (ff :: FF) (g :: * -> *) (h :: * -> *) a.
(FMonad ff, Functor g, Functor h) =>
(g ~> ff h) -> ff g a -> ff h a
fbind (Product ff gg h x -> gg h x
forall {k} {k1} (p :: k -> k1 -> *) (q :: k -> k1 -> *) (a :: k)
       (b :: k1).
Product p q a b -> q a b
Bi.proj2 (Product ff gg h x -> gg h x)
-> (g x -> Product ff gg h x) -> g x -> gg h x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> Product ff gg h x
g ~> Product ff gg h
k) gg g a
gg)