4d103d8 · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Use more specific typeclass for messages

4d103d8Michael Xavier12 years ago

katip/katip.cabal+1−1

compare with master

unifiedsplit

@@ -58,7 +58,7 @@ benchmark bench

58 hs-source-dirs: bench

59 default-language: Haskell2010

60 ghc-options: -O2

61− build-depends:

61+ build-depends:

62 base

63 , aeson

64 , blaze-builder

katip/src/Katip/Core.hs+26−8

@@ -26,7 +26,6 @@ import Control.Monad.Trans.State

26import Control.Monad.Trans.Writer

27import Data.Aeson (ToJSON (..))

28import qualified Data.Aeson as A

29−import Data.Aeson.Lens

30import Data.Foldable (foldMap)

29import Data.Foldable (foldMap)

31import qualified Data.HashMap.Strict as HM

30import qualified Data.HashMap.Strict as HM

32import Data.List

31import Data.List

@@ -198,6 +197,26 @@ instance Monoid PayloadSelection where

198 mappend _ AllKeys = AllKeys

197 mappend _ AllKeys = AllKeys

199 mappend (SomeKeys as) (SomeKeys bs) = SomeKeys (as++bs)

198 mappend (SomeKeys as) (SomeKeys bs) = SomeKeys (as++bs)

200

199

200+

201+-------------------------------------------------------------------------------

202+-- | Katip requires JSON objects to be logged as context. This

203+-- typeclass provides a default instance which uses ToJSON and

204+-- produces an empty object if 'toJSON' results in any type other than

205+-- object. If you have a type you want to log that produces an Array

206+-- or Number for example, you'll want to write an explicit instance

207+-- here. You can trivially add a ToObject instance for something with

208+-- a ToJSON instance like:

209+--

210+-- > instance ToObject Foo

211+class ToJSON a => ToObject a where

212+ toObject :: a -> A.Object

213+ toObject v = case toJSON v of

214+ A.Object o -> o

215+ _ -> mempty

216+

217+instance ToObject ()

218+instance ToObject A.Object

219+

201-------------------------------------------------------------------------------

220-------------------------------------------------------------------------------

202-- | Payload objects need instances of this class.

221-- | Payload objects need instances of this class.

203--

222--

@@ -205,7 +224,7 @@ instance Monoid PayloadSelection where

205-- keys for higher levels of verbosity. Each level of verbosity

224-- keys for higher levels of verbosity. Each level of verbosity

206-- automatically and recursively contains all keys from the level

225-- automatically and recursively contains all keys from the level

207-- before it.

226-- before it.

208−class ToJSON a => LogContext a where

227+class ToObject a => LogContext a where

209

228

210 -- | List of keys in the JSON object that should be included in message.

229 -- | List of keys in the JSON object that should be included in message.

211 payloadKeys :: Verbosity -> a -> PayloadSelection

230 payloadKeys :: Verbosity -> a -> PayloadSelection

@@ -217,11 +236,10 @@ instance LogContext () where payloadKeys _ _ = SomeKeys []

217-------------------------------------------------------------------------------

236-------------------------------------------------------------------------------

218-- | Constrain payload based on verbosity. Backends should use this to

237-- | Constrain payload based on verbosity. Backends should use this to

219-- automatically bubble higher verbosity levels to lower ones.

238-- automatically bubble higher verbosity levels to lower ones.

220−payloadJson :: LogContext a => Verbosity -> a -> A.Value

239+payloadObject :: LogContext a => Verbosity -> a -> A.Object

221−payloadJson verb a = case foldMap (flip payloadKeys a) [(V0)..verb] of

240+payloadObject verb a = case foldMap (flip payloadKeys a) [(V0)..verb] of

222− AllKeys -> toJSON a

241+ AllKeys -> toObject a

223− SomeKeys ks -> toJSON a

224− & _Object %~ HM.filterWithKey (\ k _ -> k `elem` ks)

242+ SomeKeys ks -> HM.filterWithKey (\ k _ -> k `elem` ks) $ toObject a

225

243

226

244

227-------------------------------------------------------------------------------

245-------------------------------------------------------------------------------

@@ -229,7 +247,7 @@ payloadJson verb a = case foldMap (flip payloadKeys a) [(V0)..verb] of

229-- payload based on the desired verbosity. Backends that push JSON

247-- payload based on the desired verbosity. Backends that push JSON

230-- messages should use this to obtain their payload.

248-- messages should use this to obtain their payload.

231itemJson :: LogContext a => Verbosity -> Item a -> A.Value

249itemJson :: LogContext a => Verbosity -> Item a -> A.Value

232−itemJson verb a = toJSON $ a & itemPayload %~ payloadJson verb

250+itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb

233

251

234

252

235-------------------------------------------------------------------------------

253-------------------------------------------------------------------------------

katip/src/Katip/Scribes/Handle.hs+2−2

@@ -26,8 +26,8 @@ brackets m = fromText "[" <> m <> fromText "]"

27-------------------------------------------------------------------------------

28getKeys :: LogContext s => Verbosity -> s -> [Builder]

29−getKeys verb a = payloadJson verb a ^..

29+getKeys verb a = payloadObject verb a ^..

30− _Object . to HM.toList . traverse . to rendPair

30+ to HM.toList . traverse . to rendPair

31 where

32 rendPair (k,v) = fromText k <> fromText ":" <> (v ^. _Primitive . to renderPrim)