307a2da · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Drop lenses in favor of lightweight microlens

307a2daMichael Xavier11 years ago

katip/katip.cabal+2−2

compare with master

unifiedsplit

@@ -51,8 +51,6 @@ library

51 , either >= 4 && < 4.5

52 , exceptions >= 0.5 && < 0.9

53 , hostname >=1.0 && <1.1

54− , lens >= 4.4 && <4.14

55− , lens-aeson < 1.1

56 , old-locale >= 1.0 && < 1.1

54 , old-locale >= 1.0 && < 1.1

57 , string-conv >= 0.1 && < 0.2

55 , string-conv >= 0.1 && < 0.2

58 , template-haskell >= 2.8 && < 2.11

56 , template-haskell >= 2.8 && < 2.11

@@ -67,6 +65,8 @@ library

67 , mtl >= 2.2 && < 2.3

65 , mtl >= 2.2 && < 2.3

68 , transformers-base >= 0.4.1 && < 0.5

66 , transformers-base >= 0.4.1 && < 0.5

69 , resourcet >= 1.1 && < 1.2

67 , resourcet >= 1.1 && < 1.2

68+ , microlens >= 0.2.0.0 && < 0.5

69+ , microlens-th >= 0.1.0.0 && < 0.4

71 hs-source-dirs: src

72 default-language: Haskell2010

katip/src/Katip.hs+11−9

@@ -32,11 +32,21 @@ module Katip

32 , Environment (..)

33 , Severity (..)

34 , renderSeverity

35− , severityText

35+ , textToSeverity

36 , Verbosity (..)

37 , ToObject (..)

38 , LogItem (..)

39 , Item(..)

40+ , ThreadIdText(..)

41+ , PayloadSelection (..)

42+ , Scribe (..)

43+ , LogEnv (..)

44+ , KatipContext(..)

45+ , AnyLogContext

46+ , LogContexts, liftPayload

47+ , SimpleLogPayload, sl

48+

49+ -- ** @lens@-compatible Lenses

40 , itemApp

50 , itemApp

41 , itemEnv

51 , itemEnv

42 , itemSeverity

52 , itemSeverity

@@ -48,20 +58,12 @@ module Katip

48 , itemTime

58 , itemTime

49 , itemNamespace

59 , itemNamespace

50 , itemLoc

60 , itemLoc

51− , ThreadIdText(..)

52− , PayloadSelection (..)

53− , Scribe (..)

54− , LogEnv (..)

55 , logEnvHost

61 , logEnvHost

56 , logEnvPid

62 , logEnvPid

57 , logEnvNs

63 , logEnvNs

58 , logEnvEnv

64 , logEnvEnv

59 , logEnvTimer

65 , logEnvTimer

60 , logEnvScribes

66 , logEnvScribes

61− , KatipContext(..)

62− , AnyLogContext

63− , LogContexts, liftPayload

64− , SimpleLogPayload, sl

66 -- * A Built-in Monad For Logging

68 -- * A Built-in Monad For Logging

67 , KatipT (..)

69 , KatipT (..)

katip/src/Katip/Core.hs+34−27

@@ -11,13 +11,14 @@

11{-# LANGUAGE TemplateHaskell #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE UndecidableInstances #-}

14+-- | This module is not meant to be imported directly and may contain

15+-- internal mechanisms that will change without notice.

14module Katip.Core where

16module Katip.Core where

16-------------------------------------------------------------------------------

18-------------------------------------------------------------------------------

17import Control.Applicative as A

19import Control.Applicative as A

18import Control.AutoUpdate

20import Control.AutoUpdate

19import Control.Concurrent

21import Control.Concurrent

20−import Control.Lens

21import Control.Monad.Base

22import Control.Monad.Base

22import Control.Monad.Catch

23import Control.Monad.Catch

23import Control.Monad.IO.Class

24import Control.Monad.IO.Class

@@ -47,11 +48,20 @@ import Data.Time

47import GHC.Generics hiding (to)

48import GHC.Generics hiding (to)

48import Language.Haskell.TH

49import Language.Haskell.TH

49import qualified Language.Haskell.TH.Syntax as TH

50import qualified Language.Haskell.TH.Syntax as TH

51+import Lens.Micro

52+import Lens.Micro.TH

50import Network.HostName

53import Network.HostName

51import System.Posix

54import System.Posix

52-------------------------------------------------------------------------------

55-------------------------------------------------------------------------------

58+readMay :: Read a => String -> Maybe a

59+readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of

60+ [x] -> Just x

61+ [] -> Nothing -- no parse

62+ _ -> Nothing -- Ambiguous parse

63+

64+

55-------------------------------------------------------------------------------

65-------------------------------------------------------------------------------

56-- | Represents a heirarchy of namespaces going from general to

66-- | Represents a heirarchy of namespaces going from general to

57-- specific. For instance: ["processname", "subsystem"]. Note that

67-- specific. For instance: ["processname", "subsystem"]. Note that

@@ -116,27 +126,25 @@ renderSeverity s = case s of

116

126

117

127

118-------------------------------------------------------------------------------

128-------------------------------------------------------------------------------

119−severityText :: Prism' Text Severity

129+textToSeverity :: Text -> Maybe Severity

120−severityText = prism renderSeverity toSev

121− where

122− toSev "Debug" = Right DebugS

130+textToSeverity "Debug" = Just DebugS

123− toSev "Info" = Right InfoS

131+textToSeverity "Info" = Just InfoS

124− toSev "Notice" = Right NoticeS

132+textToSeverity "Notice" = Just NoticeS

125− toSev "Warning" = Right WarningS

133+textToSeverity "Warning" = Just WarningS

126− toSev "Error" = Right ErrorS

134+textToSeverity "Error" = Just ErrorS

127− toSev "Critical" = Right CriticalS

135+textToSeverity "Critical" = Just CriticalS

128− toSev "Alert" = Right AlertS

136+textToSeverity "Alert" = Just AlertS

129− toSev "Emergency" = Right EmergencyS

137+textToSeverity "Emergency" = Just EmergencyS

130− toSev x = Left x

138+textToSeverity _ = Nothing

131

139

132−instance ToJSON Severity where

133− toJSON s = A.String (s ^. re severityText)

134

140

141+instance ToJSON Severity where

142+ toJSON s = A.String (renderSeverity s)

135

143

136instance FromJSON Severity where

144instance FromJSON Severity where

137 parseJSON = A.withText "Severity" parseSeverity

145 parseJSON = A.withText "Severity" parseSeverity

138 where

146 where

139− parseSeverity t = case t ^? severityText of

147+ parseSeverity t = case textToSeverity t of

140 Just x -> return x

148 Just x -> return x

141 Nothing -> fail $ "Invalid Severity " ++ toS t

149 Nothing -> fail $ "Invalid Severity " ++ toS t

142

150

@@ -289,13 +297,12 @@ instance FromJSON a => FromJSON (Item a) where

289 <*> (fmap getLocJs <$> o A..: "loc")

297 <*> (fmap getLocJs <$> o A..: "loc")

290

298

291

299

292−processIDText :: Prism' Text ProcessID

300+processIDToText :: ProcessID -> Text

293−processIDText = prism fromProcessID toProcessID

301+processIDToText = toS . show

294− where

302+

295− fromProcessID = toS . show

303+

296− toProcessID t = case toS t ^? _Show of

304+textToProcessID :: Text -> Maybe ProcessID

297− Just i -> Right i

305+textToProcessID = readMay . toS

298− Nothing -> Left t

299

306

300

307

301newtype ProcessIDJs = ProcessIDJs {

308newtype ProcessIDJs = ProcessIDJs {

@@ -304,13 +311,13 @@ newtype ProcessIDJs = ProcessIDJs {

304

311

305

312

306instance ToJSON ProcessIDJs where

313instance ToJSON ProcessIDJs where

307− toJSON (ProcessIDJs p) = A.String (p ^. re processIDText)

314+ toJSON (ProcessIDJs p) = A.String (processIDToText p)

308

315

309

316

310instance FromJSON ProcessIDJs where

317instance FromJSON ProcessIDJs where

311 parseJSON = A.withText "ProcessID" parseProcessID

318 parseJSON = A.withText "ProcessID" parseProcessID

312 where

319 where

313− parseProcessID t = case t ^? processIDText of

320+ parseProcessID t = case textToProcessID t of

314 Just p -> return $ ProcessIDJs p

321 Just p -> return $ ProcessIDJs p

315 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t

322 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t

316

323

@@ -515,7 +522,7 @@ registerScribe

515 -> Scribe

522 -> Scribe

516 -> LogEnv

523 -> LogEnv

517 -> LogEnv

524 -> LogEnv

518−registerScribe nm h = logEnvScribes . at nm .~ Just h

525+registerScribe nm h = logEnvScribes %~ M.insert nm h

519

526

520

527

521-------------------------------------------------------------------------------

528-------------------------------------------------------------------------------

@@ -526,7 +533,7 @@ unregisterScribe

526 -- ^ Name of the scribe

533 -- ^ Name of the scribe

527 -> LogEnv

534 -> LogEnv

528 -> LogEnv

535 -> LogEnv

529−unregisterScribe nm = logEnvScribes . at nm .~ Nothing

536+unregisterScribe nm = logEnvScribes %~ M.delete nm

530

537

531

538

532-------------------------------------------------------------------------------

539-------------------------------------------------------------------------------

katip/src/Katip/Scribes/Handle.hs+9−8

@@ -3,15 +3,15 @@

3module Katip.Scribes.Handle where

5-------------------------------------------------------------------------------

6−import Control.Lens

7import Control.Monad

6import Control.Monad

8−import Data.Aeson.Lens

7+import Data.Aeson

9import qualified Data.HashMap.Strict as HM

8import qualified Data.HashMap.Strict as HM

10import Data.Monoid

9import Data.Monoid

11import Data.Text.Lazy.Builder

10import Data.Text.Lazy.Builder

12import Data.Text.Lazy.IO as T

11import Data.Text.Lazy.IO as T

13import Data.Time

12import Data.Time

14import qualified Data.Time.Locale.Compat as LC

13import qualified Data.Time.Locale.Compat as LC

14+import Lens.Micro

15import System.IO

16import System.IO.Unsafe (unsafePerformIO)

17-------------------------------------------------------------------------------

@@ -29,15 +29,16 @@ getKeys :: LogItem s => Verbosity -> s -> [Builder]

29getKeys verb a = payloadObject verb a ^..

30 to HM.toList . traverse . to rendPair

31 where

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

32+ rendPair (k,v) = fromText k <> fromText ":" <> (renderPrim v)

35-------------------------------------------------------------------------------

36−renderPrim :: Primitive -> Builder

36+renderPrim :: Value -> Builder

37−renderPrim (StringPrim t) = fromText t

37+renderPrim (String t) = fromText t

38−renderPrim (NumberPrim s) = fromString (show s)

38+renderPrim (Number s) = fromString (show s)

39−renderPrim (BoolPrim b) = fromString (show b)

39+renderPrim (Bool b) = fromString (show b)

40−renderPrim NullPrim = fromText "null"

40+renderPrim Null = fromText "null"

41+renderPrim _ = mempty

43-------------------------------------------------------------------------------

44-------------------------------------------------------------------------------

katip/test/Katip/Tests.hs+10−1

@@ -1,4 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE StandaloneDeriving #-}

4{-# OPTIONS_GHC -fno-warn-orphans #-}

5{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -17,9 +18,11 @@ import Language.Haskell.TH

17import System.Posix.Types

18import System.Posix.Types

18import Test.QuickCheck.Instances ()

19import Test.QuickCheck.Instances ()

19import Test.Tasty

20import Test.Tasty

21+import Test.Tasty.HUnit

20import Test.Tasty.QuickCheck

22import Test.Tasty.QuickCheck

21-------------------------------------------------------------------------------

23-------------------------------------------------------------------------------

22import Katip

24import Katip

25+import Katip.Core

23-------------------------------------------------------------------------------

26-------------------------------------------------------------------------------

@@ -27,7 +30,13 @@ tests :: TestTree

27tests = testGroup "Katip"

30tests = testGroup "Katip"

28 [

31 [

29 testProperty "JSON cycle Item" $ \(i :: Item ()) ->

32 testProperty "JSON cycle Item" $ \(i :: Item ()) ->

30− prop_json_cycle i

33+ prop_json_cycle i

34+ , testProperty "renderSeverity/textToSeverity cycle" $ \sev ->

35+ textToSeverity(renderSeverity sev) === Just sev

36+ , testProperty "processIDToText/textToProcessID cycle" $ \pid ->

37+ textToProcessID (processIDToText pid) === Just pid

38+ , testCase "processIDToText is just the number" $ do

39+ processIDToText 123 @?= "123"

31 ]

40 ]