{-# 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 :: m (m a) -> m a
mact = m (m a) -> m a
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 :: (r -> f a) -> f a
mact r -> f a
f = r -> f a
f r
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 :: m (Const d a) -> Const d a
mact m (Const d a)
mca = d -> Const d a
forall k a (b :: k). a -> Const a b
Const (d -> Const d a) -> d -> Const d a
forall a b. (a -> b) -> a -> b
$ m d -> d
forall (m :: * -> *) a.
(FreeAlgebra m, AlgebraType m a) =>
m a -> a
foldFree (m d -> d) -> m d -> d
forall a b. (a -> b) -> a -> b
$ Const d a -> d
forall a k (b :: k). Const a b -> a
getConst (Const d a -> d) -> m (Const d a) -> m d
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 {
        FreeMAction m f a -> m (f a)
runFreeMAction :: m (f a)
    }
    deriving (Int -> FreeMAction m f a -> ShowS
[FreeMAction m f a] -> ShowS
FreeMAction m f a -> String
(Int -> FreeMAction m f a -> ShowS)
-> (FreeMAction m f a -> String)
-> ([FreeMAction m f a] -> ShowS)
-> Show (FreeMAction m f a)
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
(FreeMAction m f a -> FreeMAction m f a -> Bool)
-> (FreeMAction m f a -> FreeMAction m f a -> Bool)
-> Eq (FreeMAction m f a)
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, Eq (FreeMAction m f a)
Eq (FreeMAction m f a)
-> (FreeMAction m f a -> FreeMAction m f a -> Ordering)
-> (FreeMAction m f a -> FreeMAction m f a -> Bool)
-> (FreeMAction m f a -> FreeMAction m f a -> Bool)
-> (FreeMAction m f a -> FreeMAction m f a -> Bool)
-> (FreeMAction m f a -> FreeMAction m f a -> Bool)
-> (FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a)
-> (FreeMAction m f a -> FreeMAction m f a -> FreeMAction m f a)
-> Ord (FreeMAction m f a)
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
$cp1Ord :: forall (m :: * -> *) (f :: * -> *) a.
Ord (m (f a)) =>
Eq (FreeMAction m f a)
Ord, a -> FreeMAction m f b -> FreeMAction m f a
(a -> b) -> FreeMAction m f a -> FreeMAction m f b
(forall a b. (a -> b) -> FreeMAction m f a -> FreeMAction m f b)
-> (forall a b. a -> FreeMAction m f b -> FreeMAction m f a)
-> Functor (FreeMAction m f)
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
<$ :: 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 :: (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 :: a -> FreeMAction m f a
pure = m (f a) -> FreeMAction m f a
forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction (m (f a) -> FreeMAction m f a)
-> (a -> m (f a)) -> a -> FreeMAction m f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose m f a -> m (f a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose m f a -> m (f a)) -> (a -> Compose m f a) -> a -> m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Compose m f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    FreeMAction m (f (a -> b))
mfa <*> :: FreeMAction m f (a -> b) -> FreeMAction m f a -> FreeMAction m f b
<*> FreeMAction m (f a)
mfb =
        m (f b) -> FreeMAction m f b
forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction (m (f b) -> FreeMAction m f b) -> m (f b) -> FreeMAction m f b
forall a b. (a -> b) -> a -> b
$ Compose m f b -> m (f b)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose m f b -> m (f b)) -> Compose m f b -> m (f b)
forall a b. (a -> b) -> a -> b
$ m (f (a -> b)) -> Compose m f (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 Compose m f (a -> b) -> Compose m f a -> Compose m f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (f a) -> Compose m f a
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 :: m (FreeMAction m f a) -> FreeMAction m f a
mact m (FreeMAction m f a)
mfa = m (f a) -> FreeMAction m f a
forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction (m (f a) -> FreeMAction m f a) -> m (f a) -> FreeMAction m f a
forall a b. (a -> b) -> a -> b
$ m (FreeMAction m f a)
mfa m (FreeMAction m f a) -> (FreeMAction m f a -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FreeMAction m f a -> m (f a)
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 :: f a -> FreeMAction m f a
liftFree = m (f a) -> FreeMAction m f a
forall (m :: * -> *) (f :: * -> *) a. m (f a) -> FreeMAction m f a
FreeMAction (m (f a) -> FreeMAction m f a)
-> (f a -> m (f a)) -> f a -> FreeMAction m f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> m (f a)
forall (m :: * -> *) a. Monad m => a -> m a
return
    foldNatFree :: (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)
             = m (d a) -> d a
forall (m :: * -> *) (f :: * -> *) a. MAction m f => m (f a) -> f a
mact (m (d a) -> d a) -> m (d a) -> d a
forall a b. (a -> b) -> a -> b
$ f a -> d a
forall x. f x -> d x
nat (f a -> d a) -> m (f a) -> m (d a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (f a)
mfa