{-# 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

-- | Given a "string-like" tracer, outputs a warning message if the supplied 'silencedConstructors' do not
-- match the output of 'allConstructors' for the given tracer type 'a'
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)

-- | Modifies a given tracer so that any message with a constructor name appearing in 'silencedConstructors'
-- will be discarded. In order to work as expected, the type 'a' is required to have an automatically
-- derived instance of 'HasEnumerableConstructors'.
-- @
--    data Foo = Florb Int | Fleeb String | Bar Bool deriving (Generic, HasEnumerableConstructors)
-- @
-- then calling
-- >  traceWith (withSilencedTracer ["Bar"] t) $ Bar False
-- is equivalent to
-- > pure ()
-- and
-- >  traceWith (withSilencedTracer ["Bar"] t) $ Florb 3
-- will be definitionally equal to
-- >  traceWith t $ Florb 3
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)

-- | The opposite of 'withSilencedTracer'. This tracer only loggs messages which match a constructor in
-- 'allowedConstructors'.
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)

-- | Turns a tracer for some 'a' into a tracer for 'Maybe a', which traces 'Just x' using the original tracer
-- | and ignores 'Nothing' (i.e. 'pure ()')
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)

-- | Takes two tracers for values 'a'  and 'b' to a tracer for 'Either a b', which selects the appropriate tracer for each value
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

-- | Tracer that discards/ignores all messages. Useful in test suites, if we don't care about logging output
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 ()

-- | To avoid having to write those pesky 'liftIO's when changing monads, e.g. when
-- passing the logger into a servant server, we can hide the monad entirely behind an
-- existential, requiring a 'MonadIO' instance.
-- We wrap in newtype instead of just a type synonym, to avoid having to have
-- RankNTypes turned on everywhere.
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