From c1cf159fa67a107a395166c199c401aac0918c31 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Fri, 7 Jun 2024 22:36:40 +0200 Subject: 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. --- src/Conftrack.hs | 123 +++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 78 insertions(+), 45 deletions(-) (limited to 'src/Conftrack.hs') 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 -- cgit v1.2.3