{-# 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)
class FromConfig a where
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
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
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)
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)
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]
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)
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
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
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
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))
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
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
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
""
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)
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)
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
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
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)]