-- https://www.youtube.com/watch?v=qzOQOmmkKEM&feature=emb_logo

module Prod.Tracer (
    Tracer (..),
    silent,
    traceIf,
    traceBoth,

    -- * common utilities
    tracePrint,
    traceHPrint,
    traceHPut,
    encodeJSON,
    pulls,

    -- * re-exports
    Contravariant (..),
    Divisible (..),
    Decidable (..),
) where

import Control.Monad ((>=>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (ToJSON, encode)
import Data.ByteString.Lazy (ByteString, hPut)
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import System.IO (Handle, hPrint)

newtype Tracer m a = Tracer {forall (m :: * -> *) a. Tracer m a -> a -> m ()
runTracer :: (a -> m ())}

instance Contravariant (Tracer m) where
    contramap :: forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
contramap a' -> a
f (Tracer a -> m ()
g) = (a' -> m ()) -> Tracer m a'
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (a -> m ()
g (a -> m ()) -> (a' -> a) -> a' -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

instance (Applicative m) => Divisible (Tracer m) where
    conquer :: forall a. Tracer m a
conquer = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
silent
    divide :: forall a b c.
(a -> (b, c)) -> Tracer m b -> Tracer m c -> Tracer m a
divide = (a -> (b, c)) -> Tracer m b -> Tracer m c -> Tracer m a
forall (m :: * -> *) c a b.
Applicative m =>
(c -> (a, b)) -> Tracer m a -> Tracer m b -> Tracer m c
traceSplit

instance (Applicative m) => Decidable (Tracer m) where
    lose :: forall a. (a -> Void) -> Tracer m a
lose a -> Void
_ = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
silent
    choose :: forall a b c.
(a -> Either b c) -> Tracer m b -> Tracer m c -> Tracer m a
choose = (a -> Either b c) -> Tracer m b -> Tracer m c -> Tracer m a
forall (m :: * -> *) c a b.
Applicative m =>
(c -> Either a b) -> Tracer m a -> Tracer m b -> Tracer m c
tracePick

-- | Disable Tracing.
{-# INLINE silent #-}
silent :: (Applicative m) => Tracer m a
silent :: forall (m :: * -> *) a. Applicative m => Tracer m a
silent = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (m () -> a -> m ()
forall a b. a -> b -> a
const (m () -> a -> m ()) -> m () -> a -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

{- | Splits a tracer into two chunks that are run sequentially.

This name can be confusing but it has to be thought backwards for Contravariant logging:
We compose a target tracer from two tracers but we split the content of the trace.

Note that the split function may actually duplicate inputs (that's how traceBoth works).
-}
{-# INLINEABLE traceSplit #-}
traceSplit :: (Applicative m) => (c -> (a, b)) -> Tracer m a -> Tracer m b -> Tracer m c
traceSplit :: forall (m :: * -> *) c a b.
Applicative m =>
(c -> (a, b)) -> Tracer m a -> Tracer m b -> Tracer m c
traceSplit c -> (a, b)
split (Tracer a -> m ()
f1) (Tracer b -> m ()
f2) = (c -> m ()) -> Tracer m c
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a, b) -> m ()
go ((a, b) -> m ()) -> (c -> (a, b)) -> c -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> (a, b)
split)
  where
    go :: (a, b) -> m ()
go (a
b, b
c) = a -> m ()
f1 a
b m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> b -> m ()
f2 b
c

{- | If you are given two tracers and want to pass both.
Composition occurs in sequence.
-}
{-# INLINEABLE traceBoth #-}
traceBoth :: (Applicative m) => Tracer m a -> Tracer m a -> Tracer m a
traceBoth :: forall (m :: * -> *) a.
Applicative m =>
Tracer m a -> Tracer m a -> Tracer m a
traceBoth Tracer m a
t1 Tracer m a
t2 = (a -> (a, a)) -> Tracer m a -> Tracer m a -> Tracer m a
forall (m :: * -> *) c a b.
Applicative m =>
(c -> (a, b)) -> Tracer m a -> Tracer m b -> Tracer m c
traceSplit (\a
x -> (a
x, a
x)) Tracer m a
t1 Tracer m a
t2

{- | Picks a tracer based on the emitted object.
Example logic that can be built is traceIf that silent messages.
-}
{-# INLINEABLE tracePick #-}
tracePick :: (Applicative m) => (c -> Either a b) -> Tracer m a -> Tracer m b -> Tracer m c
tracePick :: forall (m :: * -> *) c a b.
Applicative m =>
(c -> Either a b) -> Tracer m a -> Tracer m b -> Tracer m c
tracePick c -> Either a b
split (Tracer a -> m ()
f1) (Tracer b -> m ()
f2) = (c -> m ()) -> Tracer m c
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((c -> m ()) -> Tracer m c) -> (c -> m ()) -> Tracer m c
forall a b. (a -> b) -> a -> b
$ \c
a ->
    let e :: Either a b
e = c -> Either a b
split c
a
     in (a -> m ()) -> (b -> m ()) -> Either a b -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m ()
f1 b -> m ()
f2 Either a b
e

-- | Filter by dynamically testing values.
{-# INLINEABLE traceIf #-}
traceIf :: (Applicative m) => (a -> Bool) -> Tracer m a -> Tracer m a
traceIf :: forall (m :: * -> *) a.
Applicative m =>
(a -> Bool) -> Tracer m a -> Tracer m a
traceIf a -> Bool
predicate Tracer m a
t = (a -> Either () a) -> Tracer m () -> Tracer m a -> Tracer m a
forall (m :: * -> *) c a b.
Applicative m =>
(c -> Either a b) -> Tracer m a -> Tracer m b -> Tracer m c
tracePick (\a
x -> if a -> Bool
predicate a
x then () -> Either () a
forall a b. a -> Either a b
Left () else a -> Either () a
forall a b. b -> Either a b
Right a
x) Tracer m ()
forall (m :: * -> *) a. Applicative m => Tracer m a
silent Tracer m a
t

-- | A tracer that prints emitted events.
tracePrint :: (MonadIO m, Show a) => Tracer m a
tracePrint :: forall (m :: * -> *) a. (MonadIO m, Show a) => Tracer m a
tracePrint = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO ()
forall a. Show a => a -> IO ()
print)

-- | A tracer that prints emitted to some handle.
traceHPrint :: (MonadIO m, Show a) => Handle -> Tracer m a
traceHPrint :: forall (m :: * -> *) a. (MonadIO m, Show a) => Handle -> Tracer m a
traceHPrint Handle
handle = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> a -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
handle)

-- | A tracer that puts some ByteString to some handle.
traceHPut :: (MonadIO m) => Handle -> Tracer m ByteString
traceHPut :: forall (m :: * -> *). MonadIO m => Handle -> Tracer m ByteString
traceHPut Handle
handle = (ByteString -> m ()) -> Tracer m ByteString
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ByteString -> IO ()) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> IO ()
hPut Handle
handle)

-- | A conversion encoding values to JSON.
{-# INLINE encodeJSON #-}
encodeJSON :: (ToJSON a) => Tracer m ByteString -> Tracer m a
encodeJSON :: forall a (m :: * -> *).
ToJSON a =>
Tracer m ByteString -> Tracer m a
encodeJSON = (a -> ByteString) -> Tracer m ByteString -> Tracer m a
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

{- | Pulls a value to complete a trace when a trace occurs.

This function allows to combines pushed values with pulled values.  Hence,
performing some scheduling between behaviours.
Typical usage would be to annotate a trace with a background value, or perform
data augmentation in a pipelines of traces.

Note that if you rely on this function you need to pay attention of the
blocking effect of 'pulls': the traced value c is not forwarded until a
value b is available.
-}
{-# INLINE pulls #-}
pulls :: (Monad m) => (c -> m b) -> Tracer m b -> Tracer m c
pulls :: forall (m :: * -> *) c b.
Monad m =>
(c -> m b) -> Tracer m b -> Tracer m c
pulls c -> m b
act (Tracer b -> m ()
f1) = (c -> m ()) -> Tracer m c
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((c -> m ()) -> Tracer m c) -> (c -> m ()) -> Tracer m c
forall a b. (a -> b) -> a -> b
$ c -> m b
act (c -> m b) -> (b -> m ()) -> c -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> m ()
f1