diff options
Diffstat (limited to '')
| -rw-r--r-- | src/Conftrack.hs | 30 | ||||
| -rw-r--r-- | src/Conftrack/Pretty.hs | 40 | ||||
| -rw-r--r-- | src/Conftrack/Value.hs | 14 |
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 |