pretty-printing of config value sources

1 files changed, 22 insertions, 8 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 []