diff options
-rw-r--r-- | src/Conftrack.hs | 24 | ||||
-rw-r--r-- | test/Main.hs | 6 |
2 files changed, 23 insertions, 7 deletions
diff --git a/src/Conftrack.hs b/src/Conftrack.hs index d6e68e2..0d3ffdd 100644 --- a/src/Conftrack.hs +++ b/src/Conftrack.hs @@ -12,6 +12,8 @@ module Conftrack , Warning(..) , runFetchConfig , readValue + , readOptionalValue + , readRequiredValue , readNested , SomeSource , ConfigError(..) @@ -54,8 +56,8 @@ runFetchConfig sources = do unusedWarnings <- collectUnused sources pure $ Right (result, origins, unusedWarnings <> warnings) -readValue :: ConfigValue a => Key -> FetchMonad a -readValue bareKey = do +readOptionalValue :: ConfigValue a => Key -> FetchMonad (Maybe a) +readOptionalValue bareKey = do (sources, prefix, origins, warnings) <- get let key = bareKey `prefixedWith` prefix @@ -69,12 +71,26 @@ readValue bareKey = do Left e -> Left e val <- case fmap (\(Right a) -> a) $ NonEmpty.filter isRight values of - [] -> lift $ throwE [NotPresent key] - val:_ -> pure val + [] -> pure (Nothing, Origin key "default value") + (value, origin):_ -> pure (Just value, origin) put (states, prefix, snd val : origins, warnings) pure (fst val) +readRequiredValue :: ConfigValue a => Key -> FetchMonad a +readRequiredValue key = + readOptionalValue key >>= \case + Nothing -> lift $ throwE [NotPresent key] + Just a -> pure a + +readValue :: ConfigValue a => a -> Key -> FetchMonad a +readValue defaultValue key = + readOptionalValue key >>= \case + Just a -> pure a + Nothing -> do + modify (\(states, prefix, origins, warnings) -> + (states, prefix, Origin key "default value" : origins, warnings)) + pure defaultValue firstMatchInSources :: Key -> [SomeSource] -> IO [(Either ConfigError (Value, Text), SomeSource)] firstMatchInSources _ [] = pure [] diff --git a/test/Main.hs b/test/Main.hs index 99b01d8..5c01f64 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -31,12 +31,12 @@ instance Arbitrary TestNested where instance Config TestFlat where readConfig = TestType - <$> readValue (Key ["foo"]) - <*> readValue (Key ["bar"]) + <$> readRequiredValue (Key ["foo"]) + <*> readRequiredValue (Key ["bar"]) instance Config TestNested where readConfig = TestNested - <$> readValue (Key ["foo"]) + <$> readRequiredValue (Key ["foo"]) <*> readNested (Key ["nested"]) testTypeToTrivial :: TestFlat -> SomeSource |