the Config interface should be Applicative, not Monad

this allows for safer alternative uses for it, such as running it on an
empty list of config sources to just get the list of keys it uses.

2 files changed, 94 insertions, 48 deletions

diff --git a/src/Conftrack.hs b/src/Conftrack.hs
index 0d3ffdd..b15fa02 100644
--- a/src/Conftrack.hs
+++ b/src/Conftrack.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Conftrack
   ( Config(..)
@@ -19,78 +20,112 @@ module Conftrack
   , ConfigError(..)
   , Key(..)
   , Value(..)
+  , configKeysOf
   ) where
 
 import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith)
 import Conftrack.Source (SomeSource (..), ConfigSource (..))
 
 import Prelude hiding (unzip)
-import Control.Monad.State (get, StateT (..), MonadState (..), modify)
+import Control.Monad.State (StateT (..))
 import Data.Functor ((<&>))
-import Control.Monad.Reader (MonadIO (liftIO))
 import Data.List.NonEmpty (NonEmpty, unzip)
 import qualified Data.List.NonEmpty as NonEmpty
-import Control.Monad (forM, foldM)
+import Control.Monad (forM, (>=>))
 import Data.Either (isRight)
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
-import Control.Monad.Trans (lift)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, mapMaybe)
 
 
 class Config a where
-  readConfig :: FetchMonad a
+  readConfig :: Fetch a
 
-type FetchMonad = StateT (NonEmpty SomeSource, [KeyPart], [Origin], [Warning]) (ExceptT [ConfigError] IO)
+data FetcherState = FetcherState
+  { fetcherSources :: [SomeSource]
+  , fetcherPrefix :: [KeyPart]
+  , fetcherOrigins :: [Origin]
+  , fetcherWarnings :: [Warning]
+  , fetcherErrors :: [ConfigError]
+  }
+
+newtype Fetch a = Fetch (FetcherState -> IO (a, FetcherState))
+  deriving (Functor)
 
 newtype Warning = Warning Text
  deriving Show
 
-runFetchConfig :: Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
+instance Applicative Fetch where
+  pure a = Fetch (\s -> pure (a, s))
+
+  liftA2 f (Fetch m) (Fetch n) = Fetch $ \s -> do
+    (a, s2) <- m s
+    (b, s3) <- n s2
+    pure (f a b, s3)
+
+
+runFetchConfig :: forall a. Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
 runFetchConfig sources = do
-  results <- runExceptT $ runStateT readConfig (sources, [], [], [])
-  case results of
-    Left a -> pure $ Left a
-    Right (result, (sources, _prefix, origins, warnings)) -> do
-      unusedWarnings <- collectUnused sources
-      pure $ Right (result, origins, unusedWarnings <> warnings)
+  let (Fetch m) = readConfig @a
+
+  (result, FetcherState sources2 _ origins warnings errors) <- m (FetcherState (NonEmpty.toList sources) [] [] [] [])
+  unusedWarnings <- collectUnused sources2
+  if null errors
+    then pure $ Right (result, origins, unusedWarnings <> warnings)
+    else pure $ Left errors
+
+configKeysOf :: forall a. Config a => IO [Key]
+configKeysOf = do
+  let (Fetch m) = readConfig @a
+  (_, FetcherState _ _ origins warnings errors) <- m (FetcherState [] [] [] [] [])
 
-readOptionalValue :: ConfigValue a => Key -> FetchMonad (Maybe a)
-readOptionalValue bareKey = do
-  (sources, prefix, origins, warnings) <- get
+  let keys = mapMaybe (\case {(NotPresent key) -> Just key; _ -> Nothing }) errors
+  pure keys
 
-  let key = bareKey `prefixedWith` prefix
 
-  stuff <- liftIO $ firstMatchInSources key (NonEmpty.toList sources) <&> NonEmpty.fromList
 
-  let (maybeValues, states) = unzip stuff
+readOptionalValue :: ConfigValue a => Key -> Fetch (Maybe a)
+readOptionalValue bareKey = Fetch $ \s1@FetcherState{..} -> do
+
+  let key = bareKey `prefixedWith` fetcherPrefix
+
+  stuff <- firstMatchInSources key fetcherSources
+
+  let (maybeValues, sources) = unzip stuff
 
   let values = maybeValues <&> \case
         Right (val, text) -> fromConfig val <&> (\val -> (val, Origin key text))
         Left e -> Left e
 
-  val <- case fmap (\(Right a) -> a) $ NonEmpty.filter isRight values of
+  val <- case fmap (\(Right a) -> a) $ filter isRight values of
     [] -> pure (Nothing, Origin key "default value")
     (value, origin):_ -> pure (Just value, origin)
 
-  put (states, prefix, snd val : origins, warnings)
-  pure (fst val)
+  pure (fst val, s1 { fetcherSources = sources, fetcherOrigins = snd val : fetcherOrigins })
 
-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
+readRequiredValue :: ConfigValue a => Key -> Fetch a
+readRequiredValue key =
+  let
+    Fetch m = readOptionalValue key
+  in
+    Fetch (m >=> (\(a, s) -> case a of
+      Nothing ->
+        let
+          dummy = error "A nonexisting config value was evaluated. This is a bug."
+        in
+          pure (dummy, s { fetcherErrors = NotPresent (key `prefixedWith` fetcherPrefix s) : fetcherErrors s })
+      Just v -> pure (v, s)))
+
+readValue :: forall a. ConfigValue a => a -> Key -> Fetch 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
+  let
+    Fetch m = readOptionalValue @a 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 })))
 
 firstMatchInSources :: Key -> [SomeSource] -> IO [(Either ConfigError (Value, Text), SomeSource)]
 firstMatchInSources _ [] = pure []
@@ -104,19 +139,17 @@ firstMatchInSources key (SomeSource (source, sourceState):sources) = do
     Right _ ->
       pure $ (eitherValue, SomeSource (source, newState)) : fmap (Left Shadowed ,) sources
 
+readNested :: forall a. Config a => Key -> Fetch a
+readNested (Key prefix') = Fetch $ \s1 -> do
+  let (Fetch nested) = readConfig @a
+  (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix' })
+  pure (config, s2 { fetcherPrefix = fetcherPrefix s1 })
 
-readNested :: forall a. Config a => Key -> FetchMonad a
-readNested (Key prefix') = do
-  prefix <- state (\(sources, prefix, origins, warnings) ->
-                     (prefix, (sources, prefix <> NonEmpty.toList prefix', origins, warnings)))
-  config <- readConfig
-  modify (\(sources, _, origins, warnings) -> (sources, prefix, origins, warnings))
-  pure config
 
-collectUnused :: NonEmpty SomeSource -> IO [Warning]
+collectUnused :: [SomeSource] -> IO [Warning]
 collectUnused sources = do
   forM sources (\(SomeSource (source, sourceState)) ->
     runStateT (leftovers source) sourceState <&> fst)
     <&> fmap (\(Just a) -> Warning $ "Unused Keys " <> T.pack (show a))
         . filter (\(Just a) -> not (null a))
-        . NonEmpty.filter isJust
+        . filter isJust
diff --git a/test/Main.hs b/test/Main.hs
index 5c01f64..1af3d9a 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ApplicativeDo #-}
 module Main (main) where
 
 import Conftrack
@@ -15,6 +16,7 @@ import Test.QuickCheck.Monadic
 import Test.QuickCheck.Instances ()
 import System.Exit (exitFailure, exitSuccess)
 import qualified Data.Text.Encoding as BS
+import Data.List ((\\))
 
 
 data TestFlat = TestType { testFoo :: Text, testBar :: Integer }
@@ -35,9 +37,10 @@ instance Config TestFlat where
     <*> readRequiredValue (Key ["bar"])
 
 instance Config TestNested where
-  readConfig = TestNested
-    <$> readRequiredValue (Key ["foo"])
-    <*> readNested (Key ["nested"])
+  readConfig = do
+    a <- readRequiredValue (Key ["foo"])
+    b <- readNested (Key ["nested"])
+    pure (TestNested a b)
 
 testTypeToTrivial :: TestFlat -> SomeSource
 testTypeToTrivial (TestType foo bar) = mkTrivialSource
@@ -81,6 +84,16 @@ prop_aeson_flat = roundtripVia testTypeToJson
 prop_aeson_nested :: TestNested -> Property
 prop_aeson_nested = roundtripVia nestedToJson
 
+prop_flat_keys :: Property
+prop_flat_keys = monadicIO $ do
+  keys <- run $ configKeysOf @TestFlat
+  assert (null (keys \\ [ Key ["foo"], Key ["bar"] ]))
+
+prop_nested_keys :: Property
+prop_nested_keys = monadicIO $ do
+  keys <- run $ configKeysOf @TestNested
+  assert (null (keys \\ [ Key ["foo"], Key ["nested", "bar"], Key ["nested", "foo"] ]))
+
 -- see quickcheck docs for why this return is here
 return []
 runTests = $quickCheckAll