{-# 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(..))
class FromConfig a where
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
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
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)
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
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)
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)
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
addDefaultsAfterDeconstructingToDefaults
:: forall a.
Typeable a =>
(a -> [(Key, Dynamic)]) ->
Key ->
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
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
]
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
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)
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
]
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]
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]
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
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))
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
"'"
]
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
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)
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
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
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
""
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)
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)
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
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
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
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)]