diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +0.5.0.4 +======= +* Loosen Win32 upper bound to run with GHC 8.2 on Windows. + 0.5.0.3 ======= * Add worked example of Katip/KatipContext to the haddocks. diff --git a/katip.cabal b/katip.cabal --- a/katip.cabal +++ b/katip.cabal @@ -1,5 +1,5 @@ name: katip -version: 0.5.0.3 +version: 0.5.0.4 synopsis: A structured logging framework. description: Katip is a structured logging framework. See README.md for more details. @@ -86,7 +86,7 @@ if flag(lib-Werror) ghc-options: -Werror if os(windows) - build-depends: Win32 >=2.3 && <2.5 + build-depends: Win32 >=2.3 && <2.6 exposed-modules: Katip.Compat else build-depends: unix >= 2.5 && <2.8 diff --git a/src/Katip/Core.hs b/src/Katip/Core.hs --- a/src/Katip/Core.hs +++ b/src/Katip/Core.hs @@ -180,7 +180,7 @@ ------------------------------------------------------------------------------- -- | Log message with Builder underneath; use '<>' to concat in O(1). newtype LogStr = LogStr { unLogStr :: B.Builder } - deriving (Generic, Show) + deriving (Generic, Show, Eq) instance IsString LogStr where fromString = LogStr . B.fromString @@ -247,31 +247,62 @@ } deriving (Generic, Functor) makeLenses ''Item +-- Manual instance because 'Loc' has no 'Eq' and 'Show' instances in old +-- versions of template-haskell (< 2.10) +instance Eq a => Eq (Item a) where + a == b = FT.and [ _itemApp a == _itemApp b + , _itemEnv a == _itemEnv b + , _itemSeverity a == _itemSeverity b + , _itemThread a == _itemThread b + , _itemHost a == _itemHost b + , _itemProcess a == _itemProcess b + , _itemPayload a == _itemPayload b + , _itemMessage a == _itemMessage b + , _itemTime a == _itemTime b + , _itemNamespace a == _itemNamespace b + , case (_itemLoc a, _itemLoc b) of + (Nothing, Nothing) -> True + (Just l1, Just l2) -> FT.and [ loc_filename l1 == loc_filename l2 + , loc_package l1 == loc_package l2 + , loc_module l1 == loc_module l2 + , loc_start l1 == loc_start l2 + , loc_end l1 == loc_end l2 + ] + _ -> False + ] instance Show a => Show (Item a) where - show Item{..} = "Item {_itemApp = " ++ show _itemApp ++ ", " ++ - "_itemEnv = " ++ show _itemEnv ++ ", " ++ - "_itemSeverity = " ++ show _itemSeverity ++ ", " ++ - "_itemThread = " ++ show _itemThread ++ ", " ++ - "_itemHost = " ++ show _itemHost ++ ", " ++ - "_itemProcess = " ++ show _itemProcess ++ ", " ++ - "_itemPayload = " ++ show _itemPayload ++ ", " ++ - "_itemMessage = " ++ show _itemMessage ++ ", " ++ - "_itemTime = " ++ show _itemTime ++ ", " ++ - "_itemNamespace = " ++ show _itemNamespace ++ ", " ++ - "_itemLoc = " ++ show (LocShow <$> _itemLoc) ++ "}" - + showsPrec d Item{..} = showParen (d >= 11) ( showString "Item {" + . field "_itemApp" _itemApp + . field "_itemEnv" _itemEnv + . field "_itemSeverity" _itemSeverity + . field "_itemThread" _itemThread + . field "_itemHost" _itemHost + . field "_itemProcess" _itemProcess + . field "_itemPayload" _itemPayload + . field "_itemMessage" _itemMessage + . field "_itemTime" _itemTime + . field "_itemNamespace" _itemNamespace + . showString "_itemLoc = " . shows (LocShow <$> _itemLoc) + . showChar '}' + ) + where + field n v = showString n . showString " = " . shows v . showString ", " newtype LocShow = LocShow Loc instance Show LocShow where - show (LocShow Loc{..}) = - "Loc {loc_filename = " ++ show loc_filename ++ ", " ++ - "loc_package = " ++ show loc_package ++ ", " ++ - "loc_module = " ++ show loc_module ++ ", " ++ - "loc_start = " ++ show loc_start ++ ", " ++ - "loc_end = " ++ show loc_end ++ "}" + showsPrec d (LocShow Loc{..}) = showParen (d >= 11) ( showString "Loc {" + . field "loc_filename" loc_filename + . field "loc_package" loc_package + . field "loc_module" loc_module + . field "loc_start" loc_start + . showString "loc_end = " . shows loc_end + . showChar '}' + ) + where + field n v = showString n . showString " = " . shows v . showString ", " instance ToJSON a => ToJSON (Item a) where @@ -629,6 +660,7 @@ data ScribeSettings = ScribeSettings { _scribeBufferSize :: Int } + deriving (Show, Eq) makeLenses ''ScribeSettings diff --git a/src/Katip/Scribes/Handle.hs b/src/Katip/Scribes/Handle.hs --- a/src/Katip/Scribes/Handle.hs +++ b/src/Katip/Scribes/Handle.hs @@ -50,6 +50,7 @@ -- ^ Whether to use color control chars in log output | ColorIfTerminal -- ^ Color if output is a terminal + deriving (Show, Eq) ------------------------------------------------------------------------------- -- | Logs to a file handle such as stdout, stderr, or a file. Contexts diff --git a/test/Katip/Tests.hs b/test/Katip/Tests.hs --- a/test/Katip/Tests.hs +++ b/test/Katip/Tests.hs @@ -25,6 +25,7 @@ import Data.Time import Data.Time.Clock.POSIX import Language.Haskell.TH +import Lens.Micro (ASetter, (&), (.~)) import System.Posix.Types import Test.QuickCheck.Instances () import Test.Tasty @@ -41,6 +42,7 @@ [ testProperty "JSON cycle Item" $ \(i :: Item ()) -> prop_json_cycle i + , eqItemTests , testProperty "renderSeverity/textToSeverity cycle" $ \sev -> textToSeverity(renderSeverity sev) === Just sev , testProperty "processIDToText/textToProcessID cycle" $ \pid -> @@ -245,11 +247,6 @@ deriving instance Arbitrary Environment deriving instance Arbitrary ThreadIdText deriving instance Arbitrary CPid -#if !MIN_VERSION_base(4, 8, 0) -deriving instance Eq Loc -#endif -deriving instance Eq LogStr -deriving instance (Eq a) => Eq (Item a) ------------------------------------------------------------------------------- @@ -278,3 +275,31 @@ ------------------------------------------------------------------------------- instance Arbitrary LogStr where arbitrary = LogStr . B.fromText <$> arbitrary + +------------------------------------------------------------------------------- +-- Somewhat test whether all fields are taken into account in `==` + +#if !MIN_VERSION_template_haskell(2, 10, 0) +-- `testProperty` requires these instances +deriving instance Eq Loc +deriving instance Show Loc +#endif + +eqItemTests :: TestTree +eqItemTests = testGroup "Eq Item" + [ testProperty "itemApp" $ prop_field itemApp + , testProperty "itemEnv" $ prop_field itemEnv + , testProperty "itemSeverity" $ prop_field itemSeverity + , testProperty "itemThread" $ prop_field itemThread + , testProperty "itemHost" $ prop_field itemHost + , testProperty "itemProcess" $ prop_field itemProcess + , testProperty "itemPayload" $ prop_field itemPayload + , testProperty "itemMessage" $ prop_field itemMessage + , testProperty "itemTime" $ prop_field itemTime + , testProperty "itemNamespace" $ prop_field itemNamespace + , testProperty "itemLoc" $ prop_field itemLoc + ] + where + prop_field :: Eq a => ASetter (Item ()) (Item ()) a a -> Item () -> a -> a -> Bool + prop_field field item f1 f2 = + ((item & field .~ f1) == (item & field .~ f2)) == (f1 == f2)