{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Control.Monad.Action where

import           Control.Monad (join)
import           Data.Functor.Const (Const (..))
import           Data.Functor.Compose (Compose (..))
import           Data.Kind (Type)

import           Control.Algebra.Free
                    ( AlgebraType0
                    , AlgebraType
                    , FreeAlgebra1 (..)
                    )
import           Data.Algebra.Pointed (Pointed (point))
import           Data.Algebra.Free (FreeAlgebra, foldFree)

-- | A /monad action/ is an `m`-algebra parametrized over a functor `f`.
-- This is direct translation of a /monoid action/ in the monoidal category of
-- endofunctors with monoidal product: functor composition.
--
-- @'mact'@ should be /associative/:
-- prop> 'mact' . 'mact' = 'mact' . 'join'
-- and /unital/:
-- prop> mact . return = id
--
-- There are monads which do not have any (safe) instances, like @'IO'@.
--
class (Monad m, Functor f) => MAction m f where
    mact :: m (f a) -> f a

instance Monad m => MAction m m where
    mact :: forall a. m (m a) -> m a
mact = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

-- | You can use @'PointedMonoid'@ newtype wrapper if you want to laverage
-- @'Pointed'@ instance for a @'Monoid'@.
--
instance (Pointed r, Functor f) => MAction ((->) r) f where
    mact :: forall a. (r -> f a) -> f a
mact r -> f a
f = r -> f a
f forall p. Pointed p => p
point

-- | Every algebra @d@ which satisfies the constraint @'AlgebraType' m d@ lifts
-- to an action on the constant functor @'Const' d@.  This is the same as to
-- say that @d@ is an @m@-algebra (as of /f-algebras/ in category theory).
--
instance ( Monad m
         , FreeAlgebra  m
         , AlgebraType  m d
         )
         => MAction m (Const d) where
    mact :: forall a. m (Const d a) -> Const d a
mact m (Const d a)
mca = forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(FreeAlgebra m, AlgebraType m a) =>
m a -> a
foldFree forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). Const a b -> a
getConst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Const d a)
mca

-- | Free algebra associated with the @'MAction' constraint.
--
newtype FreeMAction (m :: Type -> Type) (f :: Type -> Type) a =
    FreeMAction {
        forall (m :: * -> *) (f :: * -> *) a. FreeMAction m f a -> m (f a)
runFreeMAction :: m (f a)
    }
    deriving (Int -> FreeMAction m f a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) (f :: * -> *) a.
Show (m (f a)) =>
Int -> FreeMAction m f a -> ShowS
forall (m :: * -> *) (f :: * -> *) a.
Show (m (f a)) =>
[FreeMAction m f a] -> ShowS
forall (m :: * -> *) (f :: * -> *) a.
Show (m (f a)) =>
FreeMAction m f a -> String
showList :: [FreeMAction m f a] -> ShowS
$cshowList :: forall (m :: * -> *) (f :: * -> *) a.
Show (m (f a)) =>
[FreeMAction m f a] -> ShowS
show :: FreeMAction m f a -> String
$cshow :: forall (m :: * -> *) (f :: * -> *) a.
Show (m (f a)) =>
FreeMAction m f a -> String
showsPrec :: Int -> FreeMAction m f a -> ShowS
$cshowsPrec :: forall (m :: * -> *) (f :: * -> *) a.
Show (m (f a)) =>
Int -> FreeMAction m f a -> ShowS
Show, FreeMAction m f a -> FreeMAction m f a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *) (f :: * -> *) a.
Eq (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
/= :: FreeMAction m f a -> FreeMAction m f a -> Bool
$c/= :: forall (m :: * -> *) (f :: * -> *) a.
Eq (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
== :: FreeMAction m f a -> FreeMAction m f a -> Bool
$c== :: forall (m :: * -> *) (f :: * -> *) a.
Eq (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
Eq, FreeMAction m f a -> FreeMAction m f a -> Bool
FreeMAction m f a -> FreeMAction m f a -> Ordering
FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {m :: * -> *} {f :: * -> *} {a}.
Ord (m (f a)) =>
Eq (FreeMAction m f a)
forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Ordering
forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a
min :: FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a
$cmin :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a
max :: FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a
$cmax :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a
>= :: FreeMAction m f a -> FreeMAction m f a -> Bool
$c>= :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
> :: FreeMAction m f a -> FreeMAction m f a -> Bool
$c> :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
<= :: FreeMAction m f a -> FreeMAction m f a -> Bool
$c<= :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
< :: FreeMAction m f a -> FreeMAction m f a -> Bool
$c< :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Bool
compare :: FreeMAction m f a -> FreeMAction m f a -> Ordering
$ccompare :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
FreeMAction m f a -> FreeMAction m f a -> Ordering
Ord, forall a b. a -> FreeMAction m f b -> FreeMAction m f a
forall a b. (a -> b) -> FreeMAction m f a -> FreeMAction m f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) (f :: * -> *) a b.
(Functor m, Functor f) =>
a -> FreeMAction m f b -> FreeMAction m f a
forall (m :: * -> *) (f :: * -> *) a b.
(Functor m, Functor f) =>
(a -> b) -> FreeMAction m f a -> FreeMAction m f b
<$ :: forall a b. a -> FreeMAction m f b -> FreeMAction m f a
$c<$ :: forall (m :: * -> *) (f :: * -> *) a b.
(Functor m, Functor f) =>
a -> FreeMAction m f b -> FreeMAction m f a
fmap :: forall a b. (a -> b) -> FreeMAction m f a -> FreeMAction m f b
$cfmap :: forall (m :: * -> *) (f :: * -> *) a b.
(Functor m, Functor f) =>
(a -> b) -> FreeMAction m f a -> FreeMAction m f b
Functor)

instance (Applicative m, Applicative f) => Applicative (FreeMAction m f) where

    pure :: forall a. a -> FreeMAction m f a
pure = forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

    FreeMAction m (f (a -> b))
mfa <*> :: forall a b.
FreeMAction m f (a -> b) -> FreeMAction m f a -> FreeMAction m f b
<*> FreeMAction m (f a)
mfb =
        forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction forall a b. (a -> b) -> a -> b
$ forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall a b. (a -> b) -> a -> b
$ forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose m (f (a -> b))
mfa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose m (f a)
mfb


instance (Monad m, Functor f) => MAction m (FreeMAction m f) where

    mact :: forall a. m (FreeMAction m f a) -> FreeMAction m f a
mact m (FreeMAction m f a)
mfa = forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction forall a b. (a -> b) -> a -> b
$ m (FreeMAction m f a)
mfa forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (f :: * -> *) a. FreeMAction m f a -> m (f a)
runFreeMAction


type instance AlgebraType  (FreeMAction m) f = MAction m f
type instance AlgebraType0 (FreeMAction m) f = Functor f
instance Monad m => FreeAlgebra1 (FreeMAction m) where
    liftFree :: forall (f :: * -> *) a.
AlgebraType0 (FreeMAction m) f =>
f a -> FreeMAction m f a
liftFree = forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
    foldNatFree :: forall (d :: * -> *) (f :: * -> *) a.
(AlgebraType (FreeMAction m) d, AlgebraType0 (FreeMAction m) f) =>
(forall x. f x -> d x) -> FreeMAction m f a -> d a
foldNatFree forall x. f x -> d x
nat (FreeMAction m (f a)
mfa)
             = forall (m :: * -> *) (f :: * -> *) a. MAction m f => m (f a) -> f a
mact forall a b. (a -> b) -> a -> b
$ forall x. f x -> d x
nat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (f a)
mfa