content: {-# LANGUAGE DerivingVia #-}
  module Control.Effect.Trace
    ( -- * Effects
      Trace(..)
  
      -- * Actions
    , trace
    , traceShow
  
      -- * Interpretations
    , runTraceList
  
    , runTraceListIO
  
    , runTracePrinting
    , runTraceToHandle
  
    , ignoreTrace
  
    , traceIntoTell
  
      -- * Simple variants of interprations
    , runTraceListIOSimple
    , runTraceToHandleSimple
  
      -- * Threading constraints
    , WriterThreads
  
      -- * Carriers
    , TraceListC
    , TracePrintingC
    , IgnoreTraceC
    , TraceIntoTellC
    ) where
  
  import Data.IORef
  import Data.Semigroup
  
  import Control.Effect
  import Control.Effect.Writer
  
  import System.IO
  
  -- For coercion purposes
  import Control.Effect.Carrier
  import Control.Effect.Internal.Utils
  import Control.Effect.Carrier.Internal.Interpret
  import Control.Effect.Carrier.Internal.Compose
  import Control.Effect.Carrier.Internal.Intro
  import qualified Control.Monad.Trans.Writer.CPS as CPS
  
  
  -- | An effect for debugging by printing/logging strings.
  data Trace :: Effect where
    Trace :: String -> Trace m ()
  
  -- | Log the provided string
  trace :: Eff Trace m => String -> m ()
  trace = send . Trace
  {-# INLINE trace #-}
  
  -- | 'show' the provided item and log it.
  traceShow :: (Show a, Eff Trace m) => a -> m ()
  traceShow = trace . show
  {-# INLINE traceShow #-}
  
  newtype TraceListC m a = TraceListC {
      unTraceListC ::
          TraceIntoTellC
        ( TellListC String
        ( m
        )) a
    } deriving ( Functor, Applicative, Monad
               , Alternative, MonadPlus
               , MonadFix, MonadFail, MonadIO
               , MonadThrow, MonadCatch, MonadMask
               , MonadBase b, MonadBaseControl b
               )
      deriving (MonadTrans, MonadTransControl)
      via CompositionBaseT
       '[ TraceIntoTellC
        , TellListC String
        ]
  
  deriving instance (Carrier m, Threads (CPS.WriterT (Dual [String])) (Prims m))
                 => Carrier (TraceListC m)
  
  -- | Run a 'Trace' effect purely by accumulating all 'trace'd strings
  -- into a list.
  runTraceList :: forall m a p
                . ( Threaders '[WriterThreads] m p
                  , Carrier m
                  )
               => TraceListC m a
               -> m ([String], a)
  runTraceList =
       runTellList
    .# traceIntoTell
    .# unTraceListC
  {-# INLINE runTraceList #-}
  
  data TracePrintingH
  
  instance Eff (Embed IO) m
        => Handler TracePrintingH Trace m where
    effHandler (Trace str) = embed $ hPutStrLn stderr str
    {-# INLINEABLE effHandler #-}
  
  type TracePrintingC = InterpretC TracePrintingH Trace
  
  -- | Run a 'Trace' effect by printing each 'trace'd string
  -- to stderr.
  runTracePrinting :: Eff (Embed IO) m
                   => TracePrintingC m a
                   -> m a
  runTracePrinting = interpretViaHandler
  {-# INLINE runTracePrinting #-}
  
  -- | Run 'Trace' effect by providing each 'trace'd string
  -- to the provided 'Handle'.
  --
  -- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.
  -- __This makes 'runTraceToHandle' very difficult to use partially applied.__
  -- __In particular, it can't be composed using @'.'@.__
  --
  -- If performance is secondary, consider using the slower 'runTraceToHandleSimple',
  -- which doesn't have a higher-rank type.
  runTraceToHandle :: Eff (Embed IO) m
                   => Handle
                   -> InterpretReifiedC Trace m a
                   -> m a
  runTraceToHandle hdl = interpret $ \case
    Trace str -> embed $ hPutStrLn hdl str
  {-# INLINE runTraceToHandle #-}
  
  -- | Run 'Trace' effect by providing each 'trace'd string
  -- to the provided 'Handle'.
  --
  -- This is a less performant version of 'runTraceToHandle' that doesn't have
  -- a higher-rank type, making it much easier to use partially applied.
  runTraceToHandleSimple :: forall m a p
                          . ( Eff (Embed IO) m
                            , Threaders '[ReaderThreads] m p
                            )
                         => Handle
                         -> InterpretSimpleC Trace m a
                         -> m a
  runTraceToHandleSimple hdl = interpretSimple $ \case
    Trace str -> embed $ hPutStrLn hdl str
  {-# INLINE runTraceToHandleSimple #-}
  
  -- | Run a 'Trace' effect by accumulating all 'trace'd strings
  -- into a list using atomic operations in IO.
  --
  -- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.
  -- __This makes 'runTraceListIO' very difficult to use partially applied.__
  -- __In particular, it can't be composed using @'.'@.__
  --
  -- If performance is secondary, consider using the slower 'runTraceListIOSimple',
  -- which doesn't have a higher-rank type.
  runTraceListIO :: Eff (Embed IO) m
                 => InterpretReifiedC Trace m a
                 -> m ([String], a)
  runTraceListIO m = do
    ref <- embed (newIORef [])
    a   <- (`interpret` m) $ \case
      Trace o -> embed (atomicModifyIORef' ref (\s -> (o:s, ())))
    s   <- reverse <$> embed (readIORef ref)
    return (s, a)
  {-# INLINE runTraceListIO #-}
  
  
  -- | Run a 'Trace' effect by accumulating all 'trace'd strings
  -- into a list using atomic operations in IO.
  --
  -- This is a less performant version of 'runTraceListIOSimple' that doesn't have
  -- a higher-rank type, making it much easier to use partially applied.
  runTraceListIOSimple :: forall m a p
                        . ( Eff (Embed IO) m
                          , Threaders '[ReaderThreads] m p
                          )
                       => InterpretSimpleC Trace m a
                       -> m ([String], a)
  runTraceListIOSimple m = do
    ref <- embed (newIORef [])
    a   <- (`interpretSimple` m) $ \case
      Trace o -> embed (atomicModifyIORef' ref (\s -> (o:s, ())))
    s   <- reverse <$> embed (readIORef ref)
    return (s, a)
  {-# INLINE runTraceListIOSimple #-}
  
  data IgnoreTraceH
  
  instance Carrier m
        => Handler IgnoreTraceH Trace m where
    effHandler (Trace _) = pure ()
    {-# INLINEABLE effHandler #-}
  
  type IgnoreTraceC = InterpretC IgnoreTraceH Trace
  
  -- | Run a 'Trace' effect by ignoring it, doing no logging at all.
  ignoreTrace :: Carrier m
              => IgnoreTraceC m a
              -> m a
  ignoreTrace = interpretViaHandler
  {-# INLINE ignoreTrace #-}
  
  data TraceToTellH
  
  instance Eff (Tell String) m
        => Handler TraceToTellH Trace m where
    effHandler (Trace str) = tell str
    {-# INLINEABLE effHandler #-}
  
  type TraceIntoTellC = ReinterpretC TraceToTellH Trace '[Tell String]
  
  -- | Rewrite a 'Trace' effect into a @'Tell' String@ effect on top of the
  -- effect stack.
  traceIntoTell :: HeadEff (Tell String) m
                => TraceIntoTellC m a
                -> m a
  traceIntoTell = reinterpretViaHandler
  {-# INLINE traceIntoTell #-}
  