module Prod.Tracer (
Tracer (..),
silent,
traceIf,
traceBoth,
tracePrint,
traceHPrint,
traceHPut,
encodeJSON,
pulls,
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
{-# 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 ())
{-# 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
{-# 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
{-# 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
{-# 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
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)
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)
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)
{-# 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
{-# 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