461f014 · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Merge pull request #70 from haskell-service/instances

461f014Michael Xavier9 years ago

katip/src/Katip/Core.hs+51−19

compare with master

unifiedsplit

@@ -180,7 +180,7 @@ instance FromJSON Severity where

180-------------------------------------------------------------------------------

181-- | Log message with Builder underneath; use '<>' to concat in O(1).

182newtype LogStr = LogStr { unLogStr :: B.Builder }

183− deriving (Generic, Show)

183+ deriving (Generic, Show, Eq)

184

185instance IsString LogStr where

186 fromString = LogStr . B.fromString

@@ -247,31 +247,62 @@ data Item a = Item {

247 } deriving (Generic, Functor)

248makeLenses ''Item

249

250+-- Manual instance because 'Loc' has no 'Eq' and 'Show' instances in old

251+-- versions of template-haskell (< 2.10)

252+instance Eq a => Eq (Item a) where

253+ a == b = FT.and [ _itemApp a == _itemApp b

254+ , _itemEnv a == _itemEnv b

255+ , _itemSeverity a == _itemSeverity b

256+ , _itemThread a == _itemThread b

257+ , _itemHost a == _itemHost b

258+ , _itemProcess a == _itemProcess b

259+ , _itemPayload a == _itemPayload b

260+ , _itemMessage a == _itemMessage b

261+ , _itemTime a == _itemTime b

262+ , _itemNamespace a == _itemNamespace b

263+ , case (_itemLoc a, _itemLoc b) of

264+ (Nothing, Nothing) -> True

265+ (Just l1, Just l2) -> FT.and [ loc_filename l1 == loc_filename l2

266+ , loc_package l1 == loc_package l2

267+ , loc_module l1 == loc_module l2

268+ , loc_start l1 == loc_start l2

269+ , loc_end l1 == loc_end l2

270+ ]

271+ _ -> False

272+ ]

250

273

251instance Show a => Show (Item a) where

274instance Show a => Show (Item a) where

252− show Item{..} = "Item {_itemApp = " ++ show _itemApp ++ ", " ++

275+ showsPrec d Item{..} = showParen (d >= 11) ( showString "Item {"

253− "_itemEnv = " ++ show _itemEnv ++ ", " ++

276+ . field "_itemApp" _itemApp

277+ . field "_itemEnv" _itemEnv

254− "_itemSeverity = " ++ show _itemSeverity ++ ", " ++

278+ . field "_itemSeverity" _itemSeverity

255− "_itemThread = " ++ show _itemThread ++ ", " ++

279+ . field "_itemThread" _itemThread

256− "_itemHost = " ++ show _itemHost ++ ", " ++

280+ . field "_itemHost" _itemHost

257− "_itemProcess = " ++ show _itemProcess ++ ", " ++

281+ . field "_itemProcess" _itemProcess

258− "_itemPayload = " ++ show _itemPayload ++ ", " ++

282+ . field "_itemPayload" _itemPayload

259− "_itemMessage = " ++ show _itemMessage ++ ", " ++

283+ . field "_itemMessage" _itemMessage

260− "_itemTime = " ++ show _itemTime ++ ", " ++

284+ . field "_itemTime" _itemTime

261− "_itemNamespace = " ++ show _itemNamespace ++ ", " ++

285+ . field "_itemNamespace" _itemNamespace

262− "_itemLoc = " ++ show (LocShow <$> _itemLoc) ++ "}"

286+ . showString "_itemLoc = " . shows (LocShow <$> _itemLoc)

263−

287+ . showChar '}'

288+ )

289+ where

290+ field n v = showString n . showString " = " . shows v . showString ", "

264

291

265newtype LocShow = LocShow Loc

292newtype LocShow = LocShow Loc

266

293

267

294

268instance Show LocShow where

295instance Show LocShow where

269− show (LocShow Loc{..}) =

296+ showsPrec d (LocShow Loc{..}) = showParen (d >= 11) ( showString "Loc {"

270− "Loc {loc_filename = " ++ show loc_filename ++ ", " ++

297+ . field "loc_filename" loc_filename

271− "loc_package = " ++ show loc_package ++ ", " ++

298+ . field "loc_package" loc_package

272− "loc_module = " ++ show loc_module ++ ", " ++

299+ . field "loc_module" loc_module

273− "loc_start = " ++ show loc_start ++ ", " ++

300+ . field "loc_start" loc_start

274− "loc_end = " ++ show loc_end ++ "}"

301+ . showString "loc_end = " . shows loc_end

302+ . showChar '}'

303+ )

304+ where

305+ field n v = showString n . showString " = " . shows v . showString ", "

275

306

276

307

277instance ToJSON a => ToJSON (Item a) where

308instance ToJSON a => ToJSON (Item a) where

@@ -629,6 +660,7 @@ spawnScribeWorker (Scribe write _) queue = Async.async go

629data ScribeSettings = ScribeSettings {

660data ScribeSettings = ScribeSettings {

630 _scribeBufferSize :: Int

661 _scribeBufferSize :: Int

631 }

662 }

663+ deriving (Show, Eq)

632

664

633makeLenses ''ScribeSettings

665makeLenses ''ScribeSettings

634

666

katip/src/Katip/Scribes/Handle.hs+1

@@ -50,6 +50,7 @@ data ColorStrategy

50 -- ^ Whether to use color control chars in log output

51 | ColorIfTerminal

52 -- ^ Color if output is a terminal

53+ deriving (Show, Eq)

54-------------------------------------------------------------------------------

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

55-- | Logs to a file handle such as stdout, stderr, or a file. Contexts

56-- | Logs to a file handle such as stdout, stderr, or a file. Contexts

katip/test/Katip/Tests.hs+30−5

@@ -25,6 +25,7 @@ import qualified Data.Text.Lazy.Builder as B

25import Data.Time

26import Data.Time.Clock.POSIX

27import Language.Haskell.TH

28+import Lens.Micro (ASetter, (&), (.~))

28import System.Posix.Types

29import System.Posix.Types

29import Test.QuickCheck.Instances ()

30import Test.QuickCheck.Instances ()

30import Test.Tasty

31import Test.Tasty

@@ -41,6 +42,7 @@ tests = testGroup "Katip"

41 [

42 [

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

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

43 prop_json_cycle i

44 prop_json_cycle i

45+ , eqItemTests

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

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

45 textToSeverity(renderSeverity sev) === Just sev

47 textToSeverity(renderSeverity sev) === Just sev

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

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

@@ -245,11 +247,6 @@ deriving instance Arbitrary Namespace

245deriving instance Arbitrary Environment

247deriving instance Arbitrary Environment

246deriving instance Arbitrary ThreadIdText

248deriving instance Arbitrary ThreadIdText

247deriving instance Arbitrary CPid

249deriving instance Arbitrary CPid

248−#if !MIN_VERSION_base(4, 8, 0)

249−deriving instance Eq Loc

250−#endif

251−deriving instance Eq LogStr

252−deriving instance (Eq a) => Eq (Item a)

253

250

254

251

255-------------------------------------------------------------------------------

252-------------------------------------------------------------------------------

@@ -278,3 +275,31 @@ instance Arbitrary Severity where

278-------------------------------------------------------------------------------

275-------------------------------------------------------------------------------

279instance Arbitrary LogStr where

276instance Arbitrary LogStr where

280 arbitrary = LogStr . B.fromText <$> arbitrary

277 arbitrary = LogStr . B.fromText <$> arbitrary

278+

279+-------------------------------------------------------------------------------

280+-- Somewhat test whether all fields are taken into account in `==`

281+

282+#if !MIN_VERSION_template_haskell(2, 10, 0)

283+-- `testProperty` requires these instances

284+deriving instance Eq Loc

285+deriving instance Show Loc

286+#endif

287+

288+eqItemTests :: TestTree

289+eqItemTests = testGroup "Eq Item"

290+ [ testProperty "itemApp" $ prop_field itemApp

291+ , testProperty "itemEnv" $ prop_field itemEnv

292+ , testProperty "itemSeverity" $ prop_field itemSeverity

293+ , testProperty "itemThread" $ prop_field itemThread

294+ , testProperty "itemHost" $ prop_field itemHost

295+ , testProperty "itemProcess" $ prop_field itemProcess

296+ , testProperty "itemPayload" $ prop_field itemPayload

297+ , testProperty "itemMessage" $ prop_field itemMessage

298+ , testProperty "itemTime" $ prop_field itemTime

299+ , testProperty "itemNamespace" $ prop_field itemNamespace

300+ , testProperty "itemLoc" $ prop_field itemLoc

301+ ]

302+ where

303+ prop_field :: Eq a => ASetter (Item ()) (Item ()) a a -> Item () -> a -> a -> Bool

304+ prop_field field item f1 f2 =

305+ ((item & field .~ f1) == (item & field .~ f2)) == (f1 == f2)