{-# LANGUAGE CPP, MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
module Control.Effect.Type.Internal.BaseControl where

import Data.Coerce
import GHC.Exts (Proxy#, proxy#)
import Control.Effect.Internal.Union
import Control.Effect.Internal.Utils
import Control.Effect.Internal.Itself
import Control.Effect.Type.Optional
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict as SSt
import Control.Monad.Trans.State.Lazy as LSt
import Control.Monad.Trans.Writer.Lazy as LWr
import Control.Monad.Trans.Writer.Strict as SWr
import Control.Monad.Trans.Writer.CPS as CPSWr

-- | A /helper primitive effect/ that allows for lowering computations to a
-- base monad.
--
-- Helper primitive effects are effects that allow you to avoid interpreting one
-- of your own effects as a primitive if the power needed from direct access to
-- the underlying monad can instead be provided by the relevant helper primitive
-- effect. The reason why you'd want to do this is that helper primitive effects
-- already have 'ThreadsEff' instances defined for them; so you don't have to
-- define any for your own effect.
--
-- The helper primitive effects offered in this library are -- in order of
-- ascending power -- 'Control.Effect.Regional.Regional',
-- 'Control.Effect.Optional.Optional', 'Control.Effect.BaseControl.BaseControl'
-- and 'Control.Effect.Unlift.Unlift'.
--
-- __'BaseControl' is typically used as a primitive effect__.
-- If you define a 'Control.Effect.Carrier' that relies on a novel
-- non-trivial monad transformer @t@, then you need to make a
-- a @'ThreadsEff' t ('BaseControl' b)@ instance (if possible).
-- 'threadBaseControlViaClass' can help you with that.
--
-- The following threading constraints accept 'BaseControl':
--
-- * 'Control.Effect.ReaderThreads'
-- * 'Control.Effect.State.StateThreads'
-- * 'Control.Effect.State.StateLazyThreads'
-- * 'Control.Effect.Error.ErrorThreads'
-- * 'Control.Effect.Writer.WriterThreads'
-- * 'Control.Effect.Writer.WriterLazyThreads'
newtype BaseControl b m a where
  GainBaseControl :: (  forall z
                      . (MonadBaseControl b z, Coercible z m)
                     => Proxy# z
                     -> a
                     )
                  -> BaseControl b m a

-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('BaseControl' b)@
-- instance, given that @t@ lifts @'MonadBaseControl' b@ for any @b@.
threadBaseControlViaClass :: forall b t m a
                           . ( MonadTrans t
                             , Monad m
                             ,    forall z
                                . MonadBaseControl b z
                               => MonadBaseControl b (t z)
                             ,    forall z
                                . Coercible z m
                              => Coercible (t z) (t m)
                             )
                          => (forall x. BaseControl b m x -> m x)
                          -> BaseControl b (t m) a -> t m a
threadBaseControlViaClass alg (GainBaseControl main) =
  lift $ alg $ GainBaseControl $ \(_ :: Proxy# z) ->
    main (proxy# :: Proxy# (t z))
{-# INLINE threadBaseControlViaClass #-}

-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('Optional' s)@
-- instance, given that @t@ threads @'BaseControl' b@ for any @b@.
threadOptionalViaBaseControl :: forall s t m a
                              . ( Functor s
                                , Monad m
                                , Monad (t m)
                                , ThreadsEff t (BaseControl m)
                                )
                             => (forall x. Optional s m x -> m x)
                             -> Optional s (t m) a -> t m a
threadOptionalViaBaseControl alg (Optionally sa m) =
    join
  $ threadEff (\(GainBaseControl main) -> return $ main (proxy# :: Proxy# (Itself m)))
  $ GainBaseControl @m $ \(_ :: Proxy# z) ->
      coerce $ join $ liftBaseWith @m @z @(z a) $ \lower -> do
          coerceAlg alg
        $ Optionally (fmap (pure @z) sa)
                     (fmap restoreM (coerce (lower @a) m))
{-# INLINE threadOptionalViaBaseControl #-}


#define THREAD_BASE_CONTROL(monadT)                \
instance ThreadsEff (monadT) (BaseControl b) where \
  threadEff = threadBaseControlViaClass;           \
  {-# INLINE threadEff #-}

#define THREAD_BASE_CONTROL_CTX(ctx, monadT)              \
instance ctx => ThreadsEff (monadT) (BaseControl b) where \
  threadEff = threadBaseControlViaClass;                  \
  {-# INLINE threadEff #-}

THREAD_BASE_CONTROL(ReaderT i)
THREAD_BASE_CONTROL(ExceptT e)
THREAD_BASE_CONTROL(LSt.StateT s)
THREAD_BASE_CONTROL(SSt.StateT s)
THREAD_BASE_CONTROL_CTX(Monoid w, LWr.WriterT w)
THREAD_BASE_CONTROL_CTX(Monoid w, SWr.WriterT w)

-- monad-control still doesn't have a MonadBaseControl instance for CPS
-- WriterT, so we use a work-around to make this instance.
instance Monoid w => ThreadsEff (CPSWr.WriterT w) (BaseControl b) where
  threadEff alg (GainBaseControl main) =
    lift $ alg $ GainBaseControl $ \(_ :: Proxy# z) ->
      main (proxy# :: Proxy# (WriterCPS w z))
  {-# INLINE threadEff #-}


newtype WriterCPS s m a = WriterCPS { unWriterCPS :: CPSWr.WriterT s m a }
  deriving (Functor, Applicative, Monad)
  deriving MonadTrans

instance MonadBase b m => MonadBase b (WriterCPS s m) where
  liftBase = lift . liftBase
  {-# INLINE liftBase #-}

instance (Monoid s, MonadBaseControl b m)
      => MonadBaseControl b (WriterCPS s m) where
  type StM (WriterCPS s m) a = StM m (a, s)

  liftBaseWith main = lift $ liftBaseWith $ \run_it ->
    main (run_it . CPSWr.runWriterT .# unWriterCPS)
  {-# INLINE liftBaseWith #-}

  restoreM = WriterCPS #. CPSWr.writerT . restoreM
  {-# INLINE restoreM #-}