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 Control.Effect
import Control.Effect.Writer

import System.IO

-- For coercion purposes
import Control.Effect.Internal.Utils
import Control.Effect.Carrier.Internal.Interpret
import Control.Effect.Carrier.Internal.Compose
import Control.Effect.Carrier.Internal.Intro
import Control.Monad.Trans.Identity


-- | An effect for debugging by printing/logging strings.
data Trace m a where
  Trace :: String -> Trace m ()

-- | Log the provided string
trace :: Eff Trace m => String -> m ()
trace :: String -> m ()
trace = Trace m () -> m ()
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Trace m () -> m ()) -> (String -> Trace m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Trace m ()
forall k (m :: k). String -> Trace m ()
Trace
{-# INLINE trace #-}

-- | 'show' the provided item and log it.
traceShow :: (Show a, Eff Trace m) => a -> m ()
traceShow :: a -> m ()
traceShow = String -> m ()
forall (m :: * -> *). Eff Trace m => String -> m ()
trace (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
{-# INLINE traceShow #-}

type TraceListC = CompositionC
 '[ TraceIntoTellC
  , TellListC String
  ]

-- | 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 :: TraceListC m a -> m ([String], a)
runTraceList =
     TellListC String m a -> m ([String], a)
forall s (m :: * -> *) a (p :: [Effect]).
(Carrier m, Threaders '[WriterThreads] m p) =>
TellListC s m a -> m ([s], a)
runTellList
  (TellListC String m a -> m ([String], a))
-> (TraceIntoTellC
      (CompositionC
         '[ReinterpretC TellListH (Tell String) '[Tell (Dual [String])],
           TellC (Dual [String])]
         m)
      a
    -> TellListC String m a)
-> TraceIntoTellC
     (CompositionC
        '[ReinterpretC TellListH (Tell String) '[Tell (Dual [String])],
          TellC (Dual [String])]
        m)
     a
-> m ([String], a)
forall b a c. Coercible b a => (b -> c) -> (a -> b) -> a -> c
.# TraceIntoTellC
  (CompositionC
     '[ReinterpretC TellListH (Tell String) '[Tell (Dual [String])],
       TellC (Dual [String])]
     m)
  a
-> TellListC String m a
forall (m :: * -> *) a.
HeadEff (Tell String) m =>
TraceIntoTellC m a -> m a
traceIntoTell
  (TraceIntoTellC
   (CompositionC
      '[ReinterpretC TellListH (Tell String) '[Tell (Dual [String])],
        TellC (Dual [String])]
      m)
   a
 -> m ([String], a))
-> (TraceListC m a
    -> TraceIntoTellC
         (CompositionC
            '[ReinterpretC TellListH (Tell String) '[Tell (Dual [String])],
              TellC (Dual [String])]
            m)
         a)
-> TraceListC m a
-> m ([String], a)
forall b a c. Coercible b a => (b -> c) -> (a -> b) -> a -> c
.# TraceListC m a
-> TraceIntoTellC
     (CompositionC
        '[ReinterpretC TellListH (Tell String) '[Tell (Dual [String])],
          TellC (Dual [String])]
        m)
     a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
{-# INLINE runTraceList #-}

data TracePrintingH

instance Eff (Embed IO) m
      => Handler TracePrintingH Trace m where
  effHandler :: Trace (Effly z) x -> Effly z x
effHandler (Trace String
str) = IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
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 :: TracePrintingC m a -> m a
runTracePrinting = TracePrintingC m a -> m a
forall h (e :: Effect) (m :: * -> *) a.
Handler h e m =>
InterpretC h e m a -> m a
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 :: Handle -> InterpretReifiedC Trace m a -> m a
runTraceToHandle Handle
hdl = EffHandler Trace m -> InterpretReifiedC Trace m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (EffHandler Trace m -> InterpretReifiedC Trace m a -> m a)
-> EffHandler Trace m -> InterpretReifiedC Trace m a -> m a
forall a b. (a -> b) -> a -> b
$ \case
  Trace str -> IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
hdl String
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 :: Handle -> InterpretSimpleC Trace m a -> m a
runTraceToHandleSimple Handle
hdl = EffHandler Trace m -> InterpretSimpleC Trace m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
 Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple (EffHandler Trace m -> InterpretSimpleC Trace m a -> m a)
-> EffHandler Trace m -> InterpretSimpleC Trace m a -> m a
forall a b. (a -> b) -> a -> b
$ \case
  Trace str -> IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
hdl String
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 :: InterpretReifiedC Trace m a -> m ([String], a)
runTraceListIO InterpretReifiedC Trace m a
m = do
  IORef [String]
ref <- IO (IORef [String]) -> m (IORef [String])
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed ([String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef [])
  a
a   <- (EffHandler Trace m -> InterpretReifiedC Trace m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
`interpret` InterpretReifiedC Trace m a
m) (EffHandler Trace m -> m a) -> EffHandler Trace m -> m a
forall a b. (a -> b) -> a -> b
$ \case
    Trace o -> IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef [String] -> ([String] -> ([String], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [String]
ref (\[String]
s -> (String
oString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
s, ())))
  [String]
s   <- [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> m [String] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
ref)
  ([String], a) -> m ([String], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
s, a
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 :: InterpretSimpleC Trace m a -> m ([String], a)
runTraceListIOSimple InterpretSimpleC Trace m a
m = do
  IORef [String]
ref <- IO (IORef [String]) -> m (IORef [String])
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed ([String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef [])
  a
a   <- (EffHandler Trace m -> InterpretSimpleC Trace m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
 Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
`interpretSimple` InterpretSimpleC Trace m a
m) (EffHandler Trace m -> m a) -> EffHandler Trace m -> m a
forall a b. (a -> b) -> a -> b
$ \case
    Trace String
o -> IO () -> Effly z ()
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef [String] -> ([String] -> ([String], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [String]
ref (\[String]
s -> (String
oString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
s, ())))
  [String]
s   <- [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> m [String] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
ref)
  ([String], a) -> m ([String], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
s, a
a)
{-# INLINE runTraceListIOSimple #-}

data IgnoreTraceH

instance Carrier m
      => Handler IgnoreTraceH Trace m where
  effHandler :: Trace (Effly z) x -> Effly z x
effHandler (Trace String
_) = () -> Effly z ()
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: IgnoreTraceC m a -> m a
ignoreTrace = IgnoreTraceC m a -> m a
forall h (e :: Effect) (m :: * -> *) a.
Handler h e m =>
InterpretC h e m a -> m a
interpretViaHandler
{-# INLINE ignoreTrace #-}

data TraceToTellH

instance Eff (Tell String) m
      => Handler TraceToTellH Trace m where
  effHandler :: Trace (Effly z) x -> Effly z x
effHandler (Trace String
str) = String -> Effly z ()
forall s (m :: * -> *). Eff (Tell s) m => s -> m ()
tell String
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 :: TraceIntoTellC m a -> m a
traceIntoTell = TraceIntoTellC m a -> m a
forall h (e :: Effect) (new :: [Effect]) (m :: * -> *) a.
(Handler h e m, KnownList new, HeadEffs new m) =>
ReinterpretC h e new m a -> m a
reinterpretViaHandler
{-# INLINE traceIntoTell #-}