1 files changed, 78 insertions, 45 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