Namespace with phantom type

trace-dispatcher/examples/Examples/Aggregation.hs

@@ -41,7 +41,7 @@ baseStatsDocumented :: Documented Double
 baseStatsDocumented = Documented
   [
     DocMsg
-      ["BaseStats"]
+      (Namespace ["BaseStats"])
       [ ("measure", "This is the value of a single measurment")
       , ("sum", "This is the sum of all measurments")
       ]

trace-dispatcher/examples/Examples/Configuration.hs

@@ -26,7 +26,7 @@ instance LogFormatting TestMessage where
 
 testMessageDocumented :: Documented TestMessage
 testMessageDocumented = Documented
-  [ DocMsg ["TestMessage"] [] "just a text"
+  [ DocMsg (Namespace ["TestMessage"]) [] "just a text"
   ]
 
 tracers :: MonadIO m => m (Trace m TestMessage, Trace m TestMessage, Trace m TestMessage)

trace-dispatcher/examples/Examples/DataPoint.hs

@@ -33,8 +33,8 @@ instance A.ToJSON BaseStats where
 instance Show DataPoint where
   show (DataPoint a) = toString $ A.encode a
 
-namesForBaseStats :: BaseStats -> Namespace
-namesForBaseStats _ = ["BaseStats"]
+namesForBaseStats :: BaseStats -> Namespace BaseStats
+namesForBaseStats _ = Namespace ["BaseStats"]
 
 emptyStats :: BaseStats
 emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0

trace-dispatcher/examples/Examples/EKG.hs

@@ -10,7 +10,7 @@ import           System.Remote.Monitoring (forkServer)
 
 
 countDocumented :: Documented Int
-countDocumented = Documented [DocMsg ["Count"] [("count", "an integer")] ""]
+countDocumented = Documented [DocMsg (Namespace ["Count"]) [("count", "an integer")] ""]
 
 testEKG :: IO ()
 testEKG = do

trace-dispatcher/examples/Examples/TestObjects.hs

@@ -148,13 +148,13 @@ instance LogFormatting (TraceForgeEvent LogBlock) where
 traceForgeEventDocu :: Documented (TraceForgeEvent LogBlock)
 traceForgeEventDocu = Documented
   [ DocMsg
-      ["TraceStartLeadershipCheck"]
+      (Namespace ["TraceStartLeadershipCheck"])
       []
       "Start of the leadership check\n\
         \\n\
         \We record the current slot number."
   , DocMsg
-      ["TraceSlotIsImmutable"]
+      (Namespace ["TraceSlotIsImmutable"])
       []
       "Leadership check failed: the tip of the ImmutableDB inhabits the\n\
         \current slot\n\
@@ -174,7 +174,7 @@ traceForgeEventDocu = Documented
         \\n\
         \See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>"
   , DocMsg
-    ["TraceBlockFromFuture"]
+    (Namespace ["TraceBlockFromFuture"])
     []
     "Leadership check failed: the current chain contains a block from a slot\n\
       \/after/ the current slot\n\
@@ -191,9 +191,9 @@ withSeverityTraceForgeEvent :: Monad m =>
      Trace m (TraceForgeEvent blk)
   -> Trace m (TraceForgeEvent blk)
 withSeverityTraceForgeEvent = withSeverity (\case
-    TraceStartLeadershipCheck {} -> Info
-    TraceSlotIsImmutable {}      -> Error
-    TraceBlockFromFuture {}      -> Error
+    Namespace ["TraceStartLeadershipCheck"] -> Info
+    Namespace ["TraceSlotIsImmutable"]      -> Error
+    Namespace ["TraceBlockFromFuture"]      -> Error
   )
 
 message1 :: TraceForgeEvent LogBlock

trace-dispatcher/examples/Examples/Trivial.hs

@@ -47,7 +47,3 @@ test2 = do
     traceWith (appendName "Inner3" simpleTracerC3) message4
     traceWith (appendName "cont1" $ appendName "cont2" $ appendName "cont3" simpleTracerC2) message1
 
-loSeverity :: TraceForgeEvent LogBlock -> SeverityS
-loSeverity TraceStartLeadershipCheck {} = Warning
-loSeverity TraceSlotIsImmutable {}      = Error
-loSeverity TraceBlockFromFuture {}      = Error

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

@@ -52,17 +52,17 @@ configureTracers config (Documented documented) tracers = do
     configureAllTrace control (Trace tr) =
       mapM
         (\ DocMsg {..} -> T.traceWith tr (
-                              emptyLoggingContext {lcNamespace = dmNamespace}
+                              emptyLoggingContext {lcNamespace = unNS dmNamespace}
                             , Left control))
         documented
 
 -- | Switch off any message of a particular tracer based on the configuration.
 -- If the top tracer is silent and no subtracer is not silent, then switch it off
 maybeSilent :: forall m a. (MonadIO m) =>
-     Namespace
+     Namespace a
   -> Trace m a
   -> m (Trace m a)
-maybeSilent ns tr = do
+maybeSilent (Namespace ns) tr = do
     ref  <- liftIO (newIORef False)
     pure $ Trace $ T.arrow $ T.emit $ mkTrace ref
   where
@@ -82,9 +82,9 @@ maybeSilent ns tr = do
       T.traceWith (unpackTrace tr) (lc,  Left other)
 
 -- If the top tracer is silent and any subtracer is not silent, it is not
-isSilentTracer :: TraceConfig -> Namespace -> Bool
+isSilentTracer :: TraceConfig -> [Text] -> Bool
 isSilentTracer tc ns =
-    if getSeverity tc ns == SeverityF Nothing
+    if getSeverity tc  ns == SeverityF Nothing
       then
         let entries = filter (\(nsf,_opts) -> isPrefixOf ns nsf) $ Map.toList (tcOptions tc)
             blockers = filter (\(_nsf,opts) -> null (filter filterOpts opts)) entries
@@ -99,7 +99,7 @@ isSilentTracer tc ns =
 -- In this way construct a trace transformer with a config value
 withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) =>
      String
-  -> (TraceConfig -> Namespace -> m b)
+  -> (TraceConfig -> [Text] -> m b)
   -> (Maybe b -> Trace m c -> m (Trace m a))
   -> Trace m c
   -> m (Trace m a)
@@ -108,7 +108,7 @@ withNamespaceConfig name extract withConfig tr = do
     pure $ Trace $ T.arrow $ T.emit $ mkTrace ref
   where
     mkTrace ::
-         IORef (Either (Map.Map Namespace b, Maybe b) b)
+         IORef (Either (Map.Map [Text] b, Maybe b) b)
       -> (LoggingContext, Either TraceControl a)
       -> m ()
     mkTrace ref (lc, Right a) = do
@@ -276,7 +276,7 @@ withLimitersFromConfig tr trl = do
     getLimiter ::
          IORef (Map.Map Text (Limiter m a))
       -> TraceConfig
-      -> Namespace
+      -> [Text]
       -> m (Maybe (Limiter m a))
     getLimiter stateRef config ns =
       case getLimiterSpec config ns of
@@ -313,32 +313,32 @@ withLimitersFromConfig tr trl = do
 --------------------------------------------------------
 
 -- | If no severity can be found in the config, it is set to Warning
-getSeverity :: TraceConfig -> Namespace -> SeverityF
+getSeverity :: TraceConfig -> [Text] -> SeverityF
 getSeverity config ns =
     fromMaybe (SeverityF (Just Warning)) (getOption severitySelector config ns)
   where
     severitySelector :: ConfigOption -> Maybe SeverityF
     severitySelector (ConfSeverity s) = Just s
     severitySelector _              = Nothing
 
-getSeverity' :: Applicative m => TraceConfig -> Namespace -> m SeverityF
+getSeverity' :: Applicative m => TraceConfig -> [Text] -> m SeverityF
 getSeverity' config ns = pure $ getSeverity config ns
 
 -- | If no details can be found in the config, it is set to DNormal
-getDetails :: TraceConfig -> Namespace -> DetailLevel
+getDetails :: TraceConfig -> [Text] -> DetailLevel
 getDetails config ns =
     fromMaybe DNormal (getOption detailSelector config ns)
   where
     detailSelector :: ConfigOption -> Maybe DetailLevel
     detailSelector (ConfDetail d) = Just d
     detailSelector _            = Nothing
 
-getDetails' :: Applicative m => TraceConfig -> Namespace -> m DetailLevel
+getDetails' :: Applicative m => TraceConfig -> [Text] -> m DetailLevel
 getDetails' config ns = pure $ getDetails config ns
 
 -- | If no backends can be found in the config, it is set to
 -- [EKGBackend, Forwarder, Stdout HumanFormatColoured]
-getBackends :: TraceConfig -> Namespace -> [BackendConfig]
+getBackends :: TraceConfig -> [Text] -> [BackendConfig]
 getBackends config ns =
     fromMaybe [EKGBackend, Forwarder, Stdout HumanFormatColoured]
       (getOption backendSelector config ns)
@@ -347,19 +347,19 @@ getBackends config ns =
     backendSelector (ConfBackend s) = Just s
     backendSelector _             = Nothing
 
-getBackends' :: Applicative m => TraceConfig -> Namespace -> m [BackendConfig]
+getBackends' :: Applicative m => TraceConfig -> [Text] -> m [BackendConfig]
 getBackends' config ns = pure $ getBackends config ns
 
 -- | May return a limiter specification
-getLimiterSpec :: TraceConfig -> Namespace -> Maybe (Text, Double)
+getLimiterSpec :: TraceConfig -> [Text] -> Maybe (Text, Double)
 getLimiterSpec config ns = getOption limiterSelector config ns
   where
     limiterSelector :: ConfigOption -> Maybe (Text, Double)
     limiterSelector (ConfLimiter f) = Just (intercalate "." ns, f)
     limiterSelector _               = Nothing
 
 -- | Searches in the config to find an option
-getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> Namespace -> Maybe a
+getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a
 getOption sel config [] =
   case Map.lookup [] (tcOptions config) of
     Nothing -> Nothing

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

@@ -31,7 +31,7 @@ import           Cardano.Logging.Types
 defaultConfig :: TraceConfig
 defaultConfig = emptyTraceConfig {
   tcOptions = Map.fromList
-    [([] :: Namespace,
+    [([] :: [Text],
          [ ConfSeverity (SeverityF (Just Info))
          , ConfDetail DNormal
          , ConfBackend [Stdout HumanFormatColoured]
@@ -68,13 +68,13 @@ mergeWithDefault fileConf defaultConf =
         else tcResourceFrequency defaultConf)
 
 mergeOptionsWithDefault ::
-     Map.Map Namespace [ConfigOption]
-  -> Map.Map Namespace [ConfigOption]
-  -> Map.Map Namespace [ConfigOption]
+     Map.Map [Text] [ConfigOption]
+  -> Map.Map [Text] [ConfigOption]
+  -> Map.Map [Text] [ConfigOption]
 mergeOptionsWithDefault fileOpts defaultOpts =
     foldr mergeOptsNs defaultOpts (Map.toList fileOpts)
   where
-    mergeOptsNs :: (Namespace,[ConfigOption]) -> Map.Map Namespace [ConfigOption] -> Map.Map Namespace [ConfigOption]
+    mergeOptsNs :: ([Text],[ConfigOption]) -> Map.Map [Text] [ConfigOption] -> Map.Map [Text] [ConfigOption]
     mergeOptsNs (ns,opts) into =
       case Map.lookup ns into of
         Nothing -> Map.insert ns opts into

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

@@ -65,17 +65,17 @@ documentTracers (Documented documented) tracers = do
     docTrace docIdx dc (Trace tr) =
       mapM_
         (\ (DocMsg {..}, idx) ->
-            T.traceWith tr (emptyLoggingContext {lcNamespace = dmNamespace},
+            T.traceWith tr (emptyLoggingContext {lcNamespace = unNS dmNamespace},
                             Left (Document idx dmMarkdown dmMetricsMD dc)))
         docIdx
 
 showT :: Show a => a -> Text
 showT = pack . show
 
-addDocumentedNamespace  :: Namespace -> Documented a -> Documented b
-addDocumentedNamespace  ns (Documented list) =
+addDocumentedNamespace  :: Namespace a -> Documented a -> Documented b
+addDocumentedNamespace  (Namespace ns) (Documented list) =
   Documented $ map
-    (\ dm@DocMsg {} -> dm {dmNamespace = ns ++ dmNamespace dm})
+    (\ dm@DocMsg {} -> dm {dmNamespace = Namespace (ns ++ unNS (dmNamespace dm))})
     list
 
 addDocs :: Documented a -> Documented a -> Documented a
@@ -177,7 +177,7 @@ docItDatapoint _backend (LoggingContext {..},
                         Nothing -> emptyLogDoc mdText []))
         docMap)
 
-generateTOC :: [Namespace] -> [Namespace] -> [Namespace] -> Builder
+generateTOC :: [[Text]] -> [[Text]] -> [[Text]] -> Builder
 generateTOC traces metrics datapoints =
        generateTOCTraces
     <> generateTOCMetrics
@@ -192,7 +192,7 @@ generateTOC traces metrics datapoints =
     generateTOCDatapoints =
       fromText "\n\n## [Datapoints](#datapoints)"
       <> mconcat (reverse (fst (foldl namespaceToToc ([], []) datapoints)))
-    namespaceToToc :: ([Builder], Namespace) -> Namespace -> ([Builder], Namespace)
+    namespaceToToc :: ([Builder], [Text]) -> [Text]-> ([Builder], [Text])
     namespaceToToc (builders, context) ns =
       let ref = namespaceRefBuilder ns
           ns' = if take 2 ns == ["Cardano", "Node"]
@@ -215,10 +215,10 @@ generateTOC traces metrics datapoints =
           in namespaceToTocWithContext (builders, context') ns'' ref
 
     namespaceToTocWithContext ::
-         ([Builder], Namespace)
-      -> Namespace
+         ([Builder], [Text])
+      -> [Text]
       -> Builder
-      -> ([Builder], Namespace)
+      -> ([Builder], [Text])
     namespaceToTocWithContext (builders, context) ns ref =
       case ns of
         [single] ->   ((fromText "\n"
@@ -239,7 +239,7 @@ generateTOC traces metrics datapoints =
               (builder : builders, context ++ [hdn]) tln ref
         [] -> error "inpossible"
 
-    splitToNS :: Namespace -> Namespace
+    splitToNS :: [Text] -> [Text]
     splitToNS [sym] = T.split (== '.') sym
 
 
@@ -254,7 +254,7 @@ generateTOC traces metrics datapoints =
     namespaceRefBuilder ns = mconcat (map (fromText . toLower ) ns)
 
 
-buildersToText :: [(Namespace, DocuResult)] -> TraceConfig -> IO Text
+buildersToText :: [([Text], DocuResult)] -> TraceConfig -> IO Text
 buildersToText builderList configuration = do
   time <- getZonedTime
   let traceBuilders = sortBy (\ (l,_) (r,_) -> compare l r)
@@ -295,7 +295,7 @@ buildersToText builderList configuration = do
 documentMarkdown ::
      Documented a
   -> [Trace IO a]
-  -> IO [(Namespace, DocuResult)]
+  -> IO [([Text], DocuResult)]
 documentMarkdown (Documented documented) tracers = do
     DocCollector docRef <- documentTracers (Documented documented) tracers
     items <- fmap Map.toList (liftIO (readIORef docRef))
@@ -326,39 +326,39 @@ documentMarkdown (Documented documented) tracers = do
 
     documentMetrics :: [LogDoc] -> [([Text], DocuResult)]
     documentMetrics logDocs =
-      let nameCommentNamespaceList = 
+      let nameCommentNamespaceList =
             concatMap (\ld -> zip (Map.toList (ldMetricsDoc ld)) (repeat (ldNamespace ld))) logDocs
           sortedNameCommentNamespaceList =
             sortBy (\a b -> compare ((fst . fst) a) ((fst . fst) b)) nameCommentNamespaceList
           groupedNameCommentNamespaceList =
             groupBy (\a b -> (fst . fst) a == (fst . fst) b) sortedNameCommentNamespaceList
       in map documentMetrics' groupedNameCommentNamespaceList
 
-    documentMetrics' :: [((Text, Text), [Namespace])] -> ([Text], DocuResult)
+    documentMetrics' :: [((Text, Text), [[Text]])] -> ([Text], DocuResult)
     documentMetrics' ncns@(((name, comment), _) : _tail) =
-      ([name], DocuMetric 
+      ([name], DocuMetric
               $ mconcat $ intersperse(fromText "\n\n")
                     [ metricToBuilder (name,comment)
                     , namespacesMetricsBuilder (nub (concatMap snd ncns))
                     ])
 
-    namespacesBuilder :: [Namespace] -> Builder
+    namespacesBuilder :: [[Text]] -> Builder
     namespacesBuilder [ns] = namespaceBuilder ns
     namespacesBuilder []   = fromText "__Warning__: Namespace missing"
     namespacesBuilder nsl  =
       mconcat (intersperse (singleton '\n')(map namespaceBuilder nsl))
 
-    namespaceBuilder :: Namespace -> Builder
+    namespaceBuilder :: [Text] -> Builder
     namespaceBuilder ns = fromText "### " <>
       mconcat (intersperse (singleton '.') (map fromText ns))
 
-    namespacesMetricsBuilder :: [Namespace] -> Builder
+    namespacesMetricsBuilder :: [[Text]] -> Builder
     namespacesMetricsBuilder [ns] = fromText "Dispatched by: \n" <> namespaceMetricsBuilder ns
     namespacesMetricsBuilder []   = mempty
     namespacesMetricsBuilder nsl  = fromText "Dispatched by: \n" <>
       mconcat (intersperse (singleton '\n')(map namespaceMetricsBuilder nsl))
 
-    namespaceMetricsBuilder :: Namespace -> Builder
+    namespaceMetricsBuilder :: [Text] -> Builder
     namespaceMetricsBuilder ns = mconcat (intersperse (singleton '.') (map fromText ns))
 
 
@@ -415,7 +415,7 @@ documentMarkdown (Documented documented) tracers = do
                  l))
 
     -- metricsBuilder :: (Text, Text) -> [(Text, Builder)]
-    -- metricsBuilder (name, t) = (name, metricFormatToText t) 
+    -- metricsBuilder (name, t) = (name, metricFormatToText t)
 
     metricToBuilder :: (Text, Text) -> Builder
     metricToBuilder (name, text) =