contralogging.hs

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns, TemplateHaskell #-}

module Data.Tracer where

import Data.Functor.Contravariant
import Data.Time (getCurrentTime)
import Control.Lens
import Control.Monad.Catch
import Protolude hiding (catch)

newtype Trace m a = Trace {runTrace :: a -> m ()}

instance Contravariant (Trace m) where
  contramap f (Trace g) = Trace (g . f)

data Tracer m a = Tracer
  { traceThis :: a -> m ()
  , traceThrough :: forall b. (b -> a) -> m b -> m b
  , traceException :: forall e. (Exception e, MonadCatch m) => (e -> a) -> m () -> m ()
  , traceLeft :: forall l r. Monad m => (l -> a) -> m (Either l r) -> m r
  , traceCtx :: forall b. (b -> a) -> Trace m b
  }

mkTracer :: Monad m => Trace m a -> Tracer m a
mkTracer f@(Trace g) = Tracer
  g
  do
    \p m -> do
      b <- m
      b <$ g (p b)
  do \p m -> catch m $ g . p
  do \p m -> m >>= either (\x -> g (p x) >> panic "traced") pure
  do (>$< f)

data CalledLog
  = CalledStart
  | CalledBoom Int
  | CalledCatch SomeException
  | CalledLog Int
  | CalledEnd
  deriving (Show)

makePrisms ''CalledLog

testGood :: (MonadCatch m, MonadIO m) => Trace m CalledLog -> m ()
testGood (mkTracer -> Tracer {..}) = do
  traceThis CalledStart
  traceException CalledCatch $ panic "panic"
  r <- traceLeft CalledBoom $ do
    pure $ Right "some right text"
  n <- traceThrough CalledLog $ pure 84
  traceThis $ CalledLog 7
  putText $ r <> ": " <> show n
  traceThis CalledEnd

testBad :: Monad m => Trace m CalledLog -> m ()
testBad (mkTracer -> Tracer {..}) = do 
  traceThis CalledStart
  void $ traceLeft CalledBoom $ pure $ Left 42
  traceThis CalledEnd

data CallingLog
  = CallingLoop Int CalledLog
  | CallingAnother CalledLog
  | C'''''''''''''''''''''''''''''C
  | CallingStart
  | CallingEnd
  | CallingCrash SomeException
  deriving (Show)

makePrisms ''CallingLog

callCalled :: (Monad m, MonadCatch m, MonadIO m) => Trace m CallingLog -> m ()
callCalled (mkTracer -> Tracer {..}) = do
  traceThis CallingStart
  forM_ [1 .. 3] $ \i -> do
    traceThis C'''''''''''''''''''''''''''''C
    testGood (traceCtx $ CallingLoop i)
  traceThis C'''''''''''''''''''''''''''''C
  traceException CallingCrash $ testBad (traceCtx CallingAnother)
  traceThis CallingEnd

main :: IO ()
main = do
  putText "------------- just trace  ----"
  callCalled $ Trace print
  putText "------------- trace with current time ----"
  callCalled $
    Trace $ \l -> do
      t <- getCurrentTime
      putText $ show t <> ": " <> show l
  putText "------------- filter out ---------"
  callCalled $ Trace $ \x -> do
        when 
          do  isn't (_CallingAnother . _CalledStart) x
          do print x
  putText "------------- filter in ----------"
  callCalled $ Trace $ \x -> do
        when 
          do has _CallingAnother x
          do print x
  putText "------------- filter and use the log ------"
  callCalled $ Trace $ \x -> print $ fromMaybe 0 do
      (i,y) <- x ^? _CallingLoop  
      n <- y ^? _CalledLog 
      pure $ i * n