-- |
--  Module      : Cfg.Source.Config
--  Copyright   : © Jonathan Lorimer, 2023
--  License     : MIT
--  Maintainer  : jonathanlorimer@pm.me
--  Stability   : stable
--
-- @since 0.0.2.0
--
-- This module contains the generic machinery for generating a tree
-- representation of your configuration, this tree representation is intended
-- to be used with various sources. The tree structure should match the
-- structure of your (potentially) nested record type.
--
-- It is important to note that defaults are injected here, and not in the
-- parser stage. We use a 'DefaultSource' instance to inject 'Pure' values at
-- the leaves that can be used if the source fetcher doesn't return a value for
-- that key. In the case that there is no default a 'Free Data.Map.empty' is
-- placed to represent a required value.
module Cfg.Source.Config
  ( -- * Default Source Generator
    defaultConfigSource

    -- * Generic Machinery
  , 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

-- | This function is used by the deriving via machinery to dispatch to the
-- generic machinery, the user should never have to invoke it directly. This
-- takes in a 'ConfigOptions' which are retrieved from the deriving via
-- newtypes, and also threads a 'DefaultSource' instance through so that we can
-- dispatch to 'defaults' in the 'K1' case.
--
-- @since 0.0.2.0
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

-- | This class is the generic version of 'ConfigSource. It recurses on the
-- generic structure of a type, building up 'KeyTree' representation.
--
-- @since 0.0.2.0
class GConfigSource (a :: Type -> Type) where
  gConfigSource :: (Text -> Maybe Text) -> ConfigOptions -> KeyTree Text Text

-- | This is the \"base case\", since "GHC.Generics" don't recurse the generic
-- represetation multiple levels, @a@ is just a plain type. Therefore we call
-- 'configSource' on it. @a@ may be another nested record, in which case
-- 'Cfg.Parser.Config.gParseConfig' will probably get called again, but for the
-- generic representation of a sub-tree. It will do this until it finds a
-- 'ConfigSource' instance for 'Cfg.Deriving.Value.Value' which will just add a
-- 'Free Data.Map.empty' (indicating a hole to be filled when we fetch the
-- configuration).
--
-- @since 0.0.2.0
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

-- | This instance is important because it does the work of pulling off the
-- field selector name, and creating a sub-tree under that key by calling
-- 'gConfigSource' recursively. If there is a default for that selector then no
-- sub-tree is created, instead we insert a \"placeholder\" value tagged by
-- 'Pure' to represent that it is the end of the tree.
--
-- We detect if a default exists by calling 'defaults' from the 'DefaultSource'
-- instance on the selector, @defaults@ is of type @Text -> Maybe Text@, so the
-- @Nothing@ case indicates no default.
--
-- @since 0.0.2.0
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 -- TODO: Would be nice if we could turn this into a compile time error.
        [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

-- | This is the data constructor case, if we are dealing with a
-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have to create an extra layer with the \"root
-- key\" as a key and then a subtree (calculated by recursively calling 'gConfigSource') as the value.
--
-- @since 0.0.2.0
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 -- TODO: Would be nice if we could turn this into a compile time error.
            [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

-- | This is the type constructor case, if we are dealing with a
-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have to create an extra layer with the \"root
-- key\" as a key and then a subtree (calculated by recursively calling 'gConfigSource') as the value.
--
-- @since 0.0.2.0
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

-- | This instance handles product types and is pretty important. We need to
-- check that recursive calls to 'gConfigSource' generate sub-trees, and then
-- we merge the sub-trees.
--
-- You may wonder what happens if there is a 'Pure' value in one of the record
-- fields, well that would be represented like so:
--
-- @
-- Free $ M.singleton fieldName (Pure value)
-- @
--
-- since we need to account for the key corresponding to the record field. So
-- we really should never hit a case were a recursive call to 'gConfigSource'
-- yields a raw 'Pure'.
--
-- @since 0.0.2.0
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'
      -- TODO: Would be nice if we could turn this into a compile time error.
      (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)"

-- | Sum types should represent base values, so @Free M.empty@ is the right
-- thing to do here, although we should probably never hit this case, since sum
-- types should be nested under record fields as base values.
--
-- @since 0.0.2.0
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