Replace closed ADT to open typeclass for config sources

etc/src/System/Etc.hs

@@ -13,7 +13,7 @@ module System.Etc (
 
   -- * ConfigSpec
   -- $config_spec
-  , ConfigSource (..)
+  , SomeConfigSource (..)
   , ConfigValue
   , ConfigSpec
   , parseConfigSpec
@@ -71,7 +71,7 @@ module System.Etc (
 
 import System.Etc.Internal.Resolver.Default (resolveDefault)
 import System.Etc.Internal.Types
-    (Config, ConfigSource (..), ConfigValue, IConfig (..), Value (..))
+    (Config, ConfigValue, IConfig (..), SomeConfigSource (..), Value (..))
 import System.Etc.Spec
     ( ConfigInvalidSyntaxFound (..)
     , ConfigSpec

etc/src/System/Etc/Internal/Config.hs

@@ -9,6 +9,8 @@ import qualified RIO.HashMap as HashMap
 import qualified RIO.Set     as Set
 import qualified RIO.Text    as Text
 
+import Data.Typeable (cast)
+
 import qualified Data.Aeson          as JSON
 import qualified Data.Aeson.Internal as JSON (IResult (..), formatError, iparse)
 import qualified Data.Aeson.Types    as JSON (Parser)
@@ -23,7 +25,7 @@ configValueToJsonObject configValue = case configValue of
   ConfigValue sources -> case Set.maxView sources of
     Nothing          -> JSON.Null
 
-    Just (source, _) -> fromValue $ value source
+    Just (source, _) -> fromValue $ sourceValue source
 
   SubConfig configm ->
     configm
@@ -35,16 +37,14 @@ configValueToJsonObject configValue = case configValue of
       & JSON.Object
 
 _getConfigValueWith
-  :: MonadThrow m => (JSON.Value -> JSON.Parser result) -> [Text] -> Config -> m result
+  :: (MonadThrow m) => (JSON.Value -> JSON.Parser result) -> [Text] -> Config -> m result
 _getConfigValueWith parser keys0 (Config configValue0) =
   let
     loop keys configValue = case (keys, configValue) of
       ([], ConfigValue sources) -> case Set.maxView sources of
         Nothing          -> throwM $ InvalidConfigKeyPath keys0
 
-        Just (None  , _) -> throwM $ InvalidConfigKeyPath keys0
-
-        Just (source, _) -> case JSON.iparse parser (fromValue $ value source) of
+        Just (source, _) -> case JSON.iparse parser (fromValue $ sourceValue source) of
 
           JSON.IError path err ->
             JSON.formatError path err & Text.pack & ConfigValueParserFailed keys0 & throwM
@@ -65,13 +65,16 @@ _getConfigValueWith parser keys0 (Config configValue0) =
       _ -> throwM $ InvalidConfigKeyPath keys0
   in  loop keys0 configValue0
 
-_getSelectedConfigSource :: (MonadThrow m) => [Text] -> Config -> m ConfigSource
+_getSelectedConfigSource
+  :: (MonadThrow m, IConfigSource result) => [Text] -> Config -> m result
 _getSelectedConfigSource keys0 (Config configValue0) =
   let loop keys configValue = case (keys, configValue) of
         ([], ConfigValue sources) -> case Set.maxView sources of
-          Nothing          -> throwM $ InvalidConfigKeyPath keys0
+          Nothing -> throwM $ InvalidConfigKeyPath keys0
 
-          Just (source, _) -> return source
+          Just (SomeConfigSource _ source, _) ->
+            -- TODO: Change exception from InvalidConfigKeyPath
+            maybe (throwM $ InvalidConfigKeyPath keys0) return (cast source)
 
         (k : keys1, SubConfig configm) -> case HashMap.lookup k configm of
           Nothing           -> throwM $ InvalidConfigKeyPath keys0
@@ -81,7 +84,7 @@ _getSelectedConfigSource keys0 (Config configValue0) =
   in  loop keys0 configValue0
 
 
-_getAllConfigSources :: (MonadThrow m) => [Text] -> Config -> m (Set ConfigSource)
+_getAllConfigSources :: (MonadThrow m) => [Text] -> Config -> m (Set SomeConfigSource)
 _getAllConfigSources keys0 (Config configValue0) =
   let loop keys configValue = case (keys, configValue) of
         ([]       , ConfigValue sources) -> return sources
@@ -96,7 +99,6 @@ _getAllConfigSources keys0 (Config configValue0) =
 _getConfigValue :: (MonadThrow m, JSON.FromJSON result) => [Text] -> Config -> m result
 _getConfigValue = _getConfigValueWith JSON.parseJSON
 
-
 instance IConfig Config where
   getConfigValue = _getConfigValue
   getConfigValueWith = _getConfigValueWith

etc/src/System/Etc/Internal/Extra/EnvMisspell.hs

@@ -34,7 +34,7 @@ data EnvMisspell
 lookupSpecEnvKeys :: ConfigSpec a -> Vector Text
 lookupSpecEnvKeys spec =
   let foldEnvSettings val acc = case val of
-        ConfigValue { configSources } ->
+        ConfigValue ConfigValueData { configSources } ->
           maybe acc (`Vector.cons` acc) (envVar configSources)
         SubConfig hsh -> HashMap.foldr foldEnvSettings acc hsh
   in  foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty

etc/src/System/Etc/Internal/Extra/Printer.hs

@@ -89,45 +89,21 @@ renderConfigValueJSON value = case value of
     )
     (HashMap.toList obj)
 
-
 renderConfigValue :: (JSON.Value -> Doc) -> Value JSON.Value -> [Doc]
 renderConfigValue f value = case value of
   Plain (JSON.Array jsonArray) ->
     Vector.toList $ Vector.map (\jsonValue -> text "-" <+> f jsonValue) jsonArray
   Plain jsonValue -> return $ f jsonValue
   Sensitive{}     -> return $ text "<<sensitive>>"
 
-renderConfigSource :: (JSON.Value -> Doc) -> ConfigSource -> ([Doc], Doc)
-renderConfigSource f configSource = case configSource of
-  Default value ->
-    let sourceDoc = text "Default"
-        valueDoc  = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
-
-  File _index fileSource value ->
-    let sourceDoc = case fileSource of
-          FilePathSource filepath -> text "File:" <+> text (Text.unpack filepath)
-          EnvVarFileSource envVar filepath ->
-            text "File:" <+> text (Text.unpack envVar) <> "=" <> text (Text.unpack filepath)
-        valueDoc = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
-
-  Env varname value ->
-    let sourceDoc = text "Env:" <+> text (Text.unpack varname)
-        valueDoc  = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
-
-  Cli value ->
-    let sourceDoc = text "Cli"
-        valueDoc  = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
-
-  None -> (mempty, mempty)
+renderConfigSource :: (JSON.Value -> Doc) -> SomeConfigSource -> ([Doc], Doc)
+renderConfigSource f source =
+  (renderConfigValue f (sourceValue source), sourcePrettyDoc source)
 
 renderConfig_ :: MonadThrow m => ColorFn -> Config -> m Doc
 renderConfig_ ColorFn { blueColor } (Config configMap) =
   let
-    renderSources :: MonadThrow m => [ConfigSource] -> m Doc
+    renderSources :: MonadThrow m => [SomeConfigSource] -> m Doc
     renderSources sources =
       let sourceDocs = map (renderConfigSource renderConfigValueJSON) sources
 

etc/src/System/Etc/Internal/Resolver/Cli/Command.hs

@@ -113,8 +113,8 @@ specToConfigValueCli
   -> (Text, Spec.ConfigValue cmd)
   -> m (HashMap cmd (Opt.Parser ConfigValue))
 specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of
-  Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } ->
-    configValueSpecToCli acc specEntryKey configValueType isSensitive configSources
+  Spec.ConfigValue Spec.ConfigValueData { Spec.configValueType, Spec.isSensitive, Spec.configSources }
+    -> configValueSpecToCli acc specEntryKey configValueType isSensitive configSources
 
   Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc
 

etc/src/System/Etc/Internal/Resolver/Cli/Common.hs

@@ -139,7 +139,7 @@ parseCommandJsonValue commandValue = case JSON.iparse JSON.parseJSON commandValu
 
 jsonToConfigValue :: Maybe (Value JSON.Value) -> ConfigValue
 jsonToConfigValue specEntryDefVal =
-  ConfigValue $ Set.fromList $ maybe [] ((: []) . Cli) specEntryDefVal
+  ConfigValue $ Set.fromList $ maybe [] ((: []) . cliSource 3) specEntryDefVal
 
 handleCliResult :: Either SomeException a -> IO a
 handleCliResult result = case result of

etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs

@@ -92,8 +92,8 @@ specToConfigValueCli
   -> (Text, Spec.ConfigValue ())
   -> m (Opt.Parser ConfigValue)
 specToConfigValueCli acc (specEntryKey, specConfigValue) = case specConfigValue of
-  Spec.ConfigValue { Spec.configValueType, Spec.isSensitive, Spec.configSources } ->
-    configValueSpecToCli specEntryKey configValueType isSensitive configSources acc
+  Spec.ConfigValue Spec.ConfigValueData { Spec.configValueType, Spec.isSensitive, Spec.configSources }
+    -> configValueSpecToCli specEntryKey configValueType isSensitive configSources acc
 
   Spec.SubConfig subConfigSpec -> subConfigSpecToCli specEntryKey subConfigSpec acc
 

etc/src/System/Etc/Internal/Resolver/Default.hs

@@ -13,14 +13,14 @@ import           System.Etc.Internal.Types
 
 toDefaultConfigValue :: Bool -> JSON.Value -> ConfigValue
 toDefaultConfigValue sensitive =
-  ConfigValue . Set.singleton . Default . markAsSensitive sensitive
+  ConfigValue . Set.singleton . defaultSource . markAsSensitive sensitive
 
 buildDefaultResolver :: Spec.ConfigSpec cmd -> Maybe ConfigValue
 buildDefaultResolver spec =
   let resolverReducer
         :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue
       resolverReducer specKey specValue mConfig = case specValue of
-        Spec.ConfigValue { Spec.defaultValue, Spec.isSensitive } ->
+        Spec.ConfigValue Spec.ConfigValueData { Spec.defaultValue, Spec.isSensitive } ->
           let mConfigSource = toDefaultConfigValue isSensitive <$> defaultValue
 
               updateConfig  = writeInSubConfig specKey <$> mConfigSource <*> mConfig

etc/src/System/Etc/Internal/Resolver/Env.hs

@@ -19,12 +19,12 @@ resolveEnvVarSource
   -> Spec.ConfigValueType
   -> Bool
   -> Spec.ConfigSources cmd
-  -> Maybe ConfigSource
+  -> Maybe SomeConfigSource
 resolveEnvVarSource lookupEnv configValueType isSensitive specSources =
   let envTextToJSON = Spec.parseBytesToConfigValueJSON configValueType
 
       toEnvSource varname envValue =
-        Env varname . markAsSensitive isSensitive <$> envTextToJSON envValue
+        envSource 2 varname . markAsSensitive isSensitive <$> envTextToJSON envValue
   in  do
         varname <- Spec.envVar specSources
         envText <- lookupEnv varname
@@ -36,14 +36,15 @@ buildEnvVarResolver lookupEnv spec =
     resolverReducer
       :: Text -> Spec.ConfigValue cmd -> Maybe ConfigValue -> Maybe ConfigValue
     resolverReducer specKey specValue mConfig = case specValue of
-      Spec.ConfigValue { Spec.isSensitive, Spec.configValueType, Spec.configSources } ->
-        let updateConfig = do
-              envSource <- resolveEnvVarSource lookupEnv
-                                               configValueType
-                                               isSensitive
-                                               configSources
-              writeInSubConfig specKey (ConfigValue $ Set.singleton envSource) <$> mConfig
-        in  updateConfig <|> mConfig
+      Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType, Spec.configSources }
+        -> let updateConfig = do
+                 envSource' <- resolveEnvVarSource lookupEnv
+                                                   configValueType
+                                                   isSensitive
+                                                   configSources
+                 writeInSubConfig specKey (ConfigValue $ Set.singleton envSource')
+                   <$> mConfig
+           in  updateConfig <|> mConfig
 
       Spec.SubConfig specConfigMap ->
         let mSubConfig =

etc/src/System/Etc/Internal/Resolver/File.hs

@@ -25,7 +25,7 @@ import System.Environment (lookupEnv)
 import           System.Etc.Internal.Errors
 import qualified System.Etc.Internal.Spec.Parser as Spec
 import qualified System.Etc.Internal.Spec.Types  as Spec
-import           System.Etc.Internal.Types       hiding (filepath)
+import           System.Etc.Internal.Types
 
 --------------------------------------------------------------------------------
 
@@ -41,34 +41,40 @@ parseConfigValue
   => [Text]
   -> Spec.ConfigValue cmd
   -> Int
-  -> FileSource
+  -> FileValueOrigin
   -> JSON.Value
   -> m ConfigValue
-parseConfigValue keys spec fileIndex fileSource json =
-  let parentKeys = reverse keys
-      currentKey = Text.intercalate "." parentKeys
-  in  case (spec, json) of
-        (Spec.SubConfig currentSpec, JSON.Object object) -> SubConfig <$> foldM
-          (\acc (key, subConfigValue) -> case HashMap.lookup key currentSpec of
-            Nothing ->
-              throwM $ UnknownConfigKeyFound parentKeys key (HashMap.keys currentSpec)
-            Just subConfigSpec -> do
-              value1 <- parseConfigValue (key : keys)
-                                         subConfigSpec
-                                         fileIndex
-                                         fileSource
-                                         subConfigValue
-              return $ HashMap.insert key value1 acc
-          )
-          HashMap.empty
-          (HashMap.toList object)
-
-        (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json
-
-        (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do
+parseConfigValue keys spec fileIndex fileSource' json =
+  let
+    parentKeys = reverse keys
+    currentKey = Text.intercalate "." parentKeys
+  in
+    case (spec, json) of
+      (Spec.SubConfig currentSpec, JSON.Object object) -> SubConfig <$> foldM
+        (\acc (key, subConfigValue) -> case HashMap.lookup key currentSpec of
+          Nothing ->
+            throwM $ UnknownConfigKeyFound parentKeys key (HashMap.keys currentSpec)
+          Just subConfigSpec -> do
+            value1 <- parseConfigValue (key : keys)
+                                       subConfigSpec
+                                       fileIndex
+                                       fileSource'
+                                       subConfigValue
+            return $ HashMap.insert key value1 acc
+        )
+        HashMap.empty
+        (HashMap.toList object)
+
+      (Spec.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json
+
+      (Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType }, _)
+        -> do
           either throwM return $ Spec.assertMatchingConfigValueType json configValueType
           return $ ConfigValue
-            (Set.singleton $ File fileIndex fileSource $ markAsSensitive isSensitive json)
+            (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive
+              isSensitive
+              json
+            )
 
 
 
@@ -88,9 +94,15 @@ eitherDecode contents0 = case contents0 of
 
 
 parseConfig
-  :: MonadThrow m => Spec.ConfigValue cmd -> Int -> FileSource -> ConfigFile -> m Config
-parseConfig spec fileIndex fileSource contents = case eitherDecode contents of
-  Left err -> throwM $ ConfigInvalidSyntaxFound (fileSourcePath fileSource) (Text.pack err)
+  :: MonadThrow m
+  => Spec.ConfigValue cmd
+  -> Int
+  -> FileValueOrigin
+  -> ConfigFile
+  -> m Config
+parseConfig spec fileIndex fileSource' contents = case eitherDecode contents of
+  Left err ->
+    throwM $ ConfigInvalidSyntaxFound (fileSourcePath fileSource') (Text.pack err)
   -- Right json ->
   --   case JSON.iparse (parseConfigValue [] spec fileIndex fileSource) json of
   --     JSON.IError _ err    ->
@@ -100,7 +112,7 @@ parseConfig spec fileIndex fileSource contents = case eitherDecode contents of
   --         _ ->
   --           throwM $ InvalidConfiguration Nothing (Text.pack err)
   --     JSON.ISuccess result -> return (Config result)
-  Right json -> Config <$> parseConfigValue [] spec fileIndex fileSource json
+  Right json -> Config <$> parseConfigValue [] spec fileIndex fileSource' json
 
 readConfigFile :: MonadThrow m => Text -> IO (m ConfigFile)
 readConfigFile filepath =
@@ -121,18 +133,18 @@ readConfigFile filepath =
         else return $ throwM $ ConfigurationFileNotFound filepath
 
 readConfigFromFileSources
-  :: Spec.ConfigSpec cmd -> [FileSource] -> IO (Config, [SomeException])
+  :: Spec.ConfigSpec cmd -> [FileValueOrigin] -> IO (Config, [SomeException])
 readConfigFromFileSources spec fileSources =
   fileSources
     & zip [1 ..]
     & mapM
-        (\(fileIndex, fileSource) -> do
-          mContents <- readConfigFile (fileSourcePath fileSource)
+        (\(fileIndex, fileSource') -> do
+          mContents <- readConfigFile (fileSourcePath fileSource')
           return
             (   mContents
             >>= parseConfig (Spec.SubConfig $ Spec.specConfigValues spec)
                             fileIndex
-                            fileSource
+                            fileSource'
             )
         )
     & (foldl'
@@ -147,15 +159,14 @@ processFilesSpec :: Spec.ConfigSpec cmd -> IO (Config, [SomeException])
 processFilesSpec spec = case Spec.specConfigFilepaths spec of
   Nothing -> readConfigFromFileSources spec []
   Just (Spec.FilePathsSpec paths) ->
-    readConfigFromFileSources spec (map FilePathSource paths)
+    readConfigFromFileSources spec (map ConfigFileOrigin paths)
   Just (Spec.FilesSpec fileEnvVar paths0) -> do
     let getPaths = case fileEnvVar of
-          Nothing       -> return $ map FilePathSource paths0
+          Nothing       -> return $ map ConfigFileOrigin paths0
           Just filePath -> do
             envFilePath <- lookupEnv (Text.unpack filePath)
-            let envPath =
-                  maybeToList (EnvVarFileSource filePath . Text.pack <$> envFilePath)
-            return $ map FilePathSource paths0 ++ envPath
+            let envPath = maybeToList (EnvFileOrigin filePath . Text.pack <$> envFilePath)
+            return $ map ConfigFileOrigin paths0 ++ envPath
 
     paths <- getPaths
     readConfigFromFileSources spec paths