From 22d1b7f5eeb53991ceed28eb8b1947549256c112 Mon Sep 17 00:00:00 2001
From: Roman Gonzalez <romanandreg@gmail.com>
Date: Thu, 19 Jul 2018 17:10:03 -0700
Subject: [PATCH 1/6] [54] Replace closed ADT to open typeclass for config
 sources

---
 etc/src/System/Etc.hs                         |   4 +-
 etc/src/System/Etc/Internal/Config.hs         |  10 +-
 etc/src/System/Etc/Internal/Extra/Printer.hs  |  38 +--
 .../Etc/Internal/Resolver/Cli/Common.hs       |   2 +-
 .../System/Etc/Internal/Resolver/Default.hs   |   2 +-
 etc/src/System/Etc/Internal/Resolver/Env.hs   |  14 +-
 etc/src/System/Etc/Internal/Resolver/File.hs  |  86 ++++---
 etc/src/System/Etc/Internal/Spec/Parser.hs    |   3 +
 etc/src/System/Etc/Internal/Spec/Types.hs     |  11 +-
 etc/src/System/Etc/Internal/Types.hs          | 219 +++++++++++++-----
 .../System/Etc/Resolver/Cli/CommandTest.hs    |  11 +-
 etc/test/System/Etc/Resolver/Cli/PlainTest.hs |  13 +-
 etc/test/System/Etc/Resolver/DefaultTest.hs   |   8 +-
 etc/test/System/Etc/Resolver/EnvTest.hs       |   6 +-
 etc/test/System/Etc/Resolver/FileTest.hs      |  42 +++-
 examples/etc-command-example/src/Main.hs      |   4 +
 16 files changed, 290 insertions(+), 183 deletions(-)

diff --git a/etc/src/System/Etc.hs b/etc/src/System/Etc.hs
index dbd94a8..a37fe5b 100644
--- a/etc/src/System/Etc.hs
+++ b/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
diff --git a/etc/src/System/Etc/Internal/Config.hs b/etc/src/System/Etc/Internal/Config.hs
index ed54c6b..db9d3a7 100644
--- a/etc/src/System/Etc/Internal/Config.hs
+++ b/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
diff --git a/etc/src/System/Etc/Internal/Extra/Printer.hs b/etc/src/System/Etc/Internal/Extra/Printer.hs
index 852aa52..d08d3e3 100644
--- a/etc/src/System/Etc/Internal/Extra/Printer.hs
+++ b/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
 
diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs
index d13d407..f84d51a 100644
--- a/etc/src/System/Etc/Internal/Resolver/Cli/Common.hs
+++ b/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
diff --git a/etc/src/System/Etc/Internal/Resolver/Default.hs b/etc/src/System/Etc/Internal/Resolver/Default.hs
index 1742045..80aca80 100644
--- a/etc/src/System/Etc/Internal/Resolver/Default.hs
+++ b/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 =
diff --git a/etc/src/System/Etc/Internal/Resolver/Env.hs b/etc/src/System/Etc/Internal/Resolver/Env.hs
index c099449..dca762a 100644
--- a/etc/src/System/Etc/Internal/Resolver/Env.hs
+++ b/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 ->
diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs
index 3a32c8b..bc840b5 100644
--- a/etc/src/System/Etc/Internal/Resolver/File.hs
+++ b/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
diff --git a/etc/src/System/Etc/Internal/Spec/Parser.hs b/etc/src/System/Etc/Internal/Spec/Parser.hs
index 2d33f5f..36932ae 100644
--- a/etc/src/System/Etc/Internal/Spec/Parser.hs
+++ b/etc/src/System/Etc/Internal/Spec/Parser.hs
@@ -247,6 +247,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"
 
@@ -263,6 +264,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
@@ -297,5 +299,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
diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs
index bd28b6b..74e972f 100644
--- a/etc/src/System/Etc/Internal/Spec/Types.hs
+++ b/etc/src/System/Etc/Internal/Spec/Types.hs
@@ -191,6 +191,7 @@ data ConfigValue cmd
   , configValueType :: !ConfigValueType
   , isSensitive     :: !Bool
   , configSources   :: !(ConfigSources cmd)
+  , rawConfigValue  :: !JSON.Value
   }
   | SubConfig {
     subConfig :: !(HashMap Text (ConfigValue cmd))
@@ -198,8 +199,8 @@ data 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
@@ -245,13 +246,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
diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs
index 32d3495..5a46b96 100644
--- a/etc/src/System/Etc/Internal/Types.hs
+++ b/etc/src/System/Etc/Internal/Types.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RankNTypes                 #-}
 
 module System.Etc.Internal.Types
@@ -11,9 +13,17 @@ module System.Etc.Internal.Types
 import           RIO
 import qualified RIO.HashMap as HashMap
 import qualified RIO.Set     as Set
+import qualified RIO.Text    as Text
+import qualified RIO.Vector  as Vector
+
+import           Text.PrettyPrint.ANSI.Leijen (Doc, (<+>))
+import qualified Text.PrettyPrint.ANSI.Leijen as Doc
+
+import Control.Exception (throw)
 
 import           Data.Bool      (bool)
 import qualified Data.Semigroup as Semigroup
+import           Data.Typeable  (cast, typeOf)
 
 import qualified Data.Aeson       as JSON
 import qualified Data.Aeson.Types as JSON (Parser)
@@ -28,6 +38,8 @@ data Value a
   | Sensitive { fromValue :: !a }
   deriving (Generic, Eq, Ord)
 
+instance NFData a => NFData (Value a)
+
 instance Show a => Show (Value a) where
   show (Plain a)     = show a
   show (Sensitive _) = "<<sensitive>>"
@@ -53,70 +65,151 @@ instance IsString a => IsString (Value a) where
 markAsSensitive :: Bool -> (a -> Value a)
 markAsSensitive = bool Plain Sensitive
 
-data FileSource
-  = FilePathSource { fileSourcePath :: !Text }
-  | EnvVarFileSource { fileSourceEnvVar :: !Text,  fileSourcePath :: !Text }
-  deriving (Show, Eq)
-
-data ConfigSource
-  = File {
-      configIndex :: !Int
-    , filepath    :: !FileSource
-    , value       :: !(Value JSON.Value)
-    }
-  | Env {
-      envVar :: !Text
-    , value  :: !(Value JSON.Value)
-    }
-  | Cli {
-      value :: !(Value JSON.Value)
-    }
-  | Default {
-      value :: !(Value JSON.Value)
-    }
-  | None
-  deriving (Show, Eq)
-
-instance Ord ConfigSource where
-  compare a b =
-    if a == b then
-      EQ
-    else
-      case (a, b) of
-        (None, _) ->
-          LT
-
-        (_, None) ->
-          GT
-
-        (_, _)
-          | fromValue (value a) == JSON.Null -> LT
-          | fromValue (value b) == JSON.Null -> GT
-
-        (Default {}, _) ->
-          LT
-
-        (Cli {}, _) ->
-          GT
-
-        (_, Cli {}) ->
-          LT
-
-        (Env {}, _) ->
-          GT
-
-        (_, Env {}) ->
-          LT
-
-        (File {}, File {}) ->
-          comparing configIndex a b
-
-        (File {}, _) ->
-          GT
+data FileValueOrigin
+  = ConfigFileOrigin { fileSourcePath :: !Text }
+  | EnvFileOrigin    { fileSourceEnvVar :: !Text,  fileSourcePath :: !Text }
+  deriving (Generic, Show, Eq)
+
+instance NFData FileValueOrigin
+
+class IConfigSource source where
+  sourceValue   :: source -> Value JSON.Value
+  sourcePretty  :: (JSON.Value -> Doc) -> source -> ([Doc], Doc)
+  compareValues :: source -> source -> Ordering
+  compareValues _ _ = EQ
+
+data SomeConfigSource =
+  forall source. ( Show source
+                 , NFData source
+                 , Typeable source
+                 , IConfigSource source
+                 ) =>
+                 SomeConfigSource !Int
+                                  !source
+
+instance Show SomeConfigSource where
+  show (SomeConfigSource i a) = "SomeConfigSource " <> show i <> " (" <> show a <> ")"
+
+-- | Thrown when comparing config sources of different types on a same
+-- precedence level, this should never happen because config source values of
+-- the same type are created and compared on a single execution; if this does
+-- happen, it maybe either be an urgent bug or you used the private API
+-- incorrectly.
+data InvalidConfigSourceComparison
+  = InvalidConfigSourceComparison !SomeConfigSource !SomeConfigSource
+  deriving (Show)
+
+instance Exception InvalidConfigSourceComparison
+
+renderConfigValue :: (JSON.Value -> Doc) -> Value JSON.Value -> [Doc]
+renderConfigValue f value = case value of
+  Plain (JSON.Array jsonArray) ->
+    Vector.toList $ Vector.map (\jsonValue -> Doc.text "-" <+> f jsonValue) jsonArray
+  Plain jsonValue -> return $ f jsonValue
+  Sensitive{}     -> return $ Doc.text "<<sensitive>>"
+
+instance IConfigSource SomeConfigSource where
+  sourceValue (SomeConfigSource _ inner) =
+    sourceValue inner
+  sourcePretty f (SomeConfigSource _ inner) =
+    sourcePretty f inner
+  compareValues x@(SomeConfigSource ia a) y@(SomeConfigSource ib b)
+    | ia == ib =
+      if fromValue (sourceValue a) == JSON.Null && fromValue (sourceValue b) == JSON.Null then
+        EQ
+      else if typeOf a == typeOf b then
+        let b' = fromMaybe (throw (InvalidConfigSourceComparison x y)) (cast a)
+        in compareValues a b'
+      else
+        throw (InvalidConfigSourceComparison x y)
+    | fromValue (sourceValue a) == JSON.Null = LT
+    | fromValue (sourceValue b) == JSON.Null = GT
+    | otherwise =
+      compare ia ib
+
+instance Eq SomeConfigSource where
+  (==) a b = compareValues a b == EQ
+
+instance Ord SomeConfigSource where
+  compare = compareValues
+
+data FileSource = FileSource
+  { fsConfigIndex :: !Int
+  , fsValueOrigin :: !FileValueOrigin
+  , fsValue       :: !(Value JSON.Value) }
+  deriving (Generic, Typeable, Show, Eq)
+
+instance NFData FileSource
+instance IConfigSource FileSource where
+  sourceValue = fsValue
+  compareValues = comparing fsConfigIndex
+  sourcePretty f (FileSource _index origin value) =
+    let sourceDoc = case origin of
+          ConfigFileOrigin filepath -> Doc.text "File:" <+> Doc.text (Text.unpack filepath)
+          EnvFileOrigin envVar filepath ->
+            Doc.text "File:" <+> Doc.text (Text.unpack envVar) <> "=" <> Doc.text (Text.unpack filepath)
+        valueDoc = renderConfigValue f value
+    in (valueDoc, sourceDoc)
+
+fileSource :: Int -> Int -> FileValueOrigin -> Value JSON.Value -> SomeConfigSource
+fileSource precedenceOrder index origin val =
+  SomeConfigSource precedenceOrder $ FileSource index origin val
+
+data EnvSource = EnvSource
+  {
+    esVarName :: !Text
+  , esValue   :: !(Value JSON.Value)
+  }
+  deriving (Generic, Typeable, Show, Eq)
+
+instance NFData EnvSource
+instance IConfigSource EnvSource where
+  sourceValue = esValue
+  sourcePretty f (EnvSource varname value) =
+    let sourceDoc = Doc.text "Env:" <+> Doc.text (Text.unpack varname)
+        valueDoc  = renderConfigValue f value
+    in  (valueDoc, sourceDoc)
+
+envSource :: Int -> Text -> Value JSON.Value -> SomeConfigSource
+envSource precedenceOrder varName val =
+  SomeConfigSource precedenceOrder $ EnvSource varName val
+
+newtype DefaultSource =
+  DefaultSource (Value JSON.Value)
+  deriving (Generic, Typeable, Show, Eq, NFData)
+
+instance IConfigSource DefaultSource where
+  sourceValue (DefaultSource val) = val
+  sourcePretty f (DefaultSource value) =
+    let sourceDoc = Doc.text "Default"
+        valueDoc  = renderConfigValue f value
+    in  (valueDoc, sourceDoc)
+
+defaultSource :: Value JSON.Value -> SomeConfigSource
+defaultSource = SomeConfigSource 0 . DefaultSource
+
+--------------------------------------------------------------------------------
+-- TODO: Split out
+
+newtype CliSource
+  = CliSource (Value JSON.Value)
+  deriving (Generic, Typeable, Show, Eq, NFData)
+
+instance IConfigSource CliSource where
+  sourceValue (CliSource value) = value
+  sourcePretty f (CliSource value) =
+    let sourceDoc = Doc.text "Cli"
+        valueDoc  = renderConfigValue f value
+    in  (valueDoc, sourceDoc)
+
+cliSource :: Int -> Value JSON.Value -> SomeConfigSource
+cliSource precedenceOrder val = SomeConfigSource precedenceOrder $ CliSource val
+
+--------------------------------------------------------------------------------
 
 data ConfigValue
   = ConfigValue {
-      configSource :: !(Set ConfigSource)
+      configSource :: !(Set SomeConfigSource)
     }
   | SubConfig {
       configMap :: !(HashMap Text ConfigValue)
@@ -208,9 +301,9 @@ class IConfig config where
     :: (MonadThrow m)
     => [Text]
     -> config
-    -> m (Set ConfigSource)
+    -> m (Set SomeConfigSource)
   getSelectedConfigSource
     :: (MonadThrow m)
     => [Text]
     -> config
-    -> m ConfigSource
+    -> m SomeConfigSource
diff --git a/etc/test/System/Etc/Resolver/Cli/CommandTest.hs b/etc/test/System/Etc/Resolver/Cli/CommandTest.hs
index 045f3aa..eb2799f 100644
--- a/etc/test/System/Etc/Resolver/Cli/CommandTest.hs
+++ b/etc/test/System/Etc/Resolver/Cli/CommandTest.hs
@@ -11,6 +11,7 @@ import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)
 
 
 import System.Etc
+import System.Etc.Internal.Types (CliSource (..))
 
 with_command_option_tests :: TestTree
 with_command_option_tests = testGroup
@@ -40,8 +41,9 @@ with_command_option_tests = testGroup
 
     case getAllConfigSources ["greeting"] config of
       Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)
-      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                              (Set.member (Cli "hello cli") aSet)
+      Just aSet -> assertBool
+        ("expecting to see entry from env; got " <> show aSet)
+        (Set.member (SomeConfigSource 3 $ CliSource "hello cli") aSet)
   , testCase "entry accepts long" $ do
     let input = mconcat
           [ "{ \"etc/cli\": {"
@@ -70,8 +72,9 @@ with_command_option_tests = testGroup
 
     case getAllConfigSources ["greeting"] config of
       Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)
-      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                              (Set.member (Cli "hello cli") aSet)
+      Just aSet -> assertBool
+        ("expecting to see entry from env; got " <> show aSet)
+        (Set.member (SomeConfigSource 3 $ CliSource "hello cli") aSet)
   , testCase "entry gets validated with a type" $ do
     let input = mconcat
           [ "{ \"etc/cli\": {"
diff --git a/etc/test/System/Etc/Resolver/Cli/PlainTest.hs b/etc/test/System/Etc/Resolver/Cli/PlainTest.hs
index 8897e77..62f8eec 100644
--- a/etc/test/System/Etc/Resolver/Cli/PlainTest.hs
+++ b/etc/test/System/Etc/Resolver/Cli/PlainTest.hs
@@ -13,7 +13,8 @@ import qualified Data.Aeson as JSON
 import Test.Tasty       (TestTree, testGroup)
 import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)
 
-import qualified System.Etc as SUT
+import qualified System.Etc                as SUT
+import           System.Etc.Internal.Types (CliSource (..))
 
 resolver_tests :: TestTree
 resolver_tests = testGroup
@@ -96,8 +97,9 @@ option_tests = testGroup
 
     case SUT.getAllConfigSources ["greeting"] config of
       Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)
-      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                              (Set.member (SUT.Cli "hello cli") aSet)
+      Just aSet -> assertBool
+        ("expecting to see entry from env; got " <> show aSet)
+        (Set.member (SUT.SomeConfigSource 3 $ CliSource "hello cli") aSet)
   , testCase "entry accepts long" $ do
     let input = mconcat
           [ "{ \"etc/entries\": {"
@@ -115,8 +117,9 @@ option_tests = testGroup
 
     case SUT.getAllConfigSources ["greeting"] config of
       Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)
-      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                              (Set.member (SUT.Cli "hello cli") aSet)
+      Just aSet -> assertBool
+        ("expecting to see entry from env; got " <> show aSet)
+        (Set.member (SUT.SomeConfigSource 3 $ CliSource "hello cli") aSet)
   , testCase "entry gets validated with a type" $ do
     let input = mconcat
           [ "{ \"etc/entries\": {"
diff --git a/etc/test/System/Etc/Resolver/DefaultTest.hs b/etc/test/System/Etc/Resolver/DefaultTest.hs
index a9b0016..3a52e8c 100644
--- a/etc/test/System/Etc/Resolver/DefaultTest.hs
+++ b/etc/test/System/Etc/Resolver/DefaultTest.hs
@@ -11,12 +11,13 @@ import           Test.Tasty       (TestTree, testGroup)
 import           Test.Tasty.HUnit (assertBool, assertFailure, testCase)
 
 import System.Etc
+import System.Etc.Internal.Types (DefaultSource (..))
 
 assertDefaultValue :: Config -> [Text] -> Value JSON.Value -> IO ()
 assertDefaultValue config keys val = case getAllConfigSources keys config of
   Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)
   Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                          (Set.member (Default val) aSet)
+                          (Set.member (SomeConfigSource 0 $ DefaultSource val) aSet)
 
 tests :: TestTree
 tests = testGroup
@@ -47,6 +48,7 @@ tests = testGroup
 
     case getAllConfigSources ["greeting"] config of
       Nothing   -> assertFailure ("expecting to get entries for greeting\n" <> show config)
-      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                              (Set.member (Default $ Plain JSON.Null) aSet)
+      Just aSet -> assertBool
+        ("expecting to see entry from env; got " <> show aSet)
+        (Set.member (SomeConfigSource 0 $ DefaultSource $ Plain JSON.Null) aSet)
   ]
diff --git a/etc/test/System/Etc/Resolver/EnvTest.hs b/etc/test/System/Etc/Resolver/EnvTest.hs
index c3bd5da..8d67402 100644
--- a/etc/test/System/Etc/Resolver/EnvTest.hs
+++ b/etc/test/System/Etc/Resolver/EnvTest.hs
@@ -14,6 +14,7 @@ import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)
 import Paths_etc (getDataFileName)
 
 import System.Etc
+import System.Etc.Internal.Types (EnvSource (..))
 
 
 tests :: TestTree
@@ -31,8 +32,9 @@ tests = testGroup
     case getAllConfigSources ["greeting"] config of
       Nothing -> assertFailure
         ("expecting to get entries for greeting (check fixtures)\n" <> show config)
-      Just aSet -> assertBool ("expecting to see entry from env; got " <> show aSet)
-                              (Set.member (Env "GREETING" "hello env") aSet)
+      Just aSet -> assertBool
+        ("expecting to see entry from env; got " <> show aSet)
+        (Set.member (SomeConfigSource 2 $ EnvSource "GREETING" "hello env") aSet)
   , testCase "has precedence over default and file values" $ do
     jsonFilepath <- getDataFileName "test/fixtures/config.json"
     let input = mconcat
diff --git a/etc/test/System/Etc/Resolver/FileTest.hs b/etc/test/System/Etc/Resolver/FileTest.hs
index 9ce8de1..0cbc2f2 100644
--- a/etc/test/System/Etc/Resolver/FileTest.hs
+++ b/etc/test/System/Etc/Resolver/FileTest.hs
@@ -12,6 +12,8 @@ import qualified RIO.Text           as Text
 import qualified RIO.Vector         as Vector
 import qualified RIO.Vector.Partial as Vector (head)
 
+import Data.Typeable (cast)
+
 import Test.Tasty       (TestTree, testGroup)
 import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)
 
@@ -21,7 +23,7 @@ import           Paths_etc  (getDataFileName)
 import System.Environment (setEnv)
 
 import System.Etc
-import System.Etc.Internal.Types (FileSource (..))
+import System.Etc.Internal.Types (FileSource (..), FileValueOrigin (..))
 
 tests :: TestTree
 tests = testGroup
@@ -102,14 +104,19 @@ filePathsTests = testGroup
         ("expecting to get entries for greeting (check fixtures)\n" <> show config)
       Just aSet -> assertBool
         ("expecting to see entry from json config file " <> show aSet)
-        (Set.member (File 1 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet)
+        (Set.member
+          ( SomeConfigSource 1
+          $ FileSource 1 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello json"
+          )
+          aSet
+        )
 
 #ifdef WITH_YAML
        >> assertBool ("expecting to see entry from yaml config file " <> show aSet)
-                     (Set.member (File 2 (FilePathSource $ Text.pack jsonFilepath) "hello yaml") aSet)
+                     (Set.member (SomeConfigSource 1 $ FileSource 2 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello yaml") aSet)
 
        >> assertBool ("expecting to see entry from yml config file " <> show aSet)
-                     (Set.member (File 3 (FilePathSource $ Text.pack jsonFilepath) "hello yml") aSet)
+                     (Set.member (SomeConfigSource 1 $ FileSource 3 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello yml") aSet)
 #endif
   , testCase "does not support any other file extension" $ do
     fooFilepath <- getDataFileName "test/fixtures/config.foo"
@@ -151,7 +158,12 @@ filePathsTests = testGroup
         ("expecting to get entries for greeting (check fixtures)\n" <> show config)
       Just aSet -> assertBool
         ("expecting to see entry from json config file " <> show aSet)
-        (Set.member (File 1 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet)
+        (Set.member
+          ( SomeConfigSource 1
+          $ FileSource 1 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello json"
+          )
+          aSet
+        )
 
     if Vector.null errs
       then assertFailure "expecting one error, got none"
@@ -186,9 +198,9 @@ filePathsTests = testGroup
       Nothing -> assertFailure ("expecting to get entries for greeting\n" <> show config)
       Just aSet ->
         let result = any
-              (\entry -> case entry of
-                File _ _ (Plain JSON.Null) -> True
-                _                          -> False
+              (\(SomeConfigSource _ source) -> case cast source of
+                Just (FileSource _ _ (Plain JSON.Null)) -> True
+                _                                       -> False
               )
               aSet
         in  assertBool ("expecting to see entry from env; got " <> show aSet) result
@@ -235,13 +247,19 @@ filesTest = testGroup
         assertBool
           ("expecting to see entry from env config file " <> show aSet)
           (Set.member
-            (File 1
-                  (EnvVarFileSource envFileTest $ Text.pack envFilePath)
-                  "hello environment"
+            (SomeConfigSource 1 $ FileSource
+              1
+              (EnvFileOrigin envFileTest $ Text.pack envFilePath)
+              "hello environment"
             )
             aSet
           )
         assertBool
           ("expecting to see entry from json config file " <> show aSet)
-          (Set.member (File 2 (FilePathSource $ Text.pack jsonFilepath) "hello json") aSet)
+          (Set.member
+            ( SomeConfigSource 1
+            $ FileSource 2 (ConfigFileOrigin $ Text.pack jsonFilepath) "hello json"
+            )
+            aSet
+          )
   ]
diff --git a/examples/etc-command-example/src/Main.hs b/examples/etc-command-example/src/Main.hs
index 87b629a..57488ab 100644
--- a/examples/etc-command-example/src/Main.hs
+++ b/examples/etc-command-example/src/Main.hs
@@ -58,6 +58,10 @@ main = do
 
   Etc.reportEnvMisspellingWarnings configSpec
 
+  -- in case source fetching fails with an IO error, you may want to fail fast (e.g. vault)
+  -- config <- Etc.resolve [defaultCli, defaultVault, defaultEnv] configSpec
+  -- cmd <- Etc.resolveCommandCli configSpec
+  -- fileWarnings <- Etc.resolveFiles configSpec
   (configFiles, _fileWarnings) <- Etc.resolveFiles configSpec
   (cmd        , configCli    ) <- Etc.resolveCommandCli configSpec
   configEnv                    <- Etc.resolveEnv configSpec

From 9ad6de9ed50735b280daa28d74951c8fa937dafc Mon Sep 17 00:00:00 2001
From: Roman Gonzalez <romanandreg@gmail.com>
Date: Thu, 19 Jul 2018 17:38:54 -0700
Subject: [PATCH 2/6] [54] Improve upon pretty printer for sources

---
 etc/src/System/Etc/Internal/Extra/Printer.hs | 10 ++-
 etc/src/System/Etc/Internal/Types.hs         | 67 ++++++++------------
 2 files changed, 34 insertions(+), 43 deletions(-)

diff --git a/etc/src/System/Etc/Internal/Extra/Printer.hs b/etc/src/System/Etc/Internal/Extra/Printer.hs
index d08d3e3..a5dc7d2 100644
--- a/etc/src/System/Etc/Internal/Extra/Printer.hs
+++ b/etc/src/System/Etc/Internal/Extra/Printer.hs
@@ -89,8 +89,16 @@ 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) -> SomeConfigSource -> ([Doc], Doc)
-renderConfigSource = sourcePretty
+renderConfigSource f source =
+  (renderConfigValue f (sourceValue source), sourcePrettyDoc source)
 
 renderConfig_ :: MonadThrow m => ColorFn -> Config -> m Doc
 renderConfig_ ColorFn { blueColor } (Config configMap) =
diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs
index 5a46b96..34d0d20 100644
--- a/etc/src/System/Etc/Internal/Types.hs
+++ b/etc/src/System/Etc/Internal/Types.hs
@@ -10,18 +10,20 @@ module System.Etc.Internal.Types
   , module System.Etc.Internal.Spec.Types
   ) where
 
-import           RIO
+import           RIO         hiding ((<>))
 import qualified RIO.HashMap as HashMap
 import qualified RIO.Set     as Set
 import qualified RIO.Text    as Text
-import qualified RIO.Vector  as Vector
 
 import           Text.PrettyPrint.ANSI.Leijen (Doc, (<+>))
 import qualified Text.PrettyPrint.ANSI.Leijen as Doc
 
+
+
 import Control.Exception (throw)
 
 import           Data.Bool      (bool)
+import           Data.Monoid    ((<>))
 import qualified Data.Semigroup as Semigroup
 import           Data.Typeable  (cast, typeOf)
 
@@ -73,10 +75,10 @@ data FileValueOrigin
 instance NFData FileValueOrigin
 
 class IConfigSource source where
-  sourceValue   :: source -> Value JSON.Value
-  sourcePretty  :: (JSON.Value -> Doc) -> source -> ([Doc], Doc)
-  compareValues :: source -> source -> Ordering
-  compareValues _ _ = EQ
+  sourceValue     :: source -> Value JSON.Value
+  sourcePrettyDoc :: source -> Doc
+  compareSources  :: source -> source -> Ordering
+  compareSources _ _ = EQ
 
 data SomeConfigSource =
   forall source. ( Show source
@@ -101,25 +103,16 @@ data InvalidConfigSourceComparison
 
 instance Exception InvalidConfigSourceComparison
 
-renderConfigValue :: (JSON.Value -> Doc) -> Value JSON.Value -> [Doc]
-renderConfigValue f value = case value of
-  Plain (JSON.Array jsonArray) ->
-    Vector.toList $ Vector.map (\jsonValue -> Doc.text "-" <+> f jsonValue) jsonArray
-  Plain jsonValue -> return $ f jsonValue
-  Sensitive{}     -> return $ Doc.text "<<sensitive>>"
-
 instance IConfigSource SomeConfigSource where
-  sourceValue (SomeConfigSource _ inner) =
-    sourceValue inner
-  sourcePretty f (SomeConfigSource _ inner) =
-    sourcePretty f inner
-  compareValues x@(SomeConfigSource ia a) y@(SomeConfigSource ib b)
+  sourcePrettyDoc (SomeConfigSource _ inner) = sourcePrettyDoc inner
+  sourceValue (SomeConfigSource _ inner) = sourceValue inner
+  compareSources x@(SomeConfigSource ia a) y@(SomeConfigSource ib b)
     | ia == ib =
       if fromValue (sourceValue a) == JSON.Null && fromValue (sourceValue b) == JSON.Null then
         EQ
       else if typeOf a == typeOf b then
         let b' = fromMaybe (throw (InvalidConfigSourceComparison x y)) (cast a)
-        in compareValues a b'
+        in compareSources a b'
       else
         throw (InvalidConfigSourceComparison x y)
     | fromValue (sourceValue a) == JSON.Null = LT
@@ -128,10 +121,10 @@ instance IConfigSource SomeConfigSource where
       compare ia ib
 
 instance Eq SomeConfigSource where
-  (==) a b = compareValues a b == EQ
+  (==) a b = compareSources a b == EQ
 
 instance Ord SomeConfigSource where
-  compare = compareValues
+  compare = compareSources
 
 data FileSource = FileSource
   { fsConfigIndex :: !Int
@@ -141,15 +134,13 @@ data FileSource = FileSource
 
 instance NFData FileSource
 instance IConfigSource FileSource where
+  compareSources = comparing fsConfigIndex
   sourceValue = fsValue
-  compareValues = comparing fsConfigIndex
-  sourcePretty f (FileSource _index origin value) =
-    let sourceDoc = case origin of
-          ConfigFileOrigin filepath -> Doc.text "File:" <+> Doc.text (Text.unpack filepath)
-          EnvFileOrigin envVar filepath ->
-            Doc.text "File:" <+> Doc.text (Text.unpack envVar) <> "=" <> Doc.text (Text.unpack filepath)
-        valueDoc = renderConfigValue f value
-    in (valueDoc, sourceDoc)
+  sourcePrettyDoc (FileSource _index origin _value) =
+    case origin of
+      ConfigFileOrigin filepath -> Doc.text "File:" <+> Doc.text (Text.unpack filepath)
+      EnvFileOrigin envVar filepath ->
+        Doc.text "File:" <+> Doc.text (Text.unpack envVar) <> "=" <> Doc.text (Text.unpack filepath)
 
 fileSource :: Int -> Int -> FileValueOrigin -> Value JSON.Value -> SomeConfigSource
 fileSource precedenceOrder index origin val =
@@ -165,10 +156,8 @@ data EnvSource = EnvSource
 instance NFData EnvSource
 instance IConfigSource EnvSource where
   sourceValue = esValue
-  sourcePretty f (EnvSource varname value) =
-    let sourceDoc = Doc.text "Env:" <+> Doc.text (Text.unpack varname)
-        valueDoc  = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
+  sourcePrettyDoc (EnvSource varname _value) =
+    Doc.text "Env:" <+> Doc.text (Text.unpack varname)
 
 envSource :: Int -> Text -> Value JSON.Value -> SomeConfigSource
 envSource precedenceOrder varName val =
@@ -179,11 +168,8 @@ newtype DefaultSource =
   deriving (Generic, Typeable, Show, Eq, NFData)
 
 instance IConfigSource DefaultSource where
-  sourceValue (DefaultSource val) = val
-  sourcePretty f (DefaultSource value) =
-    let sourceDoc = Doc.text "Default"
-        valueDoc  = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
+  sourceValue (DefaultSource value) = value
+  sourcePrettyDoc (DefaultSource _value) = Doc.text "Default"
 
 defaultSource :: Value JSON.Value -> SomeConfigSource
 defaultSource = SomeConfigSource 0 . DefaultSource
@@ -197,10 +183,7 @@ newtype CliSource
 
 instance IConfigSource CliSource where
   sourceValue (CliSource value) = value
-  sourcePretty f (CliSource value) =
-    let sourceDoc = Doc.text "Cli"
-        valueDoc  = renderConfigValue f value
-    in  (valueDoc, sourceDoc)
+  sourcePrettyDoc (CliSource _value) = Doc.text "Cli"
 
 cliSource :: Int -> Value JSON.Value -> SomeConfigSource
 cliSource precedenceOrder val = SomeConfigSource precedenceOrder $ CliSource val

From e2099e0e89eb43554885568fb1e4a742d2143cb1 Mon Sep 17 00:00:00 2001
From: Roman Gonzalez <romanandreg@gmail.com>
Date: Thu, 19 Jul 2018 18:17:56 -0700
Subject: [PATCH 3/6] [54] Move Spec.ConfigValue to its own attribute records

---
 .../System/Etc/Internal/Extra/EnvMisspell.hs  |   2 +-
 .../Etc/Internal/Resolver/Cli/Command.hs      |   4 +-
 .../System/Etc/Internal/Resolver/Cli/Plain.hs |   4 +-
 .../System/Etc/Internal/Resolver/Default.hs   |   2 +-
 etc/src/System/Etc/Internal/Resolver/Env.hs   |  17 +--
 etc/src/System/Etc/Internal/Resolver/File.hs  |  15 +--
 etc/src/System/Etc/Internal/Spec/Parser.hs    |  32 ++---
 etc/src/System/Etc/Internal/Spec/Types.hs     |  22 ++--
 etc/test/System/Etc/SpecTest.hs               | 109 ++++++++++--------
 9 files changed, 114 insertions(+), 93 deletions(-)

diff --git a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs b/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs
index 924b9c0..4a0ea79 100644
--- a/etc/src/System/Etc/Internal/Extra/EnvMisspell.hs
+++ b/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
diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs
index 7abb400..81a75f9 100644
--- a/etc/src/System/Etc/Internal/Resolver/Cli/Command.hs
+++ b/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
 
diff --git a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs b/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs
index 62206c4..3debc1e 100644
--- a/etc/src/System/Etc/Internal/Resolver/Cli/Plain.hs
+++ b/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
 
diff --git a/etc/src/System/Etc/Internal/Resolver/Default.hs b/etc/src/System/Etc/Internal/Resolver/Default.hs
index 80aca80..c3bae2f 100644
--- a/etc/src/System/Etc/Internal/Resolver/Default.hs
+++ b/etc/src/System/Etc/Internal/Resolver/Default.hs
@@ -20,7 +20,7 @@ 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
diff --git a/etc/src/System/Etc/Internal/Resolver/Env.hs b/etc/src/System/Etc/Internal/Resolver/Env.hs
index dca762a..ac3b688 100644
--- a/etc/src/System/Etc/Internal/Resolver/Env.hs
+++ b/etc/src/System/Etc/Internal/Resolver/Env.hs
@@ -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 =
diff --git a/etc/src/System/Etc/Internal/Resolver/File.hs b/etc/src/System/Etc/Internal/Resolver/File.hs
index bc840b5..567d1eb 100644
--- a/etc/src/System/Etc/Internal/Resolver/File.hs
+++ b/etc/src/System/Etc/Internal/Resolver/File.hs
@@ -67,13 +67,14 @@ parseConfigValue keys spec fileIndex fileSource' 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 $ fileSource 1 fileIndex fileSource' $ markAsSensitive
-            isSensitive
-            json
-          )
+      (Spec.ConfigValue Spec.ConfigValueData { Spec.isSensitive, Spec.configValueType }, _)
+        -> do
+          either throwM return $ Spec.assertMatchingConfigValueType json configValueType
+          return $ ConfigValue
+            (Set.singleton $ fileSource 1 fileIndex fileSource' $ markAsSensitive
+              isSensitive
+              json
+            )
 
 
 
diff --git a/etc/src/System/Etc/Internal/Spec/Parser.hs b/etc/src/System/Etc/Internal/Spec/Parser.hs
index 36932ae..ab47ea3 100644
--- a/etc/src/System/Etc/Internal/Spec/Parser.hs
+++ b/etc/src/System/Etc/Internal/Spec/Parser.hs
@@ -241,13 +241,14 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
               mSensitive    <- fieldSpec .:? "sensitive"
               mCvType       <- fieldSpec .:? "type"
               let sensitive = fromMaybe False mSensitive
-              ConfigValue
-                <$> pure mDefaultValue
-                <*> getConfigValueType mDefaultValue mCvType
-                <*> pure sensitive
-                <*> (ConfigSources <$> fieldSpec .:? "env"
-                                   <*> fieldSpec .:? "cli")
-                <*> pure json
+              ConfigValue <$>
+                (ConfigValueData
+                  <$> pure mDefaultValue
+                  <*> getConfigValueType mDefaultValue mCvType
+                  <*> pure sensitive
+                  <*> (ConfigSources <$> fieldSpec .:? "env"
+                                     <*> fieldSpec .:? "cli")
+                  <*> pure json)
             else
               fail "etc/spec object can only contain one key"
 
@@ -258,14 +259,15 @@ instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
       _ -> do
         cvType <- either fail pure $ jsonToConfigValueType json
         return
-          ConfigValue
-          {
-            defaultValue    = Just json
-          , configValueType = cvType
-          , isSensitive     = False
-          , configSources   = ConfigSources Nothing Nothing
-          , rawConfigValue  = json
-          }
+          $ ConfigValue
+              ConfigValueData
+                {
+                  defaultValue    = Just json
+                , configValueType = cvType
+                , isSensitive     = False
+                , configSources   = ConfigSources Nothing Nothing
+                , rawConfigValue  = json
+                }
 
 parseFiles :: JSON.Value -> JSON.Parser FilesSpec
 parseFiles = JSON.withObject "FilesSpec" $ \object -> do
diff --git a/etc/src/System/Etc/Internal/Spec/Types.hs b/etc/src/System/Etc/Internal/Spec/Types.hs
index 74e972f..05f1339 100644
--- a/etc/src/System/Etc/Internal/Spec/Types.hs
+++ b/etc/src/System/Etc/Internal/Spec/Types.hs
@@ -185,23 +185,29 @@ instance Display ConfigValueType where
       CVTSingle singleVal -> display singleVal
       CVTArray  singleVal -> display $ "[" <> display singleVal <> "]"
 
-data ConfigValue cmd
-  = ConfigValue {
+data ConfigValueData cmd =
+  ConfigValueData {
     defaultValue    :: !(Maybe JSON.Value)
   , configValueType :: !ConfigValueType
   , isSensitive     :: !Bool
   , configSources   :: !(ConfigSources cmd)
   , rawConfigValue  :: !JSON.Value
   }
-  | SubConfig {
-    subConfig :: !(HashMap Text (ConfigValue cmd))
-  }
+  deriving (Generic, Show, Eq)
+
+instance Lift cmd => Lift (ConfigValueData cmd) where
+  lift ConfigValueData {defaultValue, configValueType, isSensitive, configSources, rawConfigValue } =
+    [| ConfigValueData defaultValue configValueType isSensitive configSources rawConfigValue |]
+
+data ConfigValue cmd
+  = ConfigValue !(ConfigValueData cmd)
+  | SubConfig   !(HashMap Text (ConfigValue cmd))
   deriving (Generic, Show, Eq)
 
 instance Lift cmd => Lift (ConfigValue cmd) where
-  lift ConfigValue {defaultValue, configValueType, isSensitive, configSources, rawConfigValue } =
-    [| ConfigValue defaultValue configValueType isSensitive configSources rawConfigValue |]
-  lift SubConfig {subConfig} =
+  lift (ConfigValue configValueData) =
+    [| ConfigValue configValueData |]
+  lift (SubConfig subConfig) =
     [| SubConfig (HashMap.fromList $ map (first Text.pack) subConfigList) |]
     where
       subConfigList = map (first Text.unpack) $ HashMap.toList subConfig
diff --git a/etc/test/System/Etc/SpecTest.hs b/etc/test/System/Etc/SpecTest.hs
index 924d01b..2eae9e9 100644
--- a/etc/test/System/Etc/SpecTest.hs
+++ b/etc/test/System/Etc/SpecTest.hs
@@ -79,26 +79,26 @@ general_tests = testGroup
     let input = "{\"etc/entries\":{\"greeting\":123}}"
         keys  = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
+      Just (ConfigValue value) -> assertEqual "should contain default value"
+                                              (Just (JSON.Number 123))
+                                              (defaultValue value)
+      _ -> assertFailure
         (show keys ++ " should map to a config value, got sub config map instead")
-      Just (value :: ConfigValue ()) -> assertEqual "should contain default value"
-                                                    (Just (JSON.Number 123))
-                                                    (defaultValue value)
   , testCase "entries that finish with arrays sets them as default value" $ do
     let input = "{\"etc/entries\":{\"greeting\":[123]}}"
         keys  = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
 
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
-        (show keys ++ " should map to a config value, got sub config map instead")
-      Just (value :: ConfigValue ()) -> assertEqual
+      Just (ConfigValue value) -> assertEqual
         "should contain default value"
         (Just (JSON.Array (Vector.fromList [JSON.Number 123])))
         (defaultValue value)
+      _ -> assertFailure
+        (show keys ++ " should map to a config value, got sub config map instead")
   , testCase "entries with empty arrays as values fail because type cannot be infered" $ do
     let input = "{\"etc/entries\":{\"greeting\": []}}"
     case SUT.parseConfigSpec input of
@@ -115,44 +115,43 @@ general_tests = testGroup
         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[],\"type\":\"[string]\"}}}}"
       keys = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
-        (show keys ++ " should map to an array config value, got sub config map instead")
+      Just (ConfigValue value) -> assertEqual "should contain default array value"
+                                              (Just (JSON.Array (Vector.fromList [])))
+                                              (defaultValue value)
 
-      Just (value :: ConfigValue ()) -> assertEqual
-        "should contain default array value"
-        (Just (JSON.Array (Vector.fromList [])))
-        (defaultValue value)
+      _ -> assertFailure
+        (show keys ++ " should map to an array config value, got sub config map instead")
   , testCase "entries with array of objects do not fail" $ do
     let
       input
         = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{\"default\":[{\"hello\":\"world\"}],\"type\":\"[object]\"}}}}"
       keys = ["greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
-        (show keys ++ " should map to an array config value, got sub config map instead")
-
-      Just (value :: ConfigValue ()) -> assertEqual
+      Just (ConfigValue value) -> assertEqual
         "should contain default array value"
         (Just
           (JSON.Array (Vector.fromList [JSON.object ["hello" JSON..= ("world" :: Text)]]))
         )
         (defaultValue value)
+
+      _ -> assertFailure
+        (show keys ++ " should map to an array config value, got sub config map instead")
   , testCase "entries can have many levels of nesting" $ do
     let input = "{\"etc/entries\":{\"english\":{\"greeting\":\"hello\"}}}"
         keys  = ["english", "greeting"]
 
-    config <- SUT.parseConfigSpec input
+    (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
 
     case getConfigValue keys (specConfigValues config) of
-      Nothing -> assertFailure
+      Just (ConfigValue value) -> assertEqual "should contain default value"
+                                              (Just (JSON.String "hello"))
+                                              (defaultValue value)
+      _ -> assertFailure
         (show keys ++ " should map to a config value, got sub config map instead")
-      Just (value :: ConfigValue ()) -> assertEqual "should contain default value"
-                                                    (Just (JSON.String "hello"))
-                                                    (defaultValue value)
   , testCase "spec map cannot be empty object" $ do
     let input = "{\"etc/entries\":{\"greeting\":{\"etc/spec\":{}}}"
 
@@ -233,11 +232,15 @@ cli_tests =
 
       let
         result = do
-          value    <- getConfigValue keys (specConfigValues config)
-          let valueType = configValueType value
-          PlainEntry (Opt metadata) <- cliEntry (configSources value)
-          short <- optShort metadata
-          return (short, valueType)
+          configValue    <- getConfigValue keys (specConfigValues config)
+          case configValue of
+            ConfigValue value -> do
+              let valueType = configValueType value
+              PlainEntry (Opt metadata) <- cliEntry (configSources value)
+              short <- optShort metadata
+              return (short, valueType)
+            _ ->
+              Nothing
 
       case result of
         Nothing ->
@@ -255,11 +258,15 @@ cli_tests =
 
       let
         result = do
-          value  <- getConfigValue keys (specConfigValues config)
-          let valueType = configValueType value
-          PlainEntry (Opt metadata) <- cliEntry (configSources value)
-          long <- optLong metadata
-          return (long, valueType)
+          configValue  <- getConfigValue keys (specConfigValues config)
+          case configValue of
+            ConfigValue value -> do
+              let valueType = configValueType value
+              PlainEntry (Opt metadata) <- cliEntry (configSources value)
+              long <- optLong metadata
+              return (long, valueType)
+            _ ->
+              Nothing
 
       case result of
         Nothing ->
@@ -277,11 +284,15 @@ cli_tests =
 
       let
         result = do
-          value <- getConfigValue keys (specConfigValues config)
-          let valueType = configValueType value
-          CmdEntry cmd (Opt metadata) <- cliEntry (configSources value)
-          long <- optLong metadata
-          return (cmd, long, valueType)
+          configValue <- getConfigValue keys (specConfigValues config)
+          case configValue of
+            (ConfigValue value) -> do
+              let valueType = configValueType value
+              CmdEntry cmd (Opt metadata) <- cliEntry (configSources value)
+              long <- optLong metadata
+              return (cmd, long, valueType)
+            _ ->
+              Nothing
 
       case result of
         Nothing ->
@@ -317,11 +328,11 @@ envvar_tests = testGroup
       (config :: ConfigSpec ()) <- SUT.parseConfigSpec input
 
       case getConfigValue keys (specConfigValues config) of
-        Nothing -> assertFailure
+        Just (ConfigValue value) -> assertEqual "should contain EnvVar value"
+                                                (ConfigSources (Just "GREETING") Nothing)
+                                                (configSources value)
+        _ -> assertFailure
           (show keys ++ " should map to a config value, got sub config map instead")
-        Just value -> assertEqual "should contain EnvVar value"
-                                  (ConfigSources (Just "GREETING") Nothing)
-                                  (configSources value)
   ]
 
 #ifdef WITH_YAML
@@ -341,13 +352,13 @@ yaml_tests =
 
         Right (config :: ConfigSpec ()) ->
           case getConfigValue keys (specConfigValues config) of
-            Nothing ->
-              assertFailure (show keys ++ " should map to a config value, got sub config map instead")
-
-            Just value ->
+            Just (ConfigValue value) ->
               assertEqual "should contain EnvVar value"
                           (ConfigSources (Just "GREETING") Nothing)
                           (configSources value)
+            _ ->
+              assertFailure (show keys ++ " should map to a config value, got sub config map instead")
+
   ]
 #endif
 

From 0a108fed16d6769d9955209db7c8a7885fa64d95 Mon Sep 17 00:00:00 2001
From: Roman Gonzalez <romanandreg@gmail.com>
Date: Thu, 19 Jul 2018 18:50:51 -0700
Subject: [PATCH 4/6] [54] Change signature of getSelectedConfigSource

---
 etc/src/System/Etc/Internal/Config.hs | 14 +++++++++-----
 etc/src/System/Etc/Internal/Types.hs  |  4 ++--
 2 files changed, 11 insertions(+), 7 deletions(-)

diff --git a/etc/src/System/Etc/Internal/Config.hs b/etc/src/System/Etc/Internal/Config.hs
index db9d3a7..cdd2f32 100644
--- a/etc/src/System/Etc/Internal/Config.hs
+++ b/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)
@@ -35,7 +37,7 @@ 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
@@ -63,13 +65,16 @@ _getConfigValueWith parser keys0 (Config configValue0) =
       _ -> throwM $ InvalidConfigKeyPath keys0
   in  loop keys0 configValue0
 
-_getSelectedConfigSource :: (MonadThrow m) => [Text] -> Config -> m SomeConfigSource
+_getSelectedConfigSource
+  :: (MonadThrow m, Typeable result, 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
@@ -94,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
diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs
index 34d0d20..1cdbdc7 100644
--- a/etc/src/System/Etc/Internal/Types.hs
+++ b/etc/src/System/Etc/Internal/Types.hs
@@ -286,7 +286,7 @@ class IConfig config where
     -> config
     -> m (Set SomeConfigSource)
   getSelectedConfigSource
-    :: (MonadThrow m)
+    :: (MonadThrow m, Typeable source, IConfigSource source)
     => [Text]
     -> config
-    -> m SomeConfigSource
+    -> m source

From 4f8d80618590f50306080a84e72217a1f90cbe43 Mon Sep 17 00:00:00 2001
From: Roman Gonzalez <romanandreg@gmail.com>
Date: Sat, 21 Jul 2018 14:55:59 -0700
Subject: [PATCH 5/6] [54] Move constraints from SomeConfigurationSource to
 IConfigSource

---
 etc/src/System/Etc/Internal/Types.hs | 14 ++++++--------
 1 file changed, 6 insertions(+), 8 deletions(-)

diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs
index 1cdbdc7..2c36037 100644
--- a/etc/src/System/Etc/Internal/Types.hs
+++ b/etc/src/System/Etc/Internal/Types.hs
@@ -74,18 +74,16 @@ data FileValueOrigin
 
 instance NFData FileValueOrigin
 
-class IConfigSource source where
-  sourceValue     :: source -> Value JSON.Value
+class (Show source, Typeable source) =>
+      IConfigSource source
+  where
+  sourceValue :: source -> Value JSON.Value
   sourcePrettyDoc :: source -> Doc
-  compareSources  :: source -> source -> Ordering
+  compareSources :: source -> source -> Ordering
   compareSources _ _ = EQ
 
 data SomeConfigSource =
-  forall source. ( Show source
-                 , NFData source
-                 , Typeable source
-                 , IConfigSource source
-                 ) =>
+  forall source. (IConfigSource source) =>
                  SomeConfigSource !Int
                                   !source
 

From d95f430c1a1e982b65973234c4366328b18a607a Mon Sep 17 00:00:00 2001
From: Roman Gonzalez <romanandreg@gmail.com>
Date: Sat, 21 Jul 2018 15:02:14 -0700
Subject: [PATCH 6/6] [54] Remove redudant typeclass constraint

---
 etc/src/System/Etc/Internal/Config.hs | 2 +-
 etc/src/System/Etc/Internal/Types.hs  | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/etc/src/System/Etc/Internal/Config.hs b/etc/src/System/Etc/Internal/Config.hs
index cdd2f32..9836266 100644
--- a/etc/src/System/Etc/Internal/Config.hs
+++ b/etc/src/System/Etc/Internal/Config.hs
@@ -66,7 +66,7 @@ _getConfigValueWith parser keys0 (Config configValue0) =
   in  loop keys0 configValue0
 
 _getSelectedConfigSource
-  :: (MonadThrow m, Typeable result, IConfigSource result) => [Text] -> Config -> m result
+  :: (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
diff --git a/etc/src/System/Etc/Internal/Types.hs b/etc/src/System/Etc/Internal/Types.hs
index 2c36037..9831661 100644
--- a/etc/src/System/Etc/Internal/Types.hs
+++ b/etc/src/System/Etc/Internal/Types.hs
@@ -284,7 +284,7 @@ class IConfig config where
     -> config
     -> m (Set SomeConfigSource)
   getSelectedConfigSource
-    :: (MonadThrow m, Typeable source, IConfigSource source)
+    :: (MonadThrow m, IConfigSource source)
     => [Text]
     -> config
     -> m source