-- |
-- 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 ((&))

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(..))
import Data.Foldable (msum)

-- | 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.
  fromConfig :: Key -> Config -> IO a
  default fromConfig :: (Typeable a, Generic a, IntoDefaultsG (Rep a), FromConfigG (Rep a)) => Key -> Config -> IO a
  fromConfig Key
key Config
config = do
    let configWithDefaults :: Config
configWithDefaults = case Key -> Config -> Maybe a
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults @a Key
key Config
config of
          Just a
d -> Config
config 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
key (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
config
    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)
fromConfigG Key
key Config
configWithDefaults

fetchFromConfig :: forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig :: Key -> Config -> IO a
fetchFromConfig Key
key Config
config =
  case Key -> Config -> Maybe (OverrideFromConfig a)
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults @(OverrideFromConfig a) Key
key Config
config of
    Just (OverrideFromConfig Key -> Config -> IO a
fetch) ->
      Key -> Config -> IO a
fetch Key
key (Config -> IO a) -> Config -> IO a
forall a b. (a -> b) -> a -> b
$ Key -> Config -> Config
forall t. Typeable t => Key -> Config -> Config
removeDefault @(OverrideFromConfig a) Key
key Config
config
    Maybe (OverrideFromConfig a)
Nothing ->
      Key -> Config -> IO a
forall a. FromConfig a => Key -> Config -> IO a
fromConfig Key
key 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
  fromConfig :: Key -> Config -> IO a
fromConfig = Key -> Config -> IO a
forall a. Typeable a => Key -> Config -> IO a
fetchRequiredFromDefaults

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

instance FromConfig String where
  fromConfig :: Key -> Config -> IO String
fromConfig = (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
  fromConfig :: Key -> Config -> IO [a]
fromConfig 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
        let Config
configWithDefaults :: Config =
              case Key -> Config -> Maybe [a]
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults @[a] Key
key Config
config 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, Typeable 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, Typeable 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
  fromConfig :: Key -> Config -> IO Int
fromConfig = Key -> Config -> IO Int
forall a. (Typeable a, Read a) => Key -> Config -> IO a
fetchFromConfigByRead

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

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

instance FromConfig BS.ByteString where
  fromConfig :: Key -> Config -> IO ByteString
fromConfig = (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
  fromConfig :: Key -> Config -> IO ByteString
fromConfig = (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
  fromConfig :: Key -> Config -> IO (Maybe a)
fromConfig Key
key Config
config = do
    let
      configWithUnwrappedDefault :: Config
configWithUnwrappedDefault =
        case Key -> Config -> Maybe (Maybe a)
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults @(Maybe a) Key
key Config
config 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
          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, Typeable a) => Key -> Config -> IO a
fetchFromConfig @a Key
key Config
configWithUnwrappedDefault)
      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
  fromConfig :: Key -> Config -> IO Text
fromConfig = (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
  fromConfig :: Key -> Config -> IO Bool
fromConfig = (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)

unFile :: File -> FilePath
unFile :: File -> String
unFile (File String
f) = String
f

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

instance FromConfig File where
  fromConfig :: Key -> Config -> IO File
fromConfig Key
key Config
config = do
    let defaultPath :: Maybe File
defaultPath = Key -> Config -> Maybe File
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults @File Key
key Config
config

    Maybe String
filepath <- Key -> Config -> IO (Maybe String)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig @(Maybe String) Key
key Config
config

    Maybe String
extension <- Key -> Config -> IO (Maybe String)
forall a. (FromConfig a, Typeable 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, Typeable 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, Typeable 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, Typeable 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 (File -> String
unFile (File -> String) -> File -> String
forall a b. (a -> b) -> a -> b
$ File -> Maybe File -> File
forall a. a -> Maybe a -> a
fromMaybe File
"" Maybe File
defaultPath) 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

data OverrideFromConfig a =
  OverrideFromConfig (Key -> Config -> IO a)

-- | Allow the programmer to override this 'FromConfig' instance by providing
-- a special 'OverrideFromConfig' value.
--
-- To avoid infinite recursion we remove the Override before calling the value

-- | 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]
dynamics ->
        case [Dynamic] -> Maybe a
forall a. Typeable a => [Dynamic] -> Maybe a
fromDynamics [Dynamic]
dynamics of
          Just a
a -> do
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
          Maybe a
Nothing -> do
            [Key] -> IO a
forall t a. Typeable t => [Key] -> IO a
throwMissingRequiredKeys @a [Key
k]

fromDynamics :: forall a. Typeable a => [Dynamic] -> Maybe a
fromDynamics :: [Dynamic] -> Maybe a
fromDynamics =
  [Maybe a] -> Maybe a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe a] -> Maybe a)
-> ([Dynamic] -> [Maybe a]) -> [Dynamic] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dynamic -> Maybe a) -> [Dynamic] -> [Maybe a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Typeable a => Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @a)

-- | 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
  case Key -> Config -> Maybe a
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults @a Key
key Config
config of
    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

-- | Helper function to override the fetching function for a certain key.
--
-- This function creates a 'Dynamic' that when added to the defaults allows
-- overriding the default 'FromConfig' instance.
overrideFetch :: forall a. Typeable a => (Key -> Config -> IO a) -> Dynamic
overrideFetch :: (Key -> Config -> IO a) -> Dynamic
overrideFetch Key -> Config -> IO a
f =
  Typeable (OverrideFromConfig a) => OverrideFromConfig a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn @(OverrideFromConfig a) (OverrideFromConfig a -> Dynamic)
-> OverrideFromConfig a -> Dynamic
forall a b. (a -> b) -> a -> b
$ (Key -> Config -> IO a) -> OverrideFromConfig a
forall a. (Key -> Config -> IO a) -> OverrideFromConfig a
OverrideFromConfig Key -> Config -> IO a
f

-- | 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))

-- | 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 =
  case Key -> Config -> Maybe a
forall a. Typeable a => Key -> Config -> Maybe a
fetchFromDefaults Key
key Config
config of
    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 -> Maybe a
fetchFromDefaults :: Key -> Config -> Maybe a
fetchFromDefaults Key
key Config
config =
  Key -> Config -> Maybe [Dynamic]
getKeyFromDefaults Key
key Config
config
    Maybe [Dynamic] -> ([Dynamic] -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Typeable a => [Dynamic] -> Maybe a
forall a. Typeable a => [Dynamic] -> Maybe a
fromDynamics @a

-- | Same as 'fetchFromConfig' using the root key
fetchFromRootConfig :: forall a. (FromConfig a, Typeable a) => Config -> IO a
fetchFromRootConfig :: Config -> IO a
fetchFromRootConfig =
  Key -> Config -> IO a
forall a. (FromConfig a, Typeable 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, Typeable 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, Typeable 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
  fromConfigG :: Key -> Config -> IO (f a)

instance FromConfigG inner =>
    FromConfigG (D1 metadata inner) where
  fromConfigG :: Key -> Config -> IO (D1 metadata inner a)
fromConfigG 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)
fromConfigG Key
key Config
config

instance (FromConfigWithConNameG inner, Constructor constructor) =>
    FromConfigG (C1 constructor inner) where
  fromConfigG :: Key -> Config -> IO (C1 constructor inner a)
fromConfigG 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)
fromConfigWithConNameG @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
  fromConfigWithConNameG :: String -> Key -> Config -> IO (f a)

instance (FromConfigWithConNameG left, FromConfigWithConNameG right) =>
    FromConfigWithConNameG (left :*: right) where
  fromConfigWithConNameG :: String -> Key -> Config -> IO ((:*:) left right a)
fromConfigWithConNameG 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)
fromConfigWithConNameG @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)
fromConfigWithConNameG @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
  fromConfigWithConNameG :: String -> Key -> Config -> IO (S1 selector inner a)
fromConfigWithConNameG 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)
fromConfigG @inner (Key
key Key -> Key -> Key
/. Text -> Key
fromText Text
scopedKey) Config
config

instance (FromConfig inner, Typeable inner) => FromConfigG (Rec0 inner) where
  fromConfigG :: Key -> Config -> IO (Rec0 inner a)
fromConfigG 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, Typeable 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)]