-- |
-- Copyright: (c) 2019 Lucas David Traverso
-- License: MPL-2.0
-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>
-- Stability: unstable
-- Portability: portable
--
-- Internal module providing FromConfig functionality
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Conferer.FromConfig.Internal where

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Control.Exception
import Data.Typeable
import Text.Read (readMaybe)
import Data.Dynamic
import GHC.Generics
import Data.Function (on, (&))

import Conferer.Key
import Conferer.Config.Internal.Types
import Conferer.Config.Internal
import qualified Data.Char as Char
import Control.Monad (forM)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified System.FilePath as FilePath
import Data.List (nub, foldl', sort)
import Data.String (IsString(..))

-- | The typeclass for defining the way to get values from a 'Config', hiding the
-- 'Text' based nature of the 'Conferer.Source.Source's and parse whatever value
-- as the types sees fit
--
-- Some of these instances are provided in different packages to avoid the heavy
-- dependencies.
--
-- It provides a reasonable default using 'Generic's so most of the time user need
-- not to implement this typeclass.
class FromConfig a where
  -- | This function uses a 'Config' and a scoping 'Key' to get a value.
  --
  -- Some conventions:
  --
  -- * When some 'Key' is missing this function should throw 'MissingRequiredKey'
  --
  -- * For any t it should hold that @fetchFromConfig k (config & addDefault k t) == t@
  -- meaning that a default on the same key with the right type should be used as a
  -- default and with no configuration that value should be returned
  --
  -- * Try desconstructing the value in as many keys as possible since is allows easier
  -- partial overriding.
  fetchFromConfig :: Key -> Config -> IO a
  default fetchFromConfig :: (Typeable a, Generic a, IntoDefaultsG (Rep a), FromConfigG (Rep a)) => Key -> Config -> IO a
  fetchFromConfig Key
k Config
c = do
    Maybe a
defaultValue <- Key -> Config -> IO (Maybe a)
forall a. Typeable a => Key -> Config -> IO (Maybe a)
fetchFromDefaults @a Key
k Config
c
    let config :: Config
config =
          case Maybe a
defaultValue of
            Just a
d -> Config
c Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& [(Key, Dynamic)] -> Config -> Config
addDefaults (Key -> Rep a Any -> [(Key, Dynamic)]
forall (f :: * -> *) a.
IntoDefaultsG f =>
Key -> f a -> [(Key, Dynamic)]
intoDefaultsG Key
k (Rep a Any -> [(Key, Dynamic)]) -> Rep a Any -> [(Key, Dynamic)]
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
d)
            Maybe a
Nothing -> Config
c
    Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> IO (Rep a Any) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Config -> IO (Rep a Any)
forall (f :: * -> *) a. FromConfigG f => Key -> Config -> IO (f a)
fetchFromConfigG Key
k Config
config

-- | Utility only typeclass to smooth the naming differences between default values for
-- external library settings
--
-- This typeclass is not used internally it's only here for convinience for users
class DefaultConfig a where
  configDef :: a

instance {-# OVERLAPPABLE #-} Typeable a => FromConfig a where
  fetchFromConfig :: Key -> Config -> IO a
fetchFromConfig Key
key Config
config = do
    (Text -> Maybe a) -> Key -> Config -> IO a
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (Maybe a -> Text -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) Key
key Config
config

instance FromConfig () where
  fetchFromConfig :: Key -> Config -> IO ()
fetchFromConfig Key
_key Config
_config = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance FromConfig String where
  fetchFromConfig :: Key -> Config -> IO String
fetchFromConfig = (Text -> Maybe String) -> Key -> Config -> IO String
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Text -> String) -> Text -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)

instance {-# OVERLAPPABLE #-} (Typeable a, FromConfig a) =>
    FromConfig [a] where
  fetchFromConfig :: Key -> Config -> IO [a]
fetchFromConfig Key
key Config
config = do
    Maybe [Key]
keysForItems <- IO (Maybe [Key])
getSubkeysForItems
    case Maybe [Key]
keysForItems of
      Maybe [Key]
Nothing -> do
        Key -> Config -> IO [a]
forall a. Typeable a => Key -> Config -> IO a
fetchRequiredFromDefaults @[a] Key
key Config
config
      Just [Key]
subkeys -> do
        Maybe [a]
defaultsMay <- Key -> Config -> IO (Maybe [a])
forall a. Typeable a => Key -> Config -> IO (Maybe a)
fetchFromDefaults @[a] Key
key Config
config
        let Config
configWithDefaults :: Config =
              case Maybe [a]
defaultsMay of
                Just [a]
defaults ->
                  (Config -> (Integer, a) -> Config)
-> Config -> [(Integer, a)] -> Config
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Config
c (Integer
index, a
value) ->
                    Config
c Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& Key -> a -> Config -> Config
forall a. Typeable a => Key -> a -> Config -> Config
addDefault (Key
key Key -> Key -> Key
/. Key
"defaults" Key -> Key -> Key
/. String -> Key
mkKey (Integer -> String
forall a. Show a => a -> String
show Integer
index)) a
value) Config
config
                  ([(Integer, a)] -> Config) -> [(Integer, a)] -> Config
forall a b. (a -> b) -> a -> b
$ [Integer] -> [a] -> [(Integer, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 :: Integer ..] [a]
defaults
                Maybe [a]
Nothing -> Config
config
        [Key] -> (Key -> IO a) -> IO [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Key]
subkeys ((Key -> IO a) -> IO [a]) -> (Key -> IO a) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \Key
k -> do
          Key -> Config -> IO a
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @a (Key
key Key -> Key -> Key
/. Key
k)
            (if Key -> Key -> Bool
isKeyPrefixOf (Key
key Key -> Key -> Key
/. Key
"defaults") (Key
key Key -> Key -> Key
/. Key
k)
              then
                Config
configWithDefaults
              else
                Config
configWithDefaults Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& [KeyMapping] -> Config -> Config
addKeyMappings [(Key
key Key -> Key -> Key
/. Key
k, Key
key Key -> Key -> Key
/. Key
"prototype")])
    where
    getSubkeysForItems ::IO (Maybe [Key])
    getSubkeysForItems :: IO (Maybe [Key])
getSubkeysForItems = do
      Key -> Config -> IO (Maybe Text)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe Text) (Key
key Key -> Key -> Key
/. Key
"keys") Config
config
        IO (Maybe Text)
-> (Maybe Text -> IO (Maybe [Key])) -> IO (Maybe [Key])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Text
rawKeys -> do
            Maybe [Key] -> IO (Maybe [Key])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Key] -> IO (Maybe [Key]))
-> Maybe [Key] -> IO (Maybe [Key])
forall a b. (a -> b) -> a -> b
$
              [Key] -> Maybe [Key]
forall a. a -> Maybe a
Just ([Key] -> Maybe [Key]) -> [Key] -> Maybe [Key]
forall a b. (a -> b) -> a -> b
$
              [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$
              (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= Key
"") ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$
              String -> Key
mkKey (String -> Key) -> (Text -> String) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              Text -> String
Text.unpack (Text -> Key) -> [Text] -> [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') Text
rawKeys
          Maybe Text
Nothing -> do
            [Key]
subelements <-
              [Key] -> [Key]
forall a. Ord a => [a] -> [a]
sort
              ([Key] -> [Key]) -> ([Key] -> [Key]) -> [Key] -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub
              ([Key] -> [Key]) -> ([Key] -> [Key]) -> [Key] -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Key -> Bool) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
"prototype", Key
"keys", Key
"defaults"]))
              ([Key] -> [Key]) -> ([Key] -> [Key]) -> [Key] -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Maybe Key) -> [Key] -> [Key]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Key
k -> case Key -> [Text]
rawKeyComponents (Key -> [Text]) -> Maybe Key -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Key -> Maybe Key
stripKeyPrefix Key
key Key
k of
                    Just (Text
subkey:[Text]
_) -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ Text -> Key
fromText Text
subkey
                    Maybe [Text]
_ -> Maybe Key
forall a. Maybe a
Nothing)
              ([Key] -> [Key]) -> IO [Key] -> IO [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Config -> IO [Key]
listSubkeys Key
key Config
config
            Maybe [Key] -> IO (Maybe [Key])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Key] -> IO (Maybe [Key]))
-> Maybe [Key] -> IO (Maybe [Key])
forall a b. (a -> b) -> a -> b
$ if [Key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
subelements then Maybe [Key]
forall a. Maybe a
Nothing else [Key] -> Maybe [Key]
forall a. a -> Maybe a
Just [Key]
subelements

instance FromConfig Int where
  fetchFromConfig :: Key -> Config -> IO Int
fetchFromConfig = Key -> Config -> IO Int
forall a. (Typeable a, Read a) => Key -> Config -> IO a
fetchFromConfigByRead

instance FromConfig Integer where
  fetchFromConfig :: Key -> Config -> IO Integer
fetchFromConfig Key
k Config
c = do
    Key -> Config -> IO Integer
forall a. (Typeable a, Read a) => Key -> Config -> IO a
fetchFromConfigByRead Key
k Config
c

instance FromConfig Float where
  fetchFromConfig :: Key -> Config -> IO Float
fetchFromConfig = Key -> Config -> IO Float
forall a. (Typeable a, Read a) => Key -> Config -> IO a
fetchFromConfigByRead

instance FromConfig BS.ByteString where
  fetchFromConfig :: Key -> Config -> IO ByteString
fetchFromConfig = (Text -> Maybe ByteString) -> Key -> Config -> IO ByteString
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Text -> ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8)

instance FromConfig LBS.ByteString where
  fetchFromConfig :: Key -> Config -> IO ByteString
fetchFromConfig = (Text -> Maybe ByteString) -> Key -> Config -> IO ByteString
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Text -> ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8)

instance forall a. (Typeable a, FromConfig a) => FromConfig (Maybe a) where
  fetchFromConfig :: Key -> Config -> IO (Maybe a)
fetchFromConfig Key
key Config
config = do
    let
      newConfig :: Config
newConfig =
        case Key -> Config -> Maybe Dynamic
getKeyFromDefaults Key
key Config
config Maybe Dynamic -> (Dynamic -> Maybe (Maybe a)) -> Maybe (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Typeable (Maybe a) => Dynamic -> Maybe (Maybe a)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(Maybe a) of
        Just (Just a
defaultThing) -> do
          Config
config Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& Key -> a -> Config -> Config
forall a. Typeable a => Key -> a -> Config -> Config
addDefault Key
key a
defaultThing
        Just Maybe a
Nothing -> do
          Config
config Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& Key -> Config -> Config
removeDefault Key
key
        Maybe (Maybe a)
_ -> do
          Config
config
    (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Config -> IO a
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @a Key
key Config
newConfig)
      IO (Maybe a)
-> (MissingRequiredKey -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(MissingRequiredKey
_e :: MissingRequiredKey) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)

instance FromConfig Text where
  fetchFromConfig :: Key -> Config -> IO Text
fetchFromConfig = (Text -> Maybe Text) -> Key -> Config -> IO Text
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith Text -> Maybe Text
forall a. a -> Maybe a
Just

instance FromConfig Bool where
  fetchFromConfig :: Key -> Config -> IO Bool
fetchFromConfig = (Text -> Maybe Bool) -> Key -> Config -> IO Bool
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith Text -> Maybe Bool
parseBool

-- | A newtype wrapper for a 'FilePath' to allow implementing 'FromConfig'
-- with something better than just a 'String'
newtype File =
  File FilePath
  deriving (Int -> File -> ShowS
[File] -> ShowS
File -> String
(Int -> File -> ShowS)
-> (File -> String) -> ([File] -> ShowS) -> Show File
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [File] -> ShowS
$cshowList :: [File] -> ShowS
show :: File -> String
$cshow :: File -> String
showsPrec :: Int -> File -> ShowS
$cshowsPrec :: Int -> File -> ShowS
Show, File -> File -> Bool
(File -> File -> Bool) -> (File -> File -> Bool) -> Eq File
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: File -> File -> Bool
$c/= :: File -> File -> Bool
== :: File -> File -> Bool
$c== :: File -> File -> Bool
Eq, Eq File
Eq File
-> (File -> File -> Ordering)
-> (File -> File -> Bool)
-> (File -> File -> Bool)
-> (File -> File -> Bool)
-> (File -> File -> Bool)
-> (File -> File -> File)
-> (File -> File -> File)
-> Ord File
File -> File -> Bool
File -> File -> Ordering
File -> File -> File
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: File -> File -> File
$cmin :: File -> File -> File
max :: File -> File -> File
$cmax :: File -> File -> File
>= :: File -> File -> Bool
$c>= :: File -> File -> Bool
> :: File -> File -> Bool
$c> :: File -> File -> Bool
<= :: File -> File -> Bool
$c<= :: File -> File -> Bool
< :: File -> File -> Bool
$c< :: File -> File -> Bool
compare :: File -> File -> Ordering
$ccompare :: File -> File -> Ordering
$cp1Ord :: Eq File
Ord, ReadPrec [File]
ReadPrec File
Int -> ReadS File
ReadS [File]
(Int -> ReadS File)
-> ReadS [File] -> ReadPrec File -> ReadPrec [File] -> Read File
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [File]
$creadListPrec :: ReadPrec [File]
readPrec :: ReadPrec File
$creadPrec :: ReadPrec File
readList :: ReadS [File]
$creadList :: ReadS [File]
readsPrec :: Int -> ReadS File
$creadsPrec :: Int -> ReadS File
Read)

instance IsString File where
  fromString :: String -> File
fromString String
s = String -> File
File String
s

instance FromConfig File where
  fetchFromConfig :: Key -> Config -> IO File
fetchFromConfig Key
key Config
config = do
    Maybe String
filepath <- Key -> Config -> IO (Maybe String)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe String) Key
key Config
config

    Maybe String
extension <- Key -> Config -> IO (Maybe String)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe String) (Key
key Key -> Key -> Key
/. Key
"extension") Config
config
    Maybe String
dirname <- Key -> Config -> IO (Maybe String)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe String) (Key
key Key -> Key -> Key
/. Key
"dirname") Config
config
    Maybe String
basename <- Key -> Config -> IO (Maybe String)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe String) (Key
key Key -> Key -> Key
/. Key
"basename") Config
config
    Maybe String
filename <- Key -> Config -> IO (Maybe String)
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @(Maybe String) (Key
key Key -> Key -> Key
/. Key
"filename") Config
config

    let
      constructedFilePath :: String
constructedFilePath =
        (String -> ShowS) -> Maybe String -> ShowS
forall t a. (t -> a -> t) -> Maybe a -> t -> t
applyIfPresent String -> ShowS
FilePath.replaceDirectory Maybe String
dirname
        ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> Maybe String -> ShowS
forall t a. (t -> a -> t) -> Maybe a -> t -> t
applyIfPresent String -> ShowS
FilePath.replaceBaseName Maybe String
basename
        ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> Maybe String -> ShowS
forall t a. (t -> a -> t) -> Maybe a -> t -> t
applyIfPresent String -> ShowS
FilePath.replaceExtension Maybe String
extension
        ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> Maybe String -> ShowS
forall t a. (t -> a -> t) -> Maybe a -> t -> t
applyIfPresent String -> ShowS
FilePath.replaceFileName Maybe String
filename
        ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
filepath
    if String -> Bool
FilePath.isValid String
constructedFilePath
      then File -> IO File
forall (m :: * -> *) a. Monad m => a -> m a
return (File -> IO File) -> File -> IO File
forall a b. (a -> b) -> a -> b
$ String -> File
File String
constructedFilePath
      else [Key] -> IO File
forall t a. Typeable t => [Key] -> IO a
throwMissingRequiredKeys @String
        [ Key
key
        , Key
key Key -> Key -> Key
/. Key
"extension"
        , Key
key Key -> Key -> Key
/. Key
"dirname"
        , Key
key Key -> Key -> Key
/. Key
"basename"
        , Key
key Key -> Key -> Key
/. Key
"filename"
        ]
    where
      applyIfPresent :: (t -> a -> t) -> Maybe a -> t -> t
applyIfPresent t -> a -> t
f Maybe a
maybeComponent =
        (\t
fp -> t -> (a -> t) -> Maybe a -> t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe t
fp (t -> a -> t
f t
fp) Maybe a
maybeComponent)

-- | Helper function to parse a 'Bool' from 'Text'
parseBool :: Text -> Maybe Bool
parseBool :: Text -> Maybe Bool
parseBool Text
text =
  case Text -> Text
Text.toLower Text
text of
    Text
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    Text
"true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    Text
_ -> Maybe Bool
forall a. Maybe a
Nothing

-- | Helper function to implement fetchFromConfig using the 'Read' instance
fetchFromConfigByRead :: (Typeable a, Read a) => Key -> Config -> IO a
fetchFromConfigByRead :: Key -> Config -> IO a
fetchFromConfigByRead = (Text -> Maybe a) -> Key -> Config -> IO a
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (Text -> String) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)

-- | Helper function to implement fetchFromConfig using the 'IsString' instance
fetchFromConfigByIsString :: (Typeable a, IsString a) => Key -> Config -> IO a
fetchFromConfigByIsString :: Key -> Config -> IO a
fetchFromConfigByIsString = (Text -> Maybe a) -> Key -> Config -> IO a
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (Text -> a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)

-- | Helper function to implement fetchFromConfig using some parsing function
fetchFromConfigWith :: forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith :: (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith Text -> Maybe a
parseValue Key
key Config
config = do
  Key -> Config -> IO KeyLookupResult
getKey Key
key Config
config IO KeyLookupResult -> (KeyLookupResult -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      MissingKey [Key]
k -> do
        [Key] -> IO a
forall t a. Typeable t => [Key] -> IO a
throwMissingRequiredKeys @a [Key]
k

      FoundInSources Key
k Text
value ->
        case Text -> Maybe a
parseValue Text
value of
          Just a
a -> do
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
          Maybe a
Nothing -> do
            Key -> Text -> IO a
forall a b. Typeable a => Key -> Text -> IO b
throwConfigParsingError @a Key
k Text
value

      FoundInDefaults Key
k Dynamic
dynamic ->
        case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dynamic of
          Just a
a -> do
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
          Maybe a
Nothing -> do
            Key -> Dynamic -> IO a
forall a b. Typeable a => Key -> Dynamic -> IO b
throwTypeMismatchWithDefault @a Key
k Dynamic
dynamic


-- | Helper function does the plumbing of desconstructing a default into smaller
-- defaults, which is usefull for nested 'fetchFromConfig'.
addDefaultsAfterDeconstructingToDefaults
  :: forall a.
  Typeable a =>
  -- | Function to deconstruct the value
  (a -> [(Key, Dynamic)]) ->
  -- | Key where to look for the value
  Key ->
  -- | The config
  Config ->
  IO Config
addDefaultsAfterDeconstructingToDefaults :: (a -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
addDefaultsAfterDeconstructingToDefaults a -> [(Key, Dynamic)]
destructureValue Key
key Config
config = do
  Key -> Config -> IO (Maybe a)
forall a. Typeable a => Key -> Config -> IO (Maybe a)
fetchFromDefaults @a Key
key Config
config
    IO (Maybe a) -> (Maybe a -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just a
value -> do
      let newDefaults :: [(Key, Dynamic)]
newDefaults =
            ((\(Key
k, Dynamic
d) -> (Key
key Key -> Key -> Key
/. Key
k, Dynamic
d)) ((Key, Dynamic) -> (Key, Dynamic))
-> [(Key, Dynamic)] -> [(Key, Dynamic)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [(Key, Dynamic)]
destructureValue a
value)
      Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$
        [(Key, Dynamic)] -> Config -> Config
addDefaults [(Key, Dynamic)]
newDefaults Config
config
    Maybe a
Nothing -> do
      Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
config

-- | Exception to show that a value couldn't be parsed properly
data ConfigParsingError =
  ConfigParsingError Key Text TypeRep
  deriving (Typeable, ConfigParsingError -> ConfigParsingError -> Bool
(ConfigParsingError -> ConfigParsingError -> Bool)
-> (ConfigParsingError -> ConfigParsingError -> Bool)
-> Eq ConfigParsingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigParsingError -> ConfigParsingError -> Bool
$c/= :: ConfigParsingError -> ConfigParsingError -> Bool
== :: ConfigParsingError -> ConfigParsingError -> Bool
$c== :: ConfigParsingError -> ConfigParsingError -> Bool
Eq)

instance Exception ConfigParsingError
instance Show ConfigParsingError where
  show :: ConfigParsingError -> String
show (ConfigParsingError Key
key Text
value TypeRep
aTypeRep) =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Couldn't parse value '"
    , Text -> String
Text.unpack Text
value
    , String
"' from key '"
    , Key -> String
forall a. Show a => a -> String
show Key
key
    , String
"' as "
    , TypeRep -> String
forall a. Show a => a -> String
show TypeRep
aTypeRep
    ]

-- | Helper function to throw 'ConfigParsingError'
throwConfigParsingError :: forall a b. (Typeable a) => Key -> Text -> IO b
throwConfigParsingError :: Key -> Text -> IO b
throwConfigParsingError Key
key Text
text =
  ConfigParsingError -> IO b
forall e a. Exception e => e -> IO a
throwIO (ConfigParsingError -> IO b) -> ConfigParsingError -> IO b
forall a b. (a -> b) -> a -> b
$ Key -> Text -> ConfigParsingError
forall a. Typeable a => Key -> Text -> ConfigParsingError
configParsingError @a  Key
key Text
text

-- | Helper function to create a 'ConfigParsingError'
configParsingError :: forall a. (Typeable a) => Key -> Text -> ConfigParsingError
configParsingError :: Key -> Text -> ConfigParsingError
configParsingError Key
key Text
text =
  Key -> Text -> TypeRep -> ConfigParsingError
ConfigParsingError Key
key Text
text (TypeRep -> ConfigParsingError) -> TypeRep -> ConfigParsingError
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

-- | Exception to show that some non optional 'Key' was missing while trying
-- to 'fetchFromConfig'
data MissingRequiredKey =
  MissingRequiredKey [Key] TypeRep
  deriving (Typeable, MissingRequiredKey -> MissingRequiredKey -> Bool
(MissingRequiredKey -> MissingRequiredKey -> Bool)
-> (MissingRequiredKey -> MissingRequiredKey -> Bool)
-> Eq MissingRequiredKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MissingRequiredKey -> MissingRequiredKey -> Bool
$c/= :: MissingRequiredKey -> MissingRequiredKey -> Bool
== :: MissingRequiredKey -> MissingRequiredKey -> Bool
$c== :: MissingRequiredKey -> MissingRequiredKey -> Bool
Eq)

instance Exception MissingRequiredKey
instance Show MissingRequiredKey where
  show :: MissingRequiredKey -> String
show (MissingRequiredKey [Key]
keys TypeRep
aTypeRep) =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Failed to get a '"
    , TypeRep -> String
forall a. Show a => a -> String
show TypeRep
aTypeRep
    , String
"' from keys: "
    , Text -> String
Text.unpack
      (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
", "
      ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
Text.pack (String -> Text) -> (Key -> String) -> Key -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String
forall a. Show a => a -> String
show)
      ([Key] -> [Text]) -> [Key] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Key]
keys

    ]

-- | Simplified helper function to throw a 'MissingRequiredKey'
throwMissingRequiredKey :: forall t a. Typeable t => Key -> IO a
throwMissingRequiredKey :: Key -> IO a
throwMissingRequiredKey Key
key =
  [Key] -> IO a
forall t a. Typeable t => [Key] -> IO a
throwMissingRequiredKeys @t [Key
key]

-- | Simplified helper function to create a 'MissingRequiredKey'
missingRequiredKey :: forall t. Typeable t => Key -> MissingRequiredKey
missingRequiredKey :: Key -> MissingRequiredKey
missingRequiredKey Key
key =
  [Key] -> MissingRequiredKey
forall a. Typeable a => [Key] -> MissingRequiredKey
missingRequiredKeys @t [Key
key]

-- | Helper function to throw a 'MissingRequiredKey'
throwMissingRequiredKeys :: forall t a. Typeable t => [Key] -> IO a
throwMissingRequiredKeys :: [Key] -> IO a
throwMissingRequiredKeys [Key]
keys =
  MissingRequiredKey -> IO a
forall e a. Exception e => e -> IO a
throwIO (MissingRequiredKey -> IO a) -> MissingRequiredKey -> IO a
forall a b. (a -> b) -> a -> b
$ [Key] -> MissingRequiredKey
forall a. Typeable a => [Key] -> MissingRequiredKey
missingRequiredKeys @t [Key]
keys

-- | Helper function to create a 'MissingRequiredKey'
missingRequiredKeys :: forall a. (Typeable a) => [Key] -> MissingRequiredKey
missingRequiredKeys :: [Key] -> MissingRequiredKey
missingRequiredKeys [Key]
keys =
  [Key] -> TypeRep -> MissingRequiredKey
MissingRequiredKey [Key]
keys (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

-- | Exception to show that the provided default had the wrong type, this is usually a
-- programmer error and a user that configures the library can not do much to fix it.
data TypeMismatchWithDefault =
  TypeMismatchWithDefault Key Dynamic TypeRep
  deriving (Typeable)

instance Eq TypeMismatchWithDefault where
  == :: TypeMismatchWithDefault -> TypeMismatchWithDefault -> Bool
(==) = (Key, String, TypeRep) -> (Key, String, TypeRep) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Key, String, TypeRep) -> (Key, String, TypeRep) -> Bool)
-> (TypeMismatchWithDefault -> (Key, String, TypeRep))
-> TypeMismatchWithDefault
-> TypeMismatchWithDefault
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on`
    (\(TypeMismatchWithDefault Key
k Dynamic
dyn TypeRep
t) -> (Key
k, Dynamic -> String
forall a. Show a => a -> String
show Dynamic
dyn, TypeRep
t))
instance Exception TypeMismatchWithDefault
instance Show TypeMismatchWithDefault where
  show :: TypeMismatchWithDefault -> String
show (TypeMismatchWithDefault Key
key Dynamic
dyn TypeRep
aTypeRep) =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Couldn't parse the default from key "
    , Key -> String
forall a. Show a => a -> String
show Key
key
    , String
" since there is a type mismatch. "
    , String
"Expected type is "
    , TypeRep -> String
forall a. Show a => a -> String
show TypeRep
aTypeRep
    , String
" but the actual type is '"
    , Dynamic -> String
forall a. Show a => a -> String
show Dynamic
dyn
    , String
"'"
    ]

-- | Helper function to throw a 'TypeMismatchWithDefault'
throwTypeMismatchWithDefault :: forall a b. (Typeable a) => Key -> Dynamic -> IO b
throwTypeMismatchWithDefault :: Key -> Dynamic -> IO b
throwTypeMismatchWithDefault Key
key Dynamic
dynamic =
  TypeMismatchWithDefault -> IO b
forall e a. Exception e => e -> IO a
throwIO (TypeMismatchWithDefault -> IO b)
-> TypeMismatchWithDefault -> IO b
forall a b. (a -> b) -> a -> b
$ Key -> Dynamic -> TypeMismatchWithDefault
forall a. Typeable a => Key -> Dynamic -> TypeMismatchWithDefault
typeMismatchWithDefault @a  Key
key Dynamic
dynamic

-- | Helper function to create a 'TypeMismatchWithDefault'
typeMismatchWithDefault :: forall a. (Typeable a) => Key -> Dynamic -> TypeMismatchWithDefault
typeMismatchWithDefault :: Key -> Dynamic -> TypeMismatchWithDefault
typeMismatchWithDefault Key
key Dynamic
dynamic =
  Key -> Dynamic -> TypeRep -> TypeMismatchWithDefault
TypeMismatchWithDefault Key
key Dynamic
dynamic (TypeRep -> TypeMismatchWithDefault)
-> TypeRep -> TypeMismatchWithDefault
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

-- | Fetch from value from the defaults map of a 'Config' or else throw
fetchRequiredFromDefaults :: forall a. (Typeable a) => Key -> Config -> IO a
fetchRequiredFromDefaults :: Key -> Config -> IO a
fetchRequiredFromDefaults Key
key Config
config =
  Key -> Config -> IO (Maybe a)
forall a. Typeable a => Key -> Config -> IO (Maybe a)
fetchFromDefaults Key
key Config
config IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
    Maybe a
Nothing -> do
      Key -> IO a
forall t a. Typeable t => Key -> IO a
throwMissingRequiredKey @a Key
key
    Just a
a ->
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Fetch from value from the defaults map of a 'Config' or else return a 'Nothing'
fetchFromDefaults :: forall a. (Typeable a) => Key -> Config -> IO (Maybe a)
fetchFromDefaults :: Key -> Config -> IO (Maybe a)
fetchFromDefaults Key
key Config
config =
  case Key -> Config -> Maybe Dynamic
getKeyFromDefaults Key
key Config
config of
    Maybe Dynamic
Nothing -> do
      Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just Dynamic
dyn ->
      case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @a Dynamic
dyn of
        Maybe a
Nothing ->
          Key -> Dynamic -> IO (Maybe a)
forall a b. Typeable a => Key -> Dynamic -> IO b
throwTypeMismatchWithDefault @a Key
key Dynamic
dyn
        Just a
a -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a

-- | Same as 'fetchFromConfig' using the root key
fetchFromRootConfig :: forall a. (FromConfig a) => Config -> IO a
fetchFromRootConfig :: Config -> IO a
fetchFromRootConfig =
  Key -> Config -> IO a
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig Key
""

-- | Same as 'fetchFromConfig' but adding a user defined default before 'fetchFromConfig'ing
-- so it doesn't throw a MissingKeyError
fetchFromConfigWithDefault :: forall a. (Typeable a, FromConfig a) => Config -> Key -> a -> IO a
fetchFromConfigWithDefault :: Config -> Key -> a -> IO a
fetchFromConfigWithDefault Config
config Key
key a
configDefault =
  Key -> Config -> IO a
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig Key
key (Config
config Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& Key -> a -> Config -> Config
forall a. Typeable a => Key -> a -> Config -> Config
addDefault Key
key a
configDefault)

-- | Same as 'fetchFromConfigWithDefault' using the root key
fetchFromRootConfigWithDefault :: forall a. (Typeable a, FromConfig a) => Config -> a -> IO a
fetchFromRootConfigWithDefault :: Config -> a -> IO a
fetchFromRootConfigWithDefault Config
config a
configDefault =
  Config -> IO a
forall a. FromConfig a => Config -> IO a
fetchFromRootConfig (Config
config Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& Key -> a -> Config -> Config
forall a. Typeable a => Key -> a -> Config -> Config
addDefault Key
"" a
configDefault)

-- | Purely 'Generic's machinery, ignore...
class FromConfigG f where
  fetchFromConfigG :: Key -> Config -> IO (f a)

instance FromConfigG inner =>
    FromConfigG (D1 metadata inner) where
  fetchFromConfigG :: Key -> Config -> IO (D1 metadata inner a)
fetchFromConfigG Key
key Config
config = do
    inner a -> D1 metadata inner a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (inner a -> D1 metadata inner a)
-> IO (inner a) -> IO (D1 metadata inner a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Config -> IO (inner a)
forall (f :: * -> *) a. FromConfigG f => Key -> Config -> IO (f a)
fetchFromConfigG Key
key Config
config

instance (FromConfigWithConNameG inner, Constructor constructor) =>
    FromConfigG (C1 constructor inner) where
  fetchFromConfigG :: Key -> Config -> IO (C1 constructor inner a)
fetchFromConfigG Key
key Config
config =
    inner a -> C1 constructor inner a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (inner a -> C1 constructor inner a)
-> IO (inner a) -> IO (C1 constructor inner a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Key -> Config -> IO (inner a)
forall (f :: * -> *) a.
FromConfigWithConNameG f =>
String -> Key -> Config -> IO (f a)
fetchFromConfigWithConNameG @inner (Any constructor Any Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName @constructor Any constructor Any Any
forall a. HasCallStack => a
undefined) Key
key Config
config

-- | Purely 'Generic's machinery, ignore...
class FromConfigWithConNameG f where
  fetchFromConfigWithConNameG :: String -> Key -> Config -> IO (f a)

instance (FromConfigWithConNameG left, FromConfigWithConNameG right) =>
    FromConfigWithConNameG (left :*: right) where
  fetchFromConfigWithConNameG :: String -> Key -> Config -> IO ((:*:) left right a)
fetchFromConfigWithConNameG String
s Key
key Config
config = do
    left a
leftValue <- String -> Key -> Config -> IO (left a)
forall (f :: * -> *) a.
FromConfigWithConNameG f =>
String -> Key -> Config -> IO (f a)
fetchFromConfigWithConNameG @left String
s Key
key Config
config
    right a
rightValue <- String -> Key -> Config -> IO (right a)
forall (f :: * -> *) a.
FromConfigWithConNameG f =>
String -> Key -> Config -> IO (f a)
fetchFromConfigWithConNameG @right String
s Key
key Config
config
    (:*:) left right a -> IO ((:*:) left right a)
forall (m :: * -> *) a. Monad m => a -> m a
return (left a
leftValue left a -> right a -> (:*:) left right a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: right a
rightValue)

instance (FromConfigG inner, Selector selector) =>
    FromConfigWithConNameG (S1 selector inner) where
  fetchFromConfigWithConNameG :: String -> Key -> Config -> IO (S1 selector inner a)
fetchFromConfigWithConNameG String
s Key
key Config
config =
    let
      applyFirst :: (Char -> Char) -> Text -> Text
      applyFirst :: (Char -> Char) -> Text -> Text
applyFirst Char -> Char
f Text
t = case Text -> Maybe (Char, Text)
Text.uncons Text
t of
        Just (Char
c, Text
ts) -> Char -> Text -> Text
Text.cons (Char -> Char
f Char
c) Text
ts
        Maybe (Char, Text)
Nothing -> Text
t

      fieldName :: Text
fieldName = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Any selector Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName @selector Any selector Any Any
forall a. HasCallStack => a
undefined
      prefix :: Text
prefix = (Char -> Char) -> Text -> Text
applyFirst Char -> Char
Char.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
      scopedKey :: Text
scopedKey =
        case Text -> Text -> Maybe Text
Text.stripPrefix Text
prefix Text
fieldName of
          Just Text
stripped -> (Char -> Char) -> Text -> Text
applyFirst Char -> Char
Char.toLower Text
stripped
          Maybe Text
Nothing -> Text
fieldName
    in inner a -> S1 selector inner a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (inner a -> S1 selector inner a)
-> IO (inner a) -> IO (S1 selector inner a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Config -> IO (inner a)
forall (f :: * -> *) a. FromConfigG f => Key -> Config -> IO (f a)
fetchFromConfigG @inner (Key
key Key -> Key -> Key
/. Text -> Key
fromText Text
scopedKey) Config
config

instance (FromConfig inner) => FromConfigG (Rec0 inner) where
  fetchFromConfigG :: Key -> Config -> IO (Rec0 inner a)
fetchFromConfigG Key
key Config
config = do
    inner -> Rec0 inner a
forall k i c (p :: k). c -> K1 i c p
K1 (inner -> Rec0 inner a) -> IO inner -> IO (Rec0 inner a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Config -> IO inner
forall a. FromConfig a => Key -> Config -> IO a
fetchFromConfig @inner Key
key Config
config

-- | Purely 'Generic's machinery, ignore...
class IntoDefaultsG f where
  intoDefaultsG :: Key -> f a -> [(Key, Dynamic)]

instance IntoDefaultsG inner =>
    IntoDefaultsG (D1 metadata inner) where
  intoDefaultsG :: Key -> D1 metadata inner a -> [(Key, Dynamic)]
intoDefaultsG Key
key (M1 inner a
inner) =
    Key -> inner a -> [(Key, Dynamic)]
forall (f :: * -> *) a.
IntoDefaultsG f =>
Key -> f a -> [(Key, Dynamic)]
intoDefaultsG Key
key inner a
inner

instance (IntoDefaultsWithConNameG inner, Constructor constructor) =>
    IntoDefaultsG (C1 constructor inner) where
  intoDefaultsG :: Key -> C1 constructor inner a -> [(Key, Dynamic)]
intoDefaultsG Key
key (M1 inner a
inner) =
    String -> Key -> inner a -> [(Key, Dynamic)]
forall (f :: * -> *) a.
IntoDefaultsWithConNameG f =>
String -> Key -> f a -> [(Key, Dynamic)]
intoDefaultsWithConNameG @inner (Any constructor Any Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName @constructor Any constructor Any Any
forall a. HasCallStack => a
undefined) Key
key inner a
inner

-- | Purely 'Generic's machinery, ignore...
class IntoDefaultsWithConNameG f where
  intoDefaultsWithConNameG :: String -> Key -> f a -> [(Key, Dynamic)]

instance (IntoDefaultsWithConNameG left, IntoDefaultsWithConNameG right) =>
    IntoDefaultsWithConNameG (left :*: right) where
  intoDefaultsWithConNameG :: String -> Key -> (:*:) left right a -> [(Key, Dynamic)]
intoDefaultsWithConNameG String
s Key
key (left a
left :*: right a
right) = do
    String -> Key -> left a -> [(Key, Dynamic)]
forall (f :: * -> *) a.
IntoDefaultsWithConNameG f =>
String -> Key -> f a -> [(Key, Dynamic)]
intoDefaultsWithConNameG @left String
s Key
key left a
left
    [(Key, Dynamic)] -> [(Key, Dynamic)] -> [(Key, Dynamic)]
forall a. [a] -> [a] -> [a]
++
    String -> Key -> right a -> [(Key, Dynamic)]
forall (f :: * -> *) a.
IntoDefaultsWithConNameG f =>
String -> Key -> f a -> [(Key, Dynamic)]
intoDefaultsWithConNameG @right String
s Key
key right a
right

instance (IntoDefaultsG inner, Selector selector) =>
    IntoDefaultsWithConNameG (S1 selector inner) where

  intoDefaultsWithConNameG :: String -> Key -> S1 selector inner a -> [(Key, Dynamic)]
intoDefaultsWithConNameG String
s Key
key (M1 inner a
inner) =
    let
      applyFirst :: (Char -> Char) -> Text -> Text
      applyFirst :: (Char -> Char) -> Text -> Text
applyFirst Char -> Char
f Text
t = case Text -> Maybe (Char, Text)
Text.uncons Text
t of
        Just (Char
c, Text
ts) -> Char -> Text -> Text
Text.cons (Char -> Char
f Char
c) Text
ts
        Maybe (Char, Text)
Nothing -> Text
t

      fieldName :: Text
fieldName = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Any selector Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName @selector Any selector Any Any
forall a. HasCallStack => a
undefined
      prefix :: Text
prefix = (Char -> Char) -> Text -> Text
applyFirst Char -> Char
Char.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
      scopedKey :: Text
scopedKey =
        case Text -> Text -> Maybe Text
Text.stripPrefix Text
prefix Text
fieldName of
          Just Text
stripped -> (Char -> Char) -> Text -> Text
applyFirst Char -> Char
Char.toLower Text
stripped
          Maybe Text
Nothing -> Text
fieldName
    in Key -> inner a -> [(Key, Dynamic)]
forall (f :: * -> *) a.
IntoDefaultsG f =>
Key -> f a -> [(Key, Dynamic)]
intoDefaultsG @inner (Key
key Key -> Key -> Key
/. Text -> Key
fromText Text
scopedKey) inner a
inner

instance (Typeable inner) => IntoDefaultsG (Rec0 inner) where
  intoDefaultsG :: Key -> Rec0 inner a -> [(Key, Dynamic)]
intoDefaultsG Key
key (K1 inner
inner) = do
    [(Key
key, inner -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn inner
inner)]