[54] 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

@@ -23,7 +23,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
@@ -42,9 +42,7 @@ _getConfigValueWith parser keys0 (Config configValue0) =
       ([], 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,7 +63,7 @@ _getConfigValueWith parser keys0 (Config configValue0) =
       _ -> throwM $ InvalidConfigKeyPath keys0
   in  loop keys0 configValue0
 
-_getSelectedConfigSource :: (MonadThrow m) => [Text] -> Config -> m ConfigSource
+_getSelectedConfigSource :: (MonadThrow m) => [Text] -> Config -> m SomeConfigSource
 _getSelectedConfigSource keys0 (Config configValue0) =
   let loop keys configValue = case (keys, configValue) of
         ([], ConfigValue sources) -> case Set.maxView sources of
@@ -81,7 +79,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

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

@@ -89,45 +89,13 @@ 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 = sourcePretty
 
 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/Common.hs

@@ -121,7 +121,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/Default.hs

@@ -13,7 +13,7 @@ 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 =

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
@@ -38,11 +38,11 @@ buildEnvVarResolver lookupEnv spec =
     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
+              envSource' <- resolveEnvVarSource lookupEnv
+                                                configValueType
+                                                isSensitive
+                                                configSources
+              writeInSubConfig specKey (ConfigValue $ Set.singleton envSource') <$> mConfig
         in  updateConfig <|> mConfig
 
       Spec.SubConfig specConfigMap ->

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,39 @@ 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)
+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.SubConfig{}, _) -> throwM $ SubConfigEntryExpected currentKey json
 
-        (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do
-          either throwM return $ Spec.assertMatchingConfigValueType json configValueType
-          return $ ConfigValue
-            (Set.singleton $ File fileIndex fileSource $ markAsSensitive isSensitive json)
+      (Spec.ConfigValue { Spec.isSensitive, Spec.configValueType }, _) -> do
+        either throwM return $ Spec.assertMatchingConfigValueType json configValueType
+        return $ ConfigValue
+          (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive
+            isSensitive
+            json
+          )
 
 
 
@@ -88,9 +93,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 +111,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 +132,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 +158,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

etc/src/System/Etc/Internal/Spec/Parser.hs

@@ -228,6 +228,7 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
                 <*> pure sensitive
                 <*> (ConfigSources <$> fieldSpec .:? "env"
                                    <*> fieldSpec .:? "cli")
+                <*> pure json
             else
               fail "etc/spec object can only contain one key"
 
@@ -244,6 +245,7 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
           , configValueType = cvType
           , isSensitive     = False
           , configSources   = ConfigSources Nothing Nothing
+          , rawConfigValue  = json
           }
 
 parseFiles :: JSON.Value -> JSON.Parser FilesSpec
@@ -278,5 +280,6 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where
         <$> parseFileSpec json
         <*> (object .:? "etc/cli")
         <*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries"))
+        <*> pure json
       _ ->
         JSON.typeMismatch "ConfigSpec" json

etc/src/System/Etc/Internal/Spec/Types.hs

@@ -148,15 +148,16 @@ data ConfigValue cmd
   , configValueType :: !ConfigValueType
   , isSensitive     :: !Bool
   , configSources   :: !(ConfigSources cmd)
+  , rawConfigValue  :: !JSON.Value
   }
   | SubConfig {
     subConfig :: !(HashMap Text (ConfigValue cmd))
   }
   deriving (Generic, Show, Eq)
 
 instance Lift cmd => Lift (ConfigValue cmd) where
-  lift ConfigValue {defaultValue, configValueType, isSensitive, configSources} =
-    [| ConfigValue defaultValue configValueType isSensitive configSources |]
+  lift ConfigValue {defaultValue, configValueType, isSensitive, configSources, rawConfigValue } =
+    [| ConfigValue defaultValue configValueType isSensitive configSources rawConfigValue |]
   lift SubConfig {subConfig} =
     [| SubConfig (HashMap.fromList $ map (first Text.pack) subConfigList) |]
     where
@@ -202,13 +203,15 @@ data ConfigSpec cmd
     specConfigFilepaths :: !(Maybe FilesSpec)
   , specCliProgramSpec  :: !(Maybe CliProgramSpec)
   , specConfigValues    :: !(HashMap Text (ConfigValue cmd))
+  , rawSpec             :: !JSON.Value
   }
   deriving (Generic, Show, Eq)
 
 instance Lift cmd => Lift (ConfigSpec cmd) where
-  lift ConfigSpec {specConfigFilepaths, specCliProgramSpec, specConfigValues} =
+  lift ConfigSpec {specConfigFilepaths, specCliProgramSpec, specConfigValues, rawSpec } =
     [| ConfigSpec specConfigFilepaths
                   specCliProgramSpec
-                  (HashMap.fromList $ map (first Text.pack) configValuesList) |]
+                  (HashMap.fromList $ map (first Text.pack) configValuesList)
+                  rawSpec |]
     where
       configValuesList = map (first Text.unpack) $ HashMap.toList specConfigValues