{-# LANGUAGE UndecidableInstances #-}

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
    Copyright : (c) 2023 Yamada Ryo
                (c) 2023 Casper Bach Poulsen and Cas van der Rest
    License : MPL-2.0 (see the file LICENSE)

    Maintainer : ymdfield@outlook.jp
    Stability : experimental
    Portability : portable

    The data structure of hefty trees.
-}
module Control.Monad.Trans.Hefty where

import Control.Monad (ap)
import Control.Monad.Identity (Identity (Identity), runIdentity)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Trans.Free (FreeF (Free, Pure))
import Data.Functor ((<&>))

-- | A hefty monad transformer.
newtype HeftyT h m a = HeftyT {forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
HeftyT h m a -> m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
runHeftyT :: m (FreeF (h (HeftyT h m)) a (HeftyT h m a))}

instance (Functor m, Functor (h (HeftyT h m))) => Functor (HeftyT h m) where
    fmap :: forall a b. (a -> b) -> HeftyT h m a -> HeftyT h m b
fmap a -> b
f (HeftyT m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
m) =
        forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
m (FreeF (h (HeftyT h m)) a (HeftyT h m a)) -> HeftyT h m a
HeftyT forall a b. (a -> b) -> a -> b
$
            m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
m forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                Pure a
x -> forall (f :: * -> *) a b. a -> FreeF f a b
Pure forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
                Free h (HeftyT h m) (HeftyT h m a)
h -> forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h (HeftyT h m) (HeftyT h m a)
h

instance (Monad m, Functor (h (HeftyT h m))) => Applicative (HeftyT h m) where
    pure :: forall a. a -> HeftyT h m a
pure = forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
m (FreeF (h (HeftyT h m)) a (HeftyT h m a)) -> HeftyT h m a
HeftyT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. a -> FreeF f a b
Pure
    <*> :: forall a b. HeftyT h m (a -> b) -> HeftyT h m a -> HeftyT h m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

    {-# INLINE pure #-}
    {-# INLINE (<*>) #-}

instance (Monad m, Functor (h (HeftyT h m))) => Monad (HeftyT h m) where
    HeftyT m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
m >>= :: forall a b. HeftyT h m a -> (a -> HeftyT h m b) -> HeftyT h m b
>>= a -> HeftyT h m b
k =
        forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
m (FreeF (h (HeftyT h m)) a (HeftyT h m a)) -> HeftyT h m a
HeftyT forall a b. (a -> b) -> a -> b
$
            m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Pure a
x -> forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
HeftyT h m a -> m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
runHeftyT forall a b. (a -> b) -> a -> b
$ a -> HeftyT h m b
k a
x
                Free h (HeftyT h m) (HeftyT h m a)
h -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ (a -> HeftyT h m b
k =<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h (HeftyT h m) (HeftyT h m a)
h

instance MonadTrans (HeftyT h) where
    lift :: forall (m :: * -> *) a. Monad m => m a -> HeftyT h m a
lift = forall (m :: * -> *) a (h :: (* -> *) -> * -> *).
Functor m =>
m a -> HeftyT h m a
liftHefty
    {-# INLINE lift #-}

{- | Lift a computation to a hefty monad.

     Note that this is less constrained than MonadTrans's lift (this one only
    requires a Functor for underlying monad).
-}
liftHefty :: Functor m => m a -> HeftyT h m a
liftHefty :: forall (m :: * -> *) a (h :: (* -> *) -> * -> *).
Functor m =>
m a -> HeftyT h m a
liftHefty = forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
m (FreeF (h (HeftyT h m)) a (HeftyT h m a)) -> HeftyT h m a
HeftyT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a b. a -> FreeF f a b
Pure
{-# INLINE liftHefty #-}

-- | A hefty monad.
type Hefty h = HeftyT h Identity

hefty :: FreeF (h (Hefty h)) a (Hefty h a) -> Hefty h a
hefty :: forall (h :: (* -> *) -> * -> *) a.
FreeF (h (Hefty h)) a (Hefty h a) -> Hefty h a
hefty = forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
m (FreeF (h (HeftyT h m)) a (HeftyT h m a)) -> HeftyT h m a
HeftyT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity
{-# INLINE hefty #-}

runHefty :: Hefty h a -> FreeF (h (Hefty h)) a (Hefty h a)
runHefty :: forall (h :: (* -> *) -> * -> *) a.
Hefty h a -> FreeF (h (Hefty h)) a (Hefty h a)
runHefty = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: (* -> *) -> * -> *) (m :: * -> *) a.
HeftyT h m a -> m (FreeF (h (HeftyT h m)) a (HeftyT h m a))
runHeftyT
{-# INLINE runHefty #-}