pretty-printing of config value sources

3 files changed, 74 insertions, 10 deletions

diff --git a/src/Conftrack.hs b/src/Conftrack.hs
index 6f030a6..fd718d4 100644
--- a/src/Conftrack.hs
+++ b/src/Conftrack.hs
@@ -38,6 +38,8 @@ import Data.Either (isRight)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Maybe (isJust, mapMaybe)
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
 
 
 class Config a where
@@ -46,7 +48,7 @@ class Config a where
 data FetcherState = FetcherState
   { fetcherSources :: [SomeSource]
   , fetcherPrefix :: [KeyPart]
-  , fetcherOrigins :: [Origin]
+  , fetcherOrigins :: Map Key [Origin]
   , fetcherWarnings :: [Warning]
   , fetcherErrors :: [ConfigError]
   }
@@ -66,7 +68,12 @@ instance Applicative Fetch where
     pure (f a b, s3)
 
 
-runFetchConfig :: forall a. Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
+runFetchConfig
+  :: forall a. Config a
+  => NonEmpty SomeSource
+  -> IO (Either
+         [ConfigError]
+         (a, Map Key [Origin], [Warning]))
 runFetchConfig sources = do
   let (Fetch m) = readConfig @a
 
@@ -86,7 +93,7 @@ configKeysOf = do
 
 
 
-readOptionalValue :: ConfigValue a => Key -> Fetch (Maybe a)
+readOptionalValue :: forall a. ConfigValue a => Key -> Fetch (Maybe a)
 readOptionalValue bareKey = Fetch $ \s1@FetcherState{..} -> do
 
   let key = bareKey `prefixedWith` fetcherPrefix
@@ -96,14 +103,15 @@ readOptionalValue bareKey = Fetch $ \s1@FetcherState{..} -> do
   let (maybeValues, sources) = unzip stuff
 
   let values = maybeValues <&> \case
-        Right (val, text) -> fromConfig val <&> (\val -> (val, Origin key text))
+        Right (val, text) -> fromConfig @a val <&> (\a -> (a, [Origin a text]))
         Left e -> Left e
 
   val <- case fmap (\(Right a) -> a) $ filter isRight values of
-    [] -> pure (Nothing, Origin key "default value")
+    [] -> pure (Nothing, [])
     (value, origin):_ -> pure (Just value, origin)
 
-  pure (fst val, s1 { fetcherSources = sources, fetcherOrigins = snd val : fetcherOrigins })
+  pure (fst val, s1 { fetcherSources = sources
+                    , fetcherOrigins = M.insertWith (<>) key (snd val) fetcherOrigins })
 
 
 readRequiredValue :: ConfigValue a => Key -> Fetch a
@@ -126,8 +134,14 @@ readValue defaultValue key =
   in
     Fetch (m >=> (\(a, s) -> case a of
       Just val -> pure (val, s)
-      Nothing -> do
-        pure (defaultValue, s { fetcherOrigins = Origin (key `prefixedWith` fetcherPrefix s) "default value" :  fetcherOrigins s })))
+      Nothing ->
+        let
+          origins = M.insertWith (<>)
+            (key `prefixedWith` fetcherPrefix s)
+            [Origin defaultValue "default value"]
+            (fetcherOrigins s)
+        in
+          pure (defaultValue, s { fetcherOrigins = origins })))
 
 firstMatchInSources :: Key -> [SomeSource] -> IO [(Either ConfigError (Value, Text), SomeSource)]
 firstMatchInSources _ [] = pure []
diff --git a/src/Conftrack/Pretty.hs b/src/Conftrack/Pretty.hs
new file mode 100644
index 0000000..8a11204
--- /dev/null
+++ b/src/Conftrack/Pretty.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Conftrack.Pretty where
+
+
+import Conftrack.Value (Origin (..), ConfigError, ConfigValue (..))
+import Conftrack (Warning)
+import Data.Map (Map)
+import Conftrack.Value (Key)
+import qualified Data.Map.Strict as M
+import qualified Data.Text.IO as T
+import qualified Data.Text as T
+import Data.List (sortOn)
+import GHC.Exts (groupWith)
+
+
+printConfigErrors :: [ConfigError] -> IO ()
+printConfigErrors = mapM_ print
+
+-- TODO: perhaps sort it by source, not by key?
+-- also, shadowed values are currently never read
+printConfigOrigins :: Map Key [Origin] -> IO ()
+printConfigOrigins =
+  mapM_ (T.putStrLn . prettyOrigin)
+  . groupWith ((\(Origin _ s) -> s) . head . snd)
+  . filter (not . null . snd)
+  . M.toList
+  where prettyOrigin origins =
+          T.concat $ originSource (snd (head origins)) : fmap prettyKey origins
+        prettyKey (key, []) = "\n  " <> T.pack (show key)
+        prettyKey (key, (Origin val _):shadowed) = T.concat $
+          ["\n  ", T.pack $ show key, " = ", prettyValue val]
+          <> fmap (\(Origin _ text) -> "\n    (occurrance in "<>text<>" shadowed)") shadowed
+        originSource [] = "default value"
+        originSource (Origin _ text:_) = text
+
+
+
+printConfigWarnings :: [Warning] -> IO ()
+printConfigWarnings = mapM_ print
diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs
index fef8f87..50e4e30 100644
--- a/src/Conftrack/Value.hs
+++ b/src/Conftrack/Value.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DefaultSignatures #-}
 
 module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where
 
@@ -58,9 +59,15 @@ data ConfigError =
 
 class ConfigValue a where
   fromConfig :: Value -> Either ConfigError a
+  prettyValue :: a -> Text
 
-data Origin = Origin Key Text
-  deriving Show
+  default prettyValue :: Show a => a -> Text
+  prettyValue = T.pack . show
+
+data Origin = forall a. ConfigValue a => Origin a Text
+
+instance Show Origin where
+  show (Origin a text) = "Origin " <> T.unpack (prettyValue a) <> " " <> T.unpack text
 
 withString :: (BS.ByteString -> Either ConfigError a) -> Value -> Either ConfigError a
 withString f (ConfigString a) = f a
@@ -89,6 +96,9 @@ instance ConfigValue a => ConfigValue (Maybe a) where
   fromConfig ConfigNull = Right Nothing
   fromConfig just = fmap Just (fromConfig just)
 
+  prettyValue Nothing = "null"
+  prettyValue (Just a) = prettyValue a
+
 instance ConfigValue OsPath where
   fromConfig = \case
     (ConfigString text) -> stringToPath text