{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Plow.Logging
( Tracer (..),
traceWith,
HasEnumerableConstructors,
invalidSilencedConstructors,
warnInvalidSilencedConstructorsWith,
withSilencedTracer,
withAllowedTracer,
withMaybeTracer,
withEitherTracer,
filterTracer,
simpleStdOutTracer,
simpleStdErrTracer,
voidTracer,
IOTracer (..),
)
where
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Functor.Contravariant (Contravariant (..))
import Data.List (intercalate, intersect)
import Data.Proxy (Proxy)
import Data.String (IsString (..))
import Plow.Logging.EnumerableConstructors
import System.IO (hPutStrLn, stderr)
newtype Tracer m a = Tracer (a -> m ())
instance Monad m => Semigroup (Tracer m a) where
(Tracer a -> m ()
f) <> :: Tracer m a -> Tracer m a -> Tracer m a
<> (Tracer a -> m ()
g) = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ \a
a -> a -> m ()
f a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m ()
g a
a
instance Monad m => Monoid (Tracer m a) where
mempty :: Tracer m a
mempty = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
class TraceWith x m where
traceWith :: x a -> a -> m ()
instance TraceWith (Tracer m) m where
traceWith :: forall a. Tracer m a -> a -> m ()
traceWith (Tracer a -> m ()
t) = a -> m ()
t
instance Contravariant (Tracer m) where
contramap :: forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
contramap a' -> a
f (Tracer a -> m ()
t) = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (a -> m ()
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)
invalidSilencedConstructors :: HasEnumerableConstructors a => Proxy a -> [String] -> [String]
invalidSilencedConstructors :: forall a.
HasEnumerableConstructors a =>
Proxy a -> [String] -> [String]
invalidSilencedConstructors Proxy a
p [String]
silencedConstructors =
let cs :: [String]
cs = forall a. HasEnumerableConstructors a => Proxy a -> [String]
allConstructors Proxy a
p
in forall a. (a -> Bool) -> [a] -> [a]
filter (\String
c -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ String
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
cs) [String]
silencedConstructors
warnInvalidSilencedConstructorsWith :: (Applicative m, HasEnumerableConstructors a, IsString s) => Proxy a -> [String] -> Tracer m s -> m ()
warnInvalidSilencedConstructorsWith :: forall (m :: * -> *) a s.
(Applicative m, HasEnumerableConstructors a, IsString s) =>
Proxy a -> [String] -> Tracer m s -> m ()
warnInvalidSilencedConstructorsWith Proxy a
p [String]
silencedConstructors Tracer m s
t = case forall a.
HasEnumerableConstructors a =>
Proxy a -> [String] -> [String]
invalidSilencedConstructors Proxy a
p [String]
silencedConstructors of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[String]
invalid -> forall (x :: * -> *) (m :: * -> *) a.
TraceWith x m =>
x a -> a -> m ()
traceWith Tracer m s
t forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"Detected invalid silenced logging options: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
invalid
filterTracer :: Applicative m => (a -> Bool) -> Tracer m a -> Tracer m a
filterTracer :: forall (m :: * -> *) a.
Applicative m =>
(a -> Bool) -> Tracer m a -> Tracer m a
filterTracer a -> Bool
test (Tracer a -> m ()
f) = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ \a
m -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Bool
test a
m) (a -> m ()
f a
m)
withSilencedTracer :: (Applicative m, HasEnumerableConstructors a) => [String] -> Tracer m a -> Tracer m a
withSilencedTracer :: forall (m :: * -> *) a.
(Applicative m, HasEnumerableConstructors a) =>
[String] -> Tracer m a -> Tracer m a
withSilencedTracer [String]
silencedConstructors = forall (m :: * -> *) a.
Applicative m =>
(a -> Bool) -> Tracer m a -> Tracer m a
filterTracer (\a
m -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. HasEnumerableConstructors a => a -> [String]
listConstructors a
m forall a. Eq a => [a] -> [a] -> [a]
`intersect` [String]
silencedConstructors)
withAllowedTracer :: (Applicative m, HasEnumerableConstructors a) => [String] -> Tracer m a -> Tracer m a
withAllowedTracer :: forall (m :: * -> *) a.
(Applicative m, HasEnumerableConstructors a) =>
[String] -> Tracer m a -> Tracer m a
withAllowedTracer [String]
allowedConstructors = forall (m :: * -> *) a.
Applicative m =>
(a -> Bool) -> Tracer m a -> Tracer m a
filterTracer (\a
m -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. HasEnumerableConstructors a => a -> [String]
listConstructors a
m forall a. Eq a => [a] -> [a] -> [a]
`intersect` [String]
allowedConstructors)
withMaybeTracer :: Applicative m => Tracer m a -> Tracer m (Maybe a)
withMaybeTracer :: forall (m :: * -> *) a.
Applicative m =>
Tracer m a -> Tracer m (Maybe a)
withMaybeTracer (Tracer a -> m ()
t) = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> m ()
t)
withEitherTracer :: Applicative m => Tracer m a -> Tracer m b -> Tracer m (Either a b)
withEitherTracer :: forall (m :: * -> *) a b.
Applicative m =>
Tracer m a -> Tracer m b -> Tracer m (Either a b)
withEitherTracer (Tracer a -> m ()
ta) (Tracer b -> m ()
tb) = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ \case
Left a
a -> a -> m ()
ta a
a
Right b
b -> b -> m ()
tb b
b
simpleStdOutTracer :: MonadIO m => Tracer m String
simpleStdOutTracer :: forall (m :: * -> *). MonadIO m => Tracer m String
simpleStdOutTracer = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
simpleStdErrTracer :: MonadIO m => Tracer m String
simpleStdErrTracer :: forall (m :: * -> *). MonadIO m => Tracer m String
simpleStdErrTracer = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr
voidTracer :: Applicative m => Tracer m t
voidTracer :: forall (m :: * -> *) t. Applicative m => Tracer m t
voidTracer = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
newtype IOTracer a = IOTracer (forall m. MonadIO m => Tracer m a)
instance Contravariant IOTracer where
contramap :: forall a' a. (a' -> a) -> IOTracer a -> IOTracer a'
contramap a' -> a
f (IOTracer forall (m :: * -> *). MonadIO m => Tracer m a
t) = forall a.
(forall (m :: * -> *). MonadIO m => Tracer m a) -> IOTracer a
IOTracer forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f forall (m :: * -> *). MonadIO m => Tracer m a
t
instance MonadIO m => TraceWith IOTracer m where
traceWith :: forall a. IOTracer a -> a -> m ()
traceWith (IOTracer (Tracer a -> m ()
t)) = a -> m ()
t