git.iko.soy/typeable/katip
on master help sign in
Fix location reporting in logLocM

- using implicit params and HasCallStack doesn't mix&match so just use HasCallStack everywhere - add a regression test - filter out all katip related locations and pick the first location that follows

commit913f6bb40ef2167df2e0f15da4fc46b4b866844a authorDomen Kožar <domen@dev.si> dateWed 14 Nov 2018, 20:00 (8 years ago) parent6b462d6
3 files changed+28−9
compare with master
unifiedsplit
katip/src/Katip/Core.hs+9−6 katip/src/Katip/Monadic.hs+12−3 katip/test/Katip/Tests.hs+7
katip/src/Katip/Core.hs+9−6
@@ -7,7 +7,6 @@
77{-# LANGUAGE FlexibleInstances #-}
88{-# LANGUAGE GADTs #-}
99{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10−{-# LANGUAGE ImplicitParams #-}
1110{-# LANGUAGE MultiParamTypeClasses #-}
1211{-# LANGUAGE OverloadedStrings #-}
1312{-# LANGUAGE RankNTypes #-}
@@ -997,11 +996,15 @@ liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
997996-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit
998997-- callstacks when available (GHC > 7.8).
999998#if MIN_VERSION_base(4, 8, 0)
1000−getLoc :: (?loc :: CallStack) => Maybe Loc
1001−getLoc = case getCallStack ?loc of
999+getLoc :: HasCallStack => Maybe Loc
1000+getLoc = case getCallStack callStack of
10021001 [] -> Nothing
1003− xs -> Just . toLoc . last $ xs
1002+ xs -> Just . toLoc . head $ filter filterKatip xs
10041003 where
1004+ filterKatip :: (String, SrcLoc) -> Bool
1005+ filterKatip (_, srcloc) = not $
1006+ "katip-" `isPrefixOf` srcLocPackage srcloc
1007+
10051008 toLoc :: (String, SrcLoc) -> Loc
10061009 toLoc (_, l) = Loc {
10071010 loc_filename = srcLocFile l
@@ -1032,7 +1035,7 @@ logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]
10321035
10331036
10341037-------------------------------------------------------------------------------
1035−-- | 'Loc'-tagged logging using implicit-callstacks when available.
1038+-- | 'Loc'-tagged logging using 'GHC.Stack' when available.
10361039--
10371040-- This function does not require template-haskell as it
10381041-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>
@@ -1043,7 +1046,7 @@ logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]
10431046--
10441047-- @logLoc obj mempty InfoS "Hello world"@
10451048#if MIN_VERSION_base(4, 8, 0)
1046−logLoc :: (Applicative m, LogItem a, Katip m, ?loc :: CallStack)
1049+logLoc :: (Applicative m, LogItem a, Katip m, HasCallStack)
10471050#else
10481051logLoc :: (Applicative m, LogItem a, Katip m)
10491052#endif
katip/src/Katip/Monadic.hs+12−3
@@ -68,6 +68,12 @@ import qualified Data.HashMap.Strict as HM
6868import Data.Semigroup as Semi
6969import Data.Sequence as Seq
7070import Data.Text (Text)
71+#if MIN_VERSION_base(4, 8, 0)
72+#if !MIN_VERSION_base(4, 9, 0)
73+import GHC.SrcLoc
74+#endif
75+import GHC.Stack
76+#endif
7177import Language.Haskell.TH
7278-------------------------------------------------------------------------------
7379import Katip.Core
@@ -235,7 +241,7 @@ deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)
235241-- very low level and you typically can use 'logTM' in its
236242-- place. Automatically supplies payload and namespace.
237243logItemM
238− :: (Applicative m, KatipContext m)
244+ :: (Applicative m, KatipContext m, HasCallStack)
239245 => Maybe Loc
240246 -> Severity
241247 -> LogStr
@@ -272,18 +278,21 @@ logTM = [| logItemM (Just $(getLocTH)) |]
272278
273279
274280-------------------------------------------------------------------------------
275−-- | 'Loc'-tagged logging when using <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>.
281+-- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks>.
276282-- Automatically supplies payload and namespace.
277283--
278284-- Same consideration as `logLoc` applies.
279285--
286+-- Location will be logged from the module that invokes 'logLocM' so
287+-- be aware that wrapping 'logLocM' will make location reporting useless.
288+--
280289-- This function does not require template-haskell. Using GHC <= 7.8 will result
281290-- in the emission of a log line without any location information.
282291-- Users using GHC <= 7.8 may want to use the template-haskell function
283292-- `logTM` for maximum compatibility.
284293--
285294-- @logLocM InfoS "Hello world"@
286−logLocM :: (Applicative m, KatipContext m)
295+logLocM :: (Applicative m, KatipContext m, HasCallStack)
287296 => Severity
288297 -> LogStr
289298 -> m ()
katip/test/Katip/Tests.hs+7
@@ -126,6 +126,13 @@ loggingTests = testGroup "logging"
126126 , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")
127127 , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")
128128 ]
129+ , testCase "Katip.Monadic.logLocM" $ do
130+ (le, items) <- recordingEnv
131+ runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ logLocM InfoS "basic log"
132+ _ <- closeScribes le
133+ loggedItems <- readTVarIO items
134+ let loc = _itemLoc (head loggedItems)
135+ fmap loc_module loc @?= Just "Katip.Tests"
129136 ]
130137 where
131138 recordingEnv :: IO (LogEnv, TVar [Item Object])