module Cfg.Source.Config
(
defaultConfigSource
, GConfigSource (..)
)
where
import Cfg.Options
import Cfg.Source
import Cfg.Source.Default
import Data.Kind (Type)
import Data.Map.Strict (empty, singleton)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics
import KeyTree
defaultConfigSource
:: forall a. (DefaultSource a, Generic a, GConfigSource (Rep a)) => ConfigOptions -> KeyTree Text Text
defaultConfigSource :: forall a.
(DefaultSource a, Generic a, GConfigSource (Rep a)) =>
ConfigOptions -> KeyTree Text Text
defaultConfigSource ConfigOptions
opts = forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @(Rep a) (forall a. DefaultSource a => Text -> Maybe Text
forall {k} (a :: k). DefaultSource a => Text -> Maybe Text
defaults @a) ConfigOptions
opts
class GConfigSource (a :: Type -> Type) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
instance (ConfigSource a) => GConfigSource (K1 R a) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource Text -> Maybe Text
_ ConfigOptions
_ = forall a. ConfigSource a => KeyTree Text Text
forall {k} (a :: k). ConfigSource a => KeyTree Text Text
configSource @a
instance (Selector s, GConfigSource f) => GConfigSource (M1 S s f) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource Text -> Maybe Text
def ConfigOptions
opts =
if forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
forall (s :: Meta) k1 (t :: Meta -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName @s Any s Any Any
forall a. HasCallStack => a
undefined [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
""
then
[Char] -> KeyTree Text Text
forall a. HasCallStack => [Char] -> a
error [Char]
"Can only create a tree for named product types i.e. Records with named fields"
else case Text -> Maybe Text
def Text
selectorName of
Maybe Text
Nothing -> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Map Text (KeyTree Text Text) -> KeyTree Text Text)
-> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> Map Text (KeyTree Text Text)
forall k a. k -> a -> Map k a
singleton Text
key KeyTree Text Text
value
Just Text
val -> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Map Text (KeyTree Text Text) -> KeyTree Text Text)
-> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> Map Text (KeyTree Text Text)
forall k a. k -> a -> Map k a
singleton Text
key (Text -> KeyTree Text Text
forall (f :: * -> *) a. a -> Free f a
Pure Text
val)
where
selectorName :: Text
selectorName :: Text
selectorName = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
forall (s :: Meta) k1 (t :: Meta -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName @s Any s Any Any
forall a. HasCallStack => a
undefined
key :: Text
key :: Text
key = ConfigOptions -> Text -> Text
keyModifier ConfigOptions
opts (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
selectorName
value :: KeyTree Text Text
value :: KeyTree Text Text
value = forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @f Text -> Maybe Text
def ConfigOptions
opts
instance (Constructor c, GConfigSource f) => GConfigSource (M1 C c f) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource Text -> Maybe Text
def ConfigOptions
opts =
case ConfigOptions
opts of
Root (RootOptions{rootOptionsRootKey :: RootOptions -> RootKey (Text -> Text)
rootOptionsRootKey = ConstructorName Text -> Text
modifier}) ->
if forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
forall (c :: Meta) k1 (t :: Meta -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord @c Any c Any Any
forall a. HasCallStack => a
undefined
then Map Text (KeyTree Text Text) -> KeyTree Text Text
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Map Text (KeyTree Text Text) -> KeyTree Text Text)
-> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> Map Text (KeyTree Text Text)
forall k a. k -> a -> Map k a
singleton (Text -> Text
modifier Text
key) (forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @f Text -> Maybe Text
def ConfigOptions
opts)
else
[Char] -> KeyTree Text Text
forall a. HasCallStack => [Char] -> a
error [Char]
"Can only create a tree for named product types i.e. Records with named fields"
ConfigOptions
_ -> (forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @f Text -> Maybe Text
def ConfigOptions
opts)
where
key :: Text
key :: Text
key = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall (c :: Meta) k1 (t :: Meta -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c Any c Any Any
forall a. HasCallStack => a
undefined
instance (Datatype d, GConfigSource f) => GConfigSource (M1 D d f) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource Text -> Maybe Text
def ConfigOptions
opts =
case ConfigOptions
opts of
Root (RootOptions{rootOptionsRootKey :: RootOptions -> RootKey (Text -> Text)
rootOptionsRootKey = TypeName Text -> Text
modifier}) ->
Map Text (KeyTree Text Text) -> KeyTree Text Text
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Map Text (KeyTree Text Text) -> KeyTree Text Text)
-> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> Map Text (KeyTree Text Text)
forall k a. k -> a -> Map k a
singleton (Text -> Text
modifier Text
key) (forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @f Text -> Maybe Text
def ConfigOptions
opts)
ConfigOptions
_ -> (forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @f Text -> Maybe Text
def ConfigOptions
opts)
where
key :: Text
key :: Text
key = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> [Char]
forall (d :: Meta) k1 (t :: Meta -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> [Char]
datatypeName @d Any d Any Any
forall a. HasCallStack => a
undefined
instance (GConfigSource a, GConfigSource b) => GConfigSource (a :*: b) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource Text -> Maybe Text
def ConfigOptions
opts =
case (forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @a Text -> Maybe Text
def ConfigOptions
opts, forall (a :: * -> *).
GConfigSource a =>
(Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource @b Text -> Maybe Text
def ConfigOptions
opts) of
(Free Map Text (KeyTree Text Text)
m, Free Map Text (KeyTree Text Text)
m') -> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Map Text (KeyTree Text Text) -> KeyTree Text Text)
-> Map Text (KeyTree Text Text) -> KeyTree Text Text
forall a b. (a -> b) -> a -> b
$ Map Text (KeyTree Text Text)
m Map Text (KeyTree Text Text)
-> Map Text (KeyTree Text Text) -> Map Text (KeyTree Text Text)
forall a. Semigroup a => a -> a -> a
<> Map Text (KeyTree Text Text)
m'
(KeyTree Text Text, KeyTree Text Text)
_ -> [Char] -> KeyTree Text Text
forall a. HasCallStack => [Char] -> a
error [Char]
"expected product types to generate subtrees (i.e. not contain Pure values)"
instance GConfigSource (a :+: b) where
gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text
gConfigSource Text -> Maybe Text
_ ConfigOptions
_ = Map Text (KeyTree Text Text) -> KeyTree Text Text
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free Map Text (KeyTree Text Text)
forall k a. Map k a
empty