fe9012d · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Added NoLoggingT

fe9012dSimon Hafner9 years ago

katip/katip.cabal+1

compare with master

unifiedsplit

@@ -78,6 +78,7 @@ library

78 , microlens >= 0.2.0.0 && < 0.5

79 , microlens-th >= 0.1.0.0 && < 0.5

80 , semigroups

81+ , unliftio-core >= 0.1 && < 0.2

81 , stm >= 2.4

82 , stm >= 2.4

83 hs-source-dirs: src

84 hs-source-dirs: src

katip/src/Katip/Core.hs+5

@@ -33,6 +33,7 @@ import Control.Exception.Safe

33import Control.Monad (unless, void)

34import Control.Monad.Base

35import Control.Monad.IO.Class

36+import Control.Monad.IO.Unlift

36import Control.Monad.Trans.Class

37import Control.Monad.Trans.Class

37import Control.Monad.Trans.Control

38import Control.Monad.Trans.Control

38#if !MIN_VERSION_either(4, 5, 0)

39#if !MIN_VERSION_either(4, 5, 0)

@@ -833,6 +834,10 @@ instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where

833 liftBaseWith = defaultLiftBaseWith

834 liftBaseWith = defaultLiftBaseWith

834 restoreM = defaultRestoreM

835 restoreM = defaultRestoreM

835

836

837+instance MonadUnliftIO m => MonadUnliftIO (KatipT m) where

838+ askUnliftIO = KatipT $

839+ withUnliftIO $ \u ->

840+ pure (UnliftIO (unliftIO u . unKatipT))

836

841

837-------------------------------------------------------------------------------

842-------------------------------------------------------------------------------

838-- | Execute 'KatipT' on a log env.

843-- | Execute 'KatipT' on a log env.

katip/src/Katip/Monadic.hs+57

@@ -34,6 +34,7 @@ module Katip.Monadic

34 , katipAddNamespace

35 , katipAddContext

36 , KatipContextTState(..)

37+ , NoLoggingT

37 ) where

38 ) where

@@ -43,6 +44,7 @@ import Control.Exception.Safe

43import Control.Monad.Base

44import Control.Monad.Base

44import Control.Monad.Error.Class

45import Control.Monad.Error.Class

45import Control.Monad.IO.Class

46import Control.Monad.IO.Class

47+import Control.Monad.IO.Unlift

46import Control.Monad.Reader

48import Control.Monad.Reader

47import Control.Monad.State

49import Control.Monad.State

48import Control.Monad.Trans.Control

50import Control.Monad.Trans.Control

@@ -389,6 +391,11 @@ instance (MonadIO m) => KatipContext (KatipContextT m) where

389 getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)

391 getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)

390 localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m

392 localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m

391

393

394+instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where

395+ askUnliftIO = KatipContextT $

396+ withUnliftIO $ \u ->

397+ pure (UnliftIO (unliftIO u . unKatipContextT))

398+

392

399

393-------------------------------------------------------------------------------

400-------------------------------------------------------------------------------

394runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a

401runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a

@@ -429,3 +436,53 @@ katipAddContext

429 -> m a

436 -> m a

430 -> m a

437 -> m a

431katipAddContext i = localKatipContext (<> (liftPayload i))

438katipAddContext i = localKatipContext (<> (liftPayload i))

439+

440+newtype NoLoggingT m a = NoLoggingT {

441+ runNoLoggingT :: m a

442+ } deriving ( Functor

443+ , Applicative

444+ , Monad

445+ , MonadIO

446+ , MonadThrow

447+ , MonadCatch

448+ , MonadMask

449+ , MonadBase b

450+ , MonadState s

451+ , MonadWriter w

452+ , MonadError e

453+ , MonadPlus

454+ , Alternative

455+ , MonadFix

456+ )

457+

458+instance MonadTrans NoLoggingT where

459+ lift = NoLoggingT

460+

461+instance MonadTransControl NoLoggingT where

462+ type StT NoLoggingT a = a

463+ liftWith f = NoLoggingT $ f runNoLoggingT

464+ restoreT = NoLoggingT

465+ {-# INLINE liftWith #-}

466+ {-# INLINE restoreT #-}

467+

468+instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where

469+ type StM (NoLoggingT m) a = StM m a

470+ liftBaseWith f = NoLoggingT $

471+ liftBaseWith $ \runInBase ->

472+ f $ runInBase . runNoLoggingT

473+ restoreM = NoLoggingT . restoreM

474+

475+instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where

476+ askUnliftIO = NoLoggingT $

477+ withUnliftIO $ \u ->

478+ pure (UnliftIO (unliftIO u . runNoLoggingT))

479+

480+instance MonadIO m => Katip (NoLoggingT m) where

481+ getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging")

482+ localLogEnv = const id

483+

484+instance MonadIO m => KatipContext (NoLoggingT m) where

485+ getKatipContext = pure mempty

486+ localKatipContext = const id

487+ getKatipNamespace = pure mempty

488+ localKatipNamespace = const id

stack.yaml+1

@@ -6,6 +6,7 @@ extra-deps:

6 # These can be dropped probably as soon as they hit an LTS

7 - bloodhound-0.15.0.2

8 - http-types-0.12

9+ - unliftio-core-0.1.1.0

9flags:

10flags:

10 katip:

11 katip:

11 lib-Werror: true

12 lib-Werror: true