diff options
| -rw-r--r-- | src/Conftrack.hs | 35 | ||||
| -rw-r--r-- | test/Main.hs | 47 |
2 files changed, 65 insertions, 17 deletions
diff --git a/src/Conftrack.hs b/src/Conftrack.hs index b272e3f..e1652b1 100644 --- a/src/Conftrack.hs +++ b/src/Conftrack.hs @@ -162,16 +162,35 @@ readNested (Key prefix') = Fetch $ \s1 -> do (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix' }) pure (config, s2 { fetcherPrefix = fetcherPrefix s1 }) -readNestedOptional :: forall a. Config a => Key -> Fetch (Maybe a) +readNestedOptional :: forall a. (Show a, Config a) => Key -> Fetch (Maybe a) readNestedOptional (Key prefix) = Fetch $ \s1 -> do let (Fetch nested) = readConfig @a - (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix }) - - if null (fetcherErrors s2) - then pure (Just config, s2 { fetcherPrefix = fetcherPrefix s1 }) - -- TODO: resetting errors like this makes configKeysOf less useful. Perhaps move nested errors to warnings? - else pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1 - , fetcherErrors = fetcherErrors s1 }) + let nestedState = s1 + { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix + , fetcherOrigins = [] -- pass an empy list so we can check if at least one element was present + , fetcherErrors = [] + } + + (config, s2) <- nested nestedState + + let origins = fetcherOrigins s1 <> fetcherOrigins s2 + + -- none of the keys present? then return Nothing & produce no errors + if length (fetcherOrigins s2) == length (filter (\case {NotPresent _ -> True; _ -> False}) (fetcherErrors s2)) + && length (fetcherOrigins s2) == length (fetcherErrors s2) then + pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1, fetcherErrors = fetcherErrors s1, fetcherOrigins = fetcherOrigins s1 }) + else + -- any other errors? if so, forward those + if not (null (fetcherErrors s2)) then + pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1 + , fetcherOrigins = origins + , fetcherErrors = fetcherErrors s2 <> fetcherErrors s1 + }) + else + -- success! + pure (Just config, s2 { fetcherPrefix = fetcherPrefix s1 + , fetcherOrigins = origins + }) collectUnused :: [SomeSource] -> IO [Warning] diff --git a/test/Main.hs b/test/Main.hs index 2b96ac9..769f0d7 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -18,22 +18,26 @@ import Test.QuickCheck.Instances () import System.Exit (exitFailure, exitSuccess) import qualified Data.Text.Encoding as BS import Data.List ((\\)) +import Data.Maybe (isNothing) -data TestFlat = TestType { testFoo :: Text, testBar :: Integer } +data TestFlat = TestFlat { testFoo :: Text, testBar :: Integer } deriving (Show, Eq) instance Arbitrary TestFlat where - arbitrary = TestType <$> arbitrary <*> arbitrary + arbitrary = TestFlat <$> arbitrary <*> arbitrary data TestNested = TestNested { nestedFoo :: Text, nestedTest :: TestFlat } deriving (Show, Eq) +data TestOptionalNested = TestOptionalNested { opNestedFoo :: Text, opNestedTest :: Maybe TestFlat } + deriving (Show, Eq) + instance Arbitrary TestNested where arbitrary = TestNested <$> arbitrary <*> arbitrary instance Config TestFlat where - readConfig = TestType + readConfig = TestFlat <$> readRequiredValue (Key ["foo"]) <*> readRequiredValue (Key ["bar"]) @@ -43,22 +47,28 @@ instance Config TestNested where b <- readNested (Key ["nested"]) pure (TestNested a b) +instance Config TestOptionalNested where + readConfig = do + a <- readRequiredValue (Key ["foo"]) + b <- readNestedOptional (Key ["nested"]) + pure (TestOptionalNested a b) + testTypeToTrivial :: TestFlat -> SomeSource -testTypeToTrivial (TestType foo bar) = mkTrivialSource +testTypeToTrivial (TestFlat foo bar) = mkTrivialSource [(Key ["foo"], ConfigString (BS.encodeUtf8 foo)), (Key ["bar"], ConfigInteger bar)] -testTypeToJson :: TestFlat -> SomeSource -testTypeToJson (TestType foo bar) = mkJsonSource $ +testTypeToJson :: TestFlat -> A.Value +testTypeToJson (TestFlat foo bar) = A.object ["foo" A..= foo, "bar" A..= bar] nestedToTrivial :: TestNested -> SomeSource -nestedToTrivial (TestNested nfoo (TestType foo bar)) = +nestedToTrivial (TestNested nfoo (TestFlat foo bar)) = mkTrivialSource [ (Key ["foo"], ConfigString (BS.encodeUtf8 nfoo)) , (Key ["nested", "foo"], ConfigString (BS.encodeUtf8 foo)) , (Key ["nested", "bar"], ConfigInteger bar)] nestedToJson :: TestNested -> SomeSource -nestedToJson (TestNested nfoo (TestType foo bar)) = +nestedToJson (TestNested nfoo (TestFlat foo bar)) = mkJsonSource $ A.object [ "foo" A..= nfoo , "nested" A..= A.object @@ -80,7 +90,7 @@ prop_nested :: TestNested -> Property prop_nested = roundtripVia nestedToTrivial prop_aeson_flat :: TestFlat -> Property -prop_aeson_flat = roundtripVia testTypeToJson +prop_aeson_flat = roundtripVia (mkJsonSource . testTypeToJson) prop_aeson_nested :: TestNested -> Property prop_aeson_nested = roundtripVia nestedToJson @@ -95,6 +105,25 @@ prop_nested_keys = monadicIO $ do keys <- run $ configKeysOf @TestNested assert (null (keys \\ [ [key|foo|], [key|nested.bar|], [key|nested.foo|] ])) +prop_nested_optional_nothing :: Property +prop_nested_optional_nothing = monadicIO $ do + Right (conf, _, warnings) <- run $ runFetchConfig [ mkJsonSource (A.object ["foo" A..= ("bar" :: Text)]) ] + assert (null warnings) + assert (isNothing (opNestedTest conf)) + +prop_nested_optional_partial :: Property +prop_nested_optional_partial = monadicIO $ do + Left errors <- run $ runFetchConfig @TestOptionalNested [ mkJsonSource (A.object ["foo" A..= ("bar" :: Text), "nested" A..= A.object [ "foo" A..= ("bar" :: Text) ]]) ] + assert (not (null errors)) + +prop_nested_optional_just :: TestFlat -> Property +prop_nested_optional_just nested = monadicIO $ do + Right (conf, _, warnings) <- run $ runFetchConfig [ + mkJsonSource (A.object ["foo" A..= ("bar" :: Text), "nested" A..= testTypeToJson nested ]) + ] + assert (null warnings) + assert (opNestedTest conf == Just nested) + -- see quickcheck docs for why this return is here return [] runTests :: IO Bool |