trace-dispatcher: showT

disable warning for ghc 9
Fix cabal file
Change of own messages

Author: jutaro

trace-dispatcher/src/Cardano/Logging.hs

@@ -15,4 +15,5 @@ import           Cardano.Logging.Tracer.EKG as X
 import           Cardano.Logging.Tracer.Forward as X
 import           Cardano.Logging.Tracer.Standard as X
 import           Cardano.Logging.Types as X
+import           Cardano.Logging.Utils as X
 import           Control.Tracer as X hiding (Tracer, nullTracer, traceWith)

trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs

@@ -25,38 +25,32 @@ module Cardano.Logging.DocuGenerator (
   , DocTracer
 ) where
 
+import           Prelude hiding (lines, unlines)
 
 import           Data.IORef (modifyIORef, newIORef, readIORef)
 import           Data.List (groupBy, intersperse, nub, sortBy)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe, mapMaybe)
-import           Data.Text (Text, pack, toLower)
-import qualified Data.Text as T
+import           Data.Text (Text, lines, split, toLower, unlines)
 import           Data.Text.Internal.Builder (toLazyText)
 import           Data.Text.Lazy (toStrict)
 import           Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton)
 import           Data.Time (getZonedTime)
 
 import           Cardano.Logging.Types
 import           Control.Monad.IO.Class (MonadIO, liftIO)
-import qualified Control.Tracer as T
+import qualified Control.Tracer as TR
 
+import           Cardano.Logging.Utils (showT)
 import           Trace.Forward.Utils.DataPoint (DataPoint (..))
 
-
-
 -- | Convenience function for adding a namespace prefix to a documented
 addDocumentedNamespace  :: [Text] -> Documented a -> Documented a
 addDocumentedNamespace  tl (Documented list) =
   Documented $ map
     (\ dm@DocMsg {} -> dm {dmNamespace = nsReplacePrefix (dmNamespace dm) tl})
     list
 
--- | Convenience function
-{-# INLINE showT #-}
-showT :: Show a => a -> Text
-showT = pack . show
-
 data DocuResult =
   DocuTracer Builder
   | DocuMetric Builder
@@ -294,7 +288,7 @@ documentTracersRun tracers = do
                             , ldPrivacyCoded  = privacyFor ns Nothing
                             , ldDetailsCoded  = detailsFor ns Nothing
                           }))
-            T.traceWith tr (emptyLoggingContext {lcNSInner = nsGetInner ns},
+            TR.traceWith tr (emptyLoggingContext {lcNSInner = nsGetInner ns},
                             Left (TCDocument idx dc)))
         nsIdx
 
@@ -303,7 +297,7 @@ documentTracersRun tracers = do
 docTracer :: MonadIO m =>
      BackendConfig
   -> Trace m FormattedMessage
-docTracer backendConfig = Trace $ T.arrow $ T.emit output
+docTracer backendConfig = Trace $ TR.arrow $ TR.emit output
   where
     output p@(_, Left TCDocument {}) =
       docIt backendConfig p
@@ -312,7 +306,7 @@ docTracer backendConfig = Trace $ T.arrow $ T.emit output
 docTracerDatapoint :: MonadIO m =>
      BackendConfig
   -> Trace m DataPoint
-docTracerDatapoint backendConfig = Trace $ T.arrow $ T.emit output
+docTracerDatapoint backendConfig = Trace $ TR.arrow $ TR.emit output
   where
     output p@(_, Left TCDocument {}) =
       docItDatapoint backendConfig p
@@ -530,7 +524,7 @@ generateTOC dt traces metrics datapoints =
         [] -> error "inpossible"
 
     splitToNS :: [Text] -> [Text]
-    splitToNS [sym] = T.split (== '.') sym
+    splitToNS [sym] = split (== '.') sym
     splitToNS other = other
 
 
@@ -562,4 +556,4 @@ accentuated :: Text -> Builder
 accentuated t = if t == ""
                   then fromText "\n"
                   else fromText "\n"
-                        <> fromText (T.unlines $ map ("> " <>) (T.lines t))
+                        <> fromText (unlines $ map ("> " <>) (lines t))

trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs

@@ -46,9 +46,9 @@ instance LogFormatting TraceDispatcherMessage where
     ". Suppressed " <> pack (show num) <> " messages."
   forHuman (RememberLimiting txt num) = "Frequency limiting still active for " <> txt <>
     ". Suppressed so far " <> pack (show num) <> " messages."
-  forHuman (UnknownNamespace nsUnknown nsLegal qk) = "Unknown namespace detected "
-    <> intercalate (singleton '.') nsUnknown <> ". Used for querying " <> (pack . show) qk
-    <> " a legal namespace would be " <> intercalate (singleton '.') nsLegal <> "."
+  forHuman (UnknownNamespace nsPrefixNS nsInnerNS qk) = "Unknown namespace detected "
+    <> intercalate (singleton '.') (nsPrefixNS ++ nsInnerNS)
+    <> ". Used for querying " <> (pack . show) qk <> "."
   forHuman (TracerInfo silent noMetrics allTracers) = "The tracing system has silent the following tracer,"
     <> " as they will never have any output according to the current config: "
     <> intercalate (singleton ' ') silent <> ". The following tracers will not emit metrics "

trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs

@@ -71,6 +71,7 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do
                       trForward
                       Nothing
                       (Trace T.nullTracer)
+                    >>= addContextAndFilter
 
     -- handle the messages
     !messageTrace <- withBackendsFromConfig (backendsAndFormat trStdout trForward)
@@ -92,7 +93,7 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do
     pure (messageTrace <> metricsTrace)
 
   where
-    addContextAndFilter :: Trace IO evt1 -> IO (Trace IO evt1)
+    addContextAndFilter :: MetaTrace a => Trace IO a -> IO (Trace IO a)
     addContextAndFilter tr = do
       tr'  <- withDetailsFromConfig tr
       tr'' <- filterSeverityFromConfig tr'

trace-dispatcher/src/Cardano/Logging/Utils.hs

@@ -1,14 +1,21 @@
 {-# LANGUAGE LambdaCase #-}
 
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+-- showHex needs to be a show instance on ghc8, but not any more on ghc9
+
 module Cardano.Logging.Utils (
     runInLoop
   , uncurry3
   , mapSnd
+  , showT
+  , showTHex
   ) where
 
 import           Control.Concurrent (threadDelay)
 import           Control.Exception (SomeAsyncException (..), fromException, tryJust)
 import           Control.Tracer (stdoutTracer, traceWith)
+import qualified Data.Text as T
+import           Numeric (showHex)
 
 -- | Run monadic action in a loop. If there's an exception, it will re-run
 --   the action again, after pause that grows.
@@ -39,3 +46,13 @@ uncurry3 f (a,b,c) = f a b c
 
 mapSnd :: (a -> b) -> (c, a) -> (c, b)
 mapSnd f (x,y) = (x,f y)
+
+-- | Convenience function
+{-# INLINE showT #-}
+showT :: Show a => a -> T.Text
+showT = T.pack . show
+
+-- | Convenience function
+{-# INLINE showTHex #-}
+showTHex :: (Integral a, Show a) => a -> T.Text
+showTHex i = T.pack (showHex i [])

trace-dispatcher/trace-dispatcher.cabal

@@ -13,14 +13,15 @@ maintainer:             operations@iohk.io
 license:                Apache-2.0
 license-files:          LICENSE
                         NOTICE
-extra-source-files:     CHANGELOG.md
+extra-doc-files:        CHANGELOG.md
                         README.md
                         doc/trace-dispatcher.md
 
 common project-config
   default-language:     Haskell2010
 
 library
+  import:               project-config
   hs-source-dirs:     src
   exposed-modules:    Cardano.Logging
                       Cardano.Logging.Configuration
@@ -129,6 +130,7 @@ executable trace-dispatcher-examples
                         -Wno-incomplete-patterns
 
 test-suite trace-dispatcher-test
+  import:              project-config
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             trace-dispatcher-test.hs