{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK not-home #-}
module Control.Effect.Type.Fix
 ( -- * Effects
   Fix(..)

   -- * Threading utilities
 , threadFixViaClass
 ) where

import Control.Monad.Fix
import qualified Control.Monad.Trans.Except as E
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State.Lazy as LSt
import qualified Control.Monad.Trans.State.Strict as SSt
import qualified Control.Monad.Trans.Writer.Lazy as LWr
import qualified Control.Monad.Trans.Writer.Strict as SWr
import qualified Control.Monad.Trans.Writer.CPS as CPSWr

import Control.Effect.Internal.ViaAlg
import Control.Effect.Internal.Reflection
import Control.Effect.Internal.Utils
import Control.Effect.Internal.Union

-- | An effect corresponding to the 'MonadFix' type class.
--
-- 'Control.Effect.Effly''s 'MonadFix' instance is based
-- on this effect; by having access to 'Fix', you're able to
-- use recursive do notation inside of effect handlers.
--
-- __Fix 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 @'ThreadsEff' t 'Fix'@ instance (if possible).
-- 'threadFixViaClass' can help you with that.
--
-- The following threading constraints accept 'Fix':
--
-- * 'Control.Effect.ReaderThreads'
-- * 'Control.Effect.State.StateThreads'
-- * 'Control.Effect.State.StateLazyThreads'
-- * 'Control.Effect.Error.ErrorThreads'
-- * 'Control.Effect.Writer.WriterThreads'
-- * 'Control.Effect.Writer.WriterLazyThreads'
newtype Fix :: Effect where
  Fix :: (a -> m a) -> Fix m a

instance ( Reifies s (ReifiedEffAlgebra Fix m)
         , Monad m
         ) => MonadFix (ViaAlg s Fix m) where
  mfix f = case reflect @s of
    ReifiedEffAlgebra alg -> coerceAlg alg (Fix f)
  {-# INLINE mfix #-}


-- | A valid definition of 'threadEff' for a @'ThreadsEff' t 'Fix'@ instance,
-- given that @t@ lifts 'MonadFix'.
threadFixViaClass :: Monad m
                  => ( RepresentationalT t
                     , forall b. MonadFix b => MonadFix (t b)
                     )
                  => (forall x. Fix m x -> m x)
                  -> Fix (t m) a -> t m a
threadFixViaClass alg (Fix f) = reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->
  unViaAlgT (mfix (viaAlgT @s @Fix #. f))
{-# INLINE threadFixViaClass #-}

#define THREADFIX(monadT)              \
instance ThreadsEff (monadT) Fix where \
  threadEff = threadFixViaClass;       \
  {-# INLINE threadEff #-}

#define THREADFIX_CTX(ctx, monadT)            \
instance ctx => ThreadsEff (monadT) Fix where \
  threadEff = threadFixViaClass;              \
  {-# INLINE threadEff #-}

-- TODO(KingoftheHomeless): Benchmark this vs hand-written instances.
THREADFIX(LSt.StateT s)
THREADFIX(SSt.StateT s)
THREADFIX_CTX(Monoid s, LWr.WriterT s)
THREADFIX_CTX(Monoid s, SWr.WriterT s)
THREADFIX(CPSWr.WriterT s)
THREADFIX(E.ExceptT e)
THREADFIX(R.ReaderT i)