{-|
Module      : Control.Tracer
Description : A simple interface for logging, tracing, and monitoring
Copyright   : (c) Alexander Vieth, 2019
Maintainer  : aovieth@gmail.com
License     : Apache-2.0

=== General usage

'Tracer' is a contravariant functor intended to express the pattern in which
values of its parameter type are used to produce effects which are prescribed
by the caller, as in tracing, logging, code instrumentation, etc.

Programs should be written to use as specific a tracer as possible, i.e. to
take as a parameter a @Tracer m domainSpecificType@. To combine these programs
into an executable which does meaningful tracing, an implementation of that
tracing should be used to make a @Tracer probablyIO implementationTracingType@,
which is 'contramap'ped to fit @Tracer m domainSpecificType@ wherever it is
needed, for the various @domainSpecificType@s that appear throughout the
program.

=== An example

This short example shows how a tracer can be deployed, highlighting the use of
'contramap' to fit a general tracer which writes text to a file, where a
specific tracer which takes domain-specific events is expected.

> -- Writes text to some log file.
> traceToLogFile :: FilePath -> Tracer IO Text
>
> -- Domain-specific event type.
> data Event = EventA | EventB Int
>
> -- The log-file format for an Event.
> eventToText :: Event -> Text
>
> -- Some action that can use any tracer on Event, in any monad.
> actionWithTrace :: Monad m => Tracer m Event -> m ()
> actionWithTrace tracer = do
>   traceWith tracer EventA
>   traceWith tracer (EventB 42)
>
> -- Set up a log file tracer, then use it where the Event tracer is expected.
> main :: IO ()
> main = do
>   textTacer <- traceToLogFile "log.txt"
>   let eventTracer :: Tracer IO Event
>       eventTracer = contramap eventToText textTracer
>   actionWithTrace eventTracer
-}

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

module Control.Tracer
    ( Tracer (..)
    , mkTracer
    , traceWith
    , arrow
    , use
    , Arrow.squelch
    , Arrow.emit
    , Arrow.effect
    -- * Simple tracers
    , nullTracer
    , stdoutTracer
    , debugTracer
    -- * Transforming tracers
    , natTracer
    , Arrow.nat
    , traceMaybe
    , traceMaybeM
    , traceAll
    , traceTraversable
    , squelchUnless
    , squelchUnlessM
    -- * Re-export of Contravariant
    , Contravariant(..)
    , (>$<)
    , contramapM
    ) where

import           Control.Arrow ((|||), (&&&), arr, runKleisli)
import           Control.Category ((>>>))
import           Data.Bool (bool)
import           Data.Foldable (traverse_)
import           Data.Functor.Contravariant (Contravariant (..), (>$<))
import           Debug.Trace (traceM)

import qualified Control.Tracer.Arrow as Arrow

-- | This type describes some effect in @m@ which depends upon some value of
-- type @a@, for which the /output value/ is not of interest (only the effects).
--
-- The motivating use case is to describe tracing, logging, monitoring, and
-- similar features, in which the programmer wishes to provide some values to
-- some /other/ program which will do some real world side effect, such as
-- writing to a log file or bumping a counter in some monitoring system.
--
-- The actual implementation of such a program will probably work on rather
-- large, domain-agnostic types like @Text@, @ByteString@, JSON values for
-- structured logs, etc.
--
-- But the call sites which ultimately /invoke/ these implementations will deal
-- with smaller, domain-specific types that concisely describe events, metrics,
-- debug information, etc.
--
-- This difference is reconciled by the 'Contravariant' instance for 'Tracer'.
-- 'Data.Functor.Contravariant.contramap' is used to change the input type of
-- a tracer. This allows for a more general tracer to be used where a more
-- specific one is expected.
--
-- Intuitively: if you can map your domain-specific type @Event@ to a @Text@
-- representation, then any @Tracer m Text@ can stand in where a
-- @Tracer m Event@ is required.
--
-- > eventToText :: Event -> Text
-- >
-- > traceTextToLogFile :: Tracer m Text
-- >
-- > traceEventToLogFile :: Tracer m Event
-- > traceEventToLogFile = contramap eventToText traceTextToLogFile
--
-- Effectful tracers that actually do interesting stuff can be defined
-- using 'emit', and composed via 'contramap'.
--
-- The 'nullTracer' can be used as a stand-in for any tracer, doing no
-- side-effects and producing no interesting value.
--
-- To deal with branching, the arrow interface on the underlying
-- 'Control.Tracer.Arrow.Tracer' should be used. Arrow notation can be helpful
-- here.
--
-- For example, a common pattern is to trace only some variants of a sum type.
--
-- > data Event = This Int | That Bool
-- >
-- > traceOnlyThat :: Tracer m Int -> Tracer m Bool
-- > traceOnlyThat tr = Tracer $ proc event -> do
-- >   case event of
-- >     This i -> use tr  -< i
-- >     That _ -> squelch -< ()
--
-- The key point of using the arrow representation we have here is that this
-- tracer will not necessarily need to force @event@: if the input tracer @tr@
-- does not force its value, then @event@ will not be forced. To elaborate,
-- suppose @tr@ is @nullTracer@. Then this expression becomes
--
-- > classify (This i) = Left i
-- > classify (That _) = Right ()
-- >
-- > traceOnlyThat tr
-- > = Tracer $ Pure classify >>> (squelch ||| squelch) >>> Pure (either id id)
-- > = Tracer $ Pure classify >>> Pure (either (const (Left ())) (const (Right ()))) >>> Pure (either id id)
-- > = Tracer $ Pure (classify >>> either (const (Left ())) (const (Right ())) >>> either id id)
--
-- So that when this tracer is run by 'traceWith' we get
--
-- > traceWith (traceOnlyThat tr) x
-- > = traceWith (Pure _)
-- > = pure ()
--
-- It is _essential_ that the computation of the tracing effects cannot itself
-- have side-effects, as this would ruin the ability to short-circuit when
-- it is known that no tracing will be done: the side-effects of a branch
-- could change the outcome of another branch. This would fly in the face of
-- a crucial design goal: you can leave your tracer calls in the program so
-- they do not bitrot, but can also make them zero runtime cost by substituting
-- 'nullTracer' appropriately.
newtype Tracer m a = Tracer { forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
runTracer :: Arrow.TracerA m a () }

instance Monad m => Contravariant (Tracer m) where
  -- Strict in `tracer` and strict in the `Tracer` constructor: a lazy
  -- contramap builds a thunk that retains references to the arguments,
  -- potentially keeping large heap objects alive. If the tracer is never
  -- dispatched through (e.g. the relevant event never occurs), those objects
  -- are never released.
  contramap :: forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
contramap a' -> a
f !Tracer m a
tracer = TracerA m a' () -> Tracer m a'
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA m a' () -> Tracer m a') -> TracerA m a' () -> Tracer m a'
forall a b. (a -> b) -> a -> b
$! ((a' -> a) -> TracerA m a' a
forall b c. (b -> c) -> TracerA m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a' -> a
f TracerA m a' a -> TracerA m a () -> TracerA m a' ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Tracer m a -> TracerA m a ()
forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
use Tracer m a
tracer)

-- | @tr1 <> tr2@ will run @tr1@ and then @tr2@ with the same input.
instance Monad m => Semigroup (Tracer m s) where
  Tracer TracerA m s ()
a1 <> :: Tracer m s -> Tracer m s -> Tracer m s
<> Tracer TracerA m s ()
a2 = TracerA m s () -> Tracer m s
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA m s ()
a1 TracerA m s () -> TracerA m s () -> TracerA m s ((), ())
forall b c c'.
TracerA m b c -> TracerA m b c' -> TracerA m b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TracerA m s ()
a2 TracerA m s ((), ()) -> TracerA m ((), ()) () -> TracerA m s ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((), ()) -> ()) -> TracerA m ((), ()) ()
forall b c. (b -> c) -> TracerA m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((), ()) -> ()
discard)
    where
    discard :: ((), ()) -> ()
    discard :: ((), ()) -> ()
discard = () -> ((), ()) -> ()
forall a b. a -> b -> a
const ()

instance Monad m => Monoid (Tracer m s) where
    mappend :: Tracer m s -> Tracer m s -> Tracer m s
mappend = Tracer m s -> Tracer m s -> Tracer m s
forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: Tracer m s
mempty  = Tracer m s
forall (m :: * -> *) s. Monad m => Tracer m s
nullTracer

-- | Make an emitting tracer from a callback.
--
mkTracer :: Applicative m => (a -> m ()) -> Tracer m a
mkTracer :: forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
mkTracer = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA m a () -> Tracer m a)
-> ((a -> m ()) -> TracerA m a ()) -> (a -> m ()) -> Tracer m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m ()) -> TracerA m a ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
Arrow.emit

{-# INLINE traceWith #-}
-- | Run a tracer with a given input.
traceWith :: Monad m => Tracer m a -> a -> m ()
traceWith :: forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith (Tracer TracerA m a ()
tr) a
a = Kleisli m a () -> a -> m ()
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (TracerA m a () -> Kleisli m a ()
forall (m :: * -> *) a. Monad m => TracerA m a () -> Kleisli m a ()
Arrow.runTracerA TracerA m a ()
tr) a
a

-- | Inverse of 'use'.
arrow :: Arrow.TracerA m a () -> Tracer m a
arrow :: forall (m :: * -> *) a. TracerA m a () -> Tracer m a
arrow = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer

-- | Inverse of 'arrow'. Useful when writing arrow tracers which use a
-- contravariant tracer (the newtype in this module).
use :: Tracer m a -> Arrow.TracerA m a ()
use :: forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
use = Tracer m a -> TracerA m a ()
forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
runTracer

-- | A tracer which does nothing.
nullTracer :: Monad m => Tracer m a
nullTracer :: forall (m :: * -> *) s. Monad m => Tracer m s
nullTracer = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer TracerA m a ()
forall (m :: * -> *) a. Applicative m => TracerA m a ()
Arrow.squelch

-- | Create a simple contravariant tracer which runs a given side-effect.
emit :: Applicative m => (a -> m ()) -> Tracer m a
emit :: forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
emit a -> m ()
f = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer ((a -> m ()) -> TracerA m a ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
Arrow.emit a -> m ()
f)

-- | Run a tracer only for the Just variant of a Maybe. If it's Nothing, the
-- 'nullTracer' is used (no output).
--
-- The arrow representation allows for proper laziness: if the tracer parameter
-- does not produce any tracing effects, then the predicate won't even be
-- evaluated. Contrast with the simple contravariant representation as
-- @a -> m ()@, in which the predicate _must_ be forced no matter what,
-- because it's impossible to know a priori whether that function will not
-- produce any tracing effects.
--
-- It's written out explicitly for demonstration. Could also use arrow
-- notation:
--
-- > traceMaybe p tr = Tracer $ proc a -> do
-- >   case k a of
-- >     Just b  -> use tr        -< b
-- >     Nothing -> Arrow.squelch -< ()
--
traceMaybe :: Monad m => (a -> Maybe b) -> Tracer m b -> Tracer m a
traceMaybe :: forall (m :: * -> *) a b.
Monad m =>
(a -> Maybe b) -> Tracer m b -> Tracer m a
traceMaybe a -> Maybe b
k Tracer m b
tr = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA m a () -> Tracer m a) -> TracerA m a () -> Tracer m a
forall a b. (a -> b) -> a -> b
$ TracerA m a (Either () b)
classify TracerA m a (Either () b)
-> TracerA m (Either () b) () -> TracerA m a ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TracerA m () ()
forall (m :: * -> *) a. Applicative m => TracerA m a ()
Arrow.squelch TracerA m () () -> TracerA m b () -> TracerA m (Either () b) ()
forall b d c.
TracerA m b d -> TracerA m c d -> TracerA m (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| Tracer m b -> TracerA m b ()
forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
use Tracer m b
tr)
  where
  classify :: TracerA m a (Either () b)
classify = (a -> Either () b) -> TracerA m a (Either () b)
forall b c. (b -> c) -> TracerA m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either () b -> (b -> Either () b) -> Maybe b -> Either () b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either () b
forall a b. a -> Either a b
Left ()) b -> Either () b
forall a b. b -> Either a b
Right (Maybe b -> Either () b) -> (a -> Maybe b) -> a -> Either () b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
k)

-- | A monadic version of `traceMaybe`.
--
traceMaybeM :: Monad m => (a -> m (Maybe b)) -> Tracer m b -> Tracer m a
traceMaybeM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Tracer m b -> Tracer m a
traceMaybeM a -> m (Maybe b)
k Tracer m b
tr = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA m a () -> Tracer m a) -> TracerA m a () -> Tracer m a
forall a b. (a -> b) -> a -> b
$ TracerA m a (Either () b)
classify TracerA m a (Either () b)
-> TracerA m (Either () b) () -> TracerA m a ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TracerA m () ()
forall (m :: * -> *) a. Applicative m => TracerA m a ()
Arrow.squelch TracerA m () () -> TracerA m b () -> TracerA m (Either () b) ()
forall b d c.
TracerA m b d -> TracerA m c d -> TracerA m (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| Tracer m b -> TracerA m b ()
forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
use Tracer m b
tr)
  where
  classify :: TracerA m a (Either () b)
classify = (a -> m (Either () b)) -> TracerA m a (Either () b)
forall a (m :: * -> *) b. (a -> m b) -> TracerA m a b
Arrow.effect ((Maybe b -> Either () b) -> m (Maybe b) -> m (Either () b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either () b -> (b -> Either () b) -> Maybe b -> Either () b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either () b
forall a b. a -> Either a b
Left ()) b -> Either () b
forall a b. b -> Either a b
Right) (m (Maybe b) -> m (Either () b))
-> (a -> m (Maybe b)) -> a -> m (Either () b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Maybe b)
k)

-- | Uses 'traceMaybe' to give a tracer which emits only if a predicate is true.
squelchUnless :: Monad m => (a -> Bool) -> Tracer m a -> Tracer m a
squelchUnless :: forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Tracer m a -> Tracer m a
squelchUnless a -> Bool
p = (a -> Maybe a) -> Tracer m a -> Tracer m a
forall (m :: * -> *) a b.
Monad m =>
(a -> Maybe b) -> Tracer m b -> Tracer m a
traceMaybe (\a
a -> Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (a -> Bool
p a
a))

-- | A monadic version of `squelchUnless`.
squelchUnlessM :: Monad m => (a -> m Bool) -> Tracer m a -> Tracer m a
squelchUnlessM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Tracer m a -> Tracer m a
squelchUnlessM a -> m Bool
p = (a -> m (Maybe a)) -> Tracer m a -> Tracer m a
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Tracer m b -> Tracer m a
traceMaybeM (\a
a -> Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Bool -> Maybe a) -> m Bool -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m Bool
p a
a)

traceTraversable :: (Monad m, Foldable t) => Tracer m a -> Tracer m (t a)
traceTraversable :: forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
Tracer m a -> Tracer m (t a)
traceTraversable tracer :: Tracer m a
tracer@(Tracer TracerA m a ()
tr) =
  case TracerA m a ()
tr of
    Arrow.Squelching Kleisli m a ()
_ -> Tracer m (t a)
forall (m :: * -> *) s. Monad m => Tracer m s
nullTracer
    TracerA m a ()
_                  -> (t a -> m ()) -> Tracer m (t a)
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
emit ((a -> m ()) -> t a -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Tracer m a -> a -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m a
tracer))

traceAll :: (Monad m, Foldable t) => (b -> t a) -> Tracer m a -> Tracer m b
traceAll :: forall (m :: * -> *) (t :: * -> *) b a.
(Monad m, Foldable t) =>
(b -> t a) -> Tracer m a -> Tracer m b
traceAll b -> t a
f = (b -> t a) -> Tracer m (t a) -> Tracer m b
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap b -> t a
f (Tracer m (t a) -> Tracer m b)
-> (Tracer m a -> Tracer m (t a)) -> Tracer m a -> Tracer m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m a -> Tracer m (t a)
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
Tracer m a -> Tracer m (t a)
traceTraversable

-- | Use a natural transformation to change the @m@ type. This is useful, for
-- instance, to use concrete IO tracers in monad transformer stacks that have
-- IO as their base.
natTracer :: forall m n s . (forall x . m x -> n x) -> Tracer m s -> Tracer n s
natTracer :: forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer forall x. m x -> n x
h (Tracer TracerA m s ()
tr) = TracerA n s () -> Tracer n s
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer ((forall x. m x -> n x) -> TracerA m s () -> TracerA n s ()
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x) -> TracerA m a b -> TracerA n a b
Arrow.nat m x -> n x
forall x. m x -> n x
h TracerA m s ()
tr)

-- | Trace strings to stdout. Output could be jumbled when this is used from
-- multiple threads. Consider 'debugTracer' instead.
stdoutTracer :: Tracer IO String
stdoutTracer :: Tracer IO String
stdoutTracer = (String -> IO ()) -> Tracer IO String
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
emit String -> IO ()
putStrLn

-- | Trace strings using 'Debug.Trace.traceM'. This will use stderr. See
-- documentation in "Debug.Trace" for more details.
debugTracer :: Applicative m => Tracer m String
debugTracer :: forall (m :: * -> *). Applicative m => Tracer m String
debugTracer = (String -> m ()) -> Tracer m String
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
emit String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM

-- | A contravariant transformation of a tracer using a Kleisli arrow.
--
contramapM
  :: Monad m
  => (a -> m b)
  -- ^ Kleisli arrow which is evaluated only if a downstream tracer emits
  -> Tracer m b
  -> Tracer m a
contramapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM a -> m b
f Tracer m b
tracer = TracerA m a () -> Tracer m a
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
arrow ((a -> m b) -> TracerA m a b
forall a (m :: * -> *) b. (a -> m b) -> TracerA m a b
Arrow.effect a -> m b
f TracerA m a b -> TracerA m b () -> TracerA m a ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Tracer m b -> TracerA m b ()
forall (m :: * -> *) a. Tracer m a -> TracerA m a ()
use Tracer m b
tracer)