git.iko.soy/typeable/katip
on master help sign in
Add more instances for KatipT
fe7f201Michael Xavier
katip/bench/Main.hs+43−28
compare with master
unifiedsplit
@@ -1,17 +1,18 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# OPTIONS_GHC -fno-warn-orphans #-}
2module Main
5module Main
3 ( main
6 ( main
4 ) where
7 ) where
5
8
6
9
7-------------------------------------------------------------------------------
10-------------------------------------------------------------------------------
8−import Blaze.ByteString.Builder
9import Control.Concurrent
11import Control.Concurrent
10−import Control.Monad.IO.Class
12+import Control.DeepSeq
11−import CriterionPlus
13+import Criterion.Main
12import Data.Aeson
14import Data.Aeson
13import Data.Monoid
15import Data.Monoid
14−import Data.Text (Text)
15import Data.Time.Calendar
16import Data.Time.Calendar
16import Data.Time.Clock
17import Data.Time.Clock
17import System.IO
18import System.IO
@@ -22,35 +23,39 @@ import Katip.Scribes.Handle
22-------------------------------------------------------------------------------
23-------------------------------------------------------------------------------
23
24
24main :: IO ()
25main :: IO ()
25−main = benchmark $
26+main = defaultMain [
26− handleScribeBench
27+ handleScribeBench
28+ ]
27
29
28
30
29-------------------------------------------------------------------------------
31-------------------------------------------------------------------------------
30−handleScribeBench :: Benchmark ()
32+handleScribeBench :: Benchmark
31−handleScribeBench = standoff "Katip.Scribes.Handle" $
33+handleScribeBench = bgroup "Katip.Scribes.Handle" [
34+ env setupEnv $ \ ~(Scribe push, tid) ->
32− subject "Bytestring Builder" $ do
35+ bench "Bytestring Builder" $
33− pause
36+ whnfIO $ push $ exItem tid
34− (Scribe push) <- liftIO setup
37+ ]
38+ where
39+ setupEnv = do
40+ scribe <- setup
35− tid <- liftIO myThreadId
41+ tid <- myThreadId
36− continue
42+ return (scribe, mkThreadIdText tid)
37− whnfIO $ push $ exItem tid
38
43
39
44
40-------------------------------------------------------------------------------
45-------------------------------------------------------------------------------
41−exItem :: ThreadId -> Item ExPayload
46+exItem :: ThreadIdText -> Item ExPayload
42exItem tid = Item {
47exItem tid = Item {
43− itemApp = Namespace ["app"]
48+ _itemApp = Namespace ["app"]
44− , itemEnv = Environment "production"
49+ , _itemEnv = Environment "production"
45− , itemSeverity = Warning
50+ , _itemSeverity = WarningS
46− , itemThread = tid
51+ , _itemThread = tid
47− , itemHost = "example"
52+ , _itemHost = "example"
48− , itemProcess = CPid 123
53+ , _itemProcess = CPid 123
49− , itemPayload = ExPayload
54+ , _itemPayload = ExPayload
50− , itemMessage = "message"
55+ , _itemMessage = "message"
51− , itemTime = mkUTCTime 2015 3 14 1 5 9
56+ , _itemTime = mkUTCTime 2015 3 14 1 5 9
52− , itemNamespace = Namespace ["foo"]
57+ , _itemNamespace = Namespace ["foo"]
53− , itemLoc = Nothing
58+ , _itemLoc = Nothing
54 }
59 }
55
60
56
61
@@ -60,6 +65,8 @@ data ExPayload = ExPayload
60instance ToJSON ExPayload where
65instance ToJSON ExPayload where
61 toJSON _ = Object mempty
66 toJSON _ = Object mempty
62
67
68+instance ToObject ExPayload
69+
63instance LogItem ExPayload where
70instance LogItem ExPayload where
64 payloadKeys _ _ = AllKeys
71 payloadKeys _ _ = AllKeys
65
72
@@ -76,4 +83,12 @@ mkUTCTime y mt d h mn s = UTCTime day dt
76setup :: IO Scribe
83setup :: IO Scribe
77setup = do
84setup = do
78 h <- openFile "/dev/null" WriteMode
85 h <- openFile "/dev/null" WriteMode
79− mkHandleScribe h Debug V0
86+ mkHandleScribe ColorIfTerminal h DebugS V0
87+
88+
89+-------------------------------------------------------------------------------
90+deriving instance NFData ThreadIdText
91+
92+
93+instance NFData Scribe where
94+ rnf (Scribe _) = ()
katip/katip.cabal+3−3
@@ -71,7 +71,7 @@ test-suite test
71 build-depends: base
71 build-depends: base
72 , katip
72 , katip
73 , aeson
73 , aeson
74− , tasty
74+ , tasty >= 0.10.1.2
75 , tasty-hunit
75 , tasty-hunit
76 , tasty-quickcheck
76 , tasty-quickcheck
77 , quickcheck-instances
77 , quickcheck-instances
@@ -96,9 +96,9 @@ benchmark bench
96 , aeson
96 , aeson
97 , blaze-builder
97 , blaze-builder
98 , katip
98 , katip
99− , criterion >= 0.8 && < 1.0
99+ , criterion >= 1.1.0.0
100− , criterion-plus
101 , unix
100 , unix
102 , text
101 , text
103 , time
102 , time
104 , transformers
103 , transformers
104+ , deepseq
katip/src/Katip/Core.hs+19−1
@@ -9,6 +9,8 @@
9{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
12module Katip.Core where
14module Katip.Core where
13
15
14-------------------------------------------------------------------------------
16-------------------------------------------------------------------------------
@@ -17,9 +19,11 @@ import Control.AutoUpdate
17import Control.Concurrent
19import Control.Concurrent
18import Control.Lens
20import Control.Lens
19import Control.Monad
21import Control.Monad
22+import Control.Monad.Base
20import Control.Monad.Catch
23import Control.Monad.Catch
21import Control.Monad.IO.Class
24import Control.Monad.IO.Class
22import Control.Monad.Trans.Class
25import Control.Monad.Trans.Class
26+import Control.Monad.Trans.Control
23import Control.Monad.Trans.Either
27import Control.Monad.Trans.Either
24import Control.Monad.Trans.Maybe
28import Control.Monad.Trans.Maybe
25import Control.Monad.Trans.Reader
29import Control.Monad.Trans.Reader
@@ -518,13 +522,27 @@ instance (Katip m) => Katip (ResourceT m) where
518-- | A concrete monad you can use to run logging actions.
522-- | A concrete monad you can use to run logging actions.
519newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }
523newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }
520 deriving ( Functor, Applicative, Monad, MonadIO
524 deriving ( Functor, Applicative, Monad, MonadIO
521− , MonadMask, MonadCatch, MonadThrow, MonadTrans )
525+ , MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)
522
526
523
527
524instance MonadIO m => Katip (KatipT m) where
528instance MonadIO m => Katip (KatipT m) where
525 getLogEnv = KatipT ask
529 getLogEnv = KatipT ask
526
530
527
531
532+instance MonadTransControl KatipT where
533+ type StT (KatipT) a = a
534+ liftWith f = KatipT $ ReaderT $ \le -> f $ \t -> runKatipT le t
535+ restoreT = KatipT . ReaderT . const
536+ {-# INLINABLE liftWith #-}
537+ {-# INLINABLE restoreT #-}
538+
539+
540+instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where
541+ type StM ((KatipT) m) a = ComposeSt (KatipT) m a
542+ liftBaseWith = defaultLiftBaseWith
543+ restoreM = defaultRestoreM
544+
545+
528-------------------------------------------------------------------------------
546-------------------------------------------------------------------------------
529-- | Execute 'KatipT' on a log env.
547-- | Execute 'KatipT' on a log env.
530runKatipT :: LogEnv -> KatipT m a -> m a
548runKatipT :: LogEnv -> KatipT m a -> m a