-- |
--  Module      : Cfg.Parser.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 building parsers from the
-- structure of a type. The majority of the work here is threading a
-- 'Cfg.Parser.Value.ValueParser' through the 'KeyTree.KeyTree' structure until
-- a 'Pure' value is hit, and then dispatching the correct parser.
module Cfg.Parser.Config
  ( -- * Default Parser Function
    defaultParseConfig

    -- * Generic Machinery
  , GConfigParser (..)
  )
where

import Cfg.Options
import Cfg.Parser (ConfigParseError (..), ConfigParser (..))
import Data.Kind (Type)
import Data.Map qualified as M
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics
import KeyTree

-- | This function is the workhorse of the generic machinery, however the user
-- should never have to invoke it directly. Instead, one of the newtypes from
-- 'Cfg.Deriving.Config' should call into this function in the definition of a
-- 'Cfg.Parser.ConfigParser' instance. The deriving via type should pull out
-- the 'ConfigOptions' from type level information.
--
-- @since 0.0.1.0
defaultParseConfig
  :: forall a
   . (Generic a, GConfigParser (Rep a))
  => ConfigOptions
  -> KeyTree Text Text
  -> Either ConfigParseError a
defaultParseConfig :: forall a.
(Generic a, GConfigParser (Rep a)) =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError a
defaultParseConfig ConfigOptions
opts KeyTree Text Text
tree = (Rep a Any -> a)
-> Either ConfigParseError (Rep a Any) -> Either ConfigParseError a
forall a b.
(a -> b) -> Either ConfigParseError a -> Either ConfigParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Either ConfigParseError (Rep a Any) -> Either ConfigParseError a)
-> Either ConfigParseError (Rep a Any) -> Either ConfigParseError a
forall a b. (a -> b) -> a -> b
$ ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError (Rep a Any)
forall p.
ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError (Rep a p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
tree

-- | This class is the generic version of 'ConfigParser'. It recurses on the
-- generic structure of a type, building up a return type for the parser.
--
-- @since 0.0.2.0
class GConfigParser (f :: Type -> Type) where
  gParseConfig :: ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)

-- | 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
-- 'parseConfig' on it. @a@ may be another nested record, in which case
-- 'gParseConfig' will probably get called again, but for the generic
-- representation of a sub-tree. Or it will find the default instance for
-- 'ConfigParser' (indicating that we have reached a leaf) and dispatch to a
-- value parser through 'parseConfig'.
--
-- @since 0.0.2.0
instance (ConfigParser a) => GConfigParser (K1 R a) where
  gParseConfig :: forall p.
ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError (K1 R a p)
gParseConfig ConfigOptions
_ KeyTree Text Text
kt = a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 R a p)
-> Either ConfigParseError a -> Either ConfigParseError (K1 R a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyTree Text Text -> Either ConfigParseError a
forall a.
ConfigParser a =>
KeyTree Text Text -> Either ConfigParseError a
parseConfig KeyTree Text Text
kt

-- | This is the type constructor case, if we are dealing with a
-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have lookup the \"root
-- key\", but in all other cases we just keep recursing.
--
-- @since 0.0.2.0
instance (GConfigParser f, Datatype d) => GConfigParser (M1 D d f) where
  gParseConfig :: forall p.
ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError (M1 D d f p)
gParseConfig ConfigOptions
opts t :: KeyTree Text Text
t@(Free Map Text (KeyTree Text Text)
keyForest) =
    case ConfigOptions
opts of
      Root (RootOptions{rootOptionsRootKey :: RootOptions -> RootKey (Text -> Text)
rootOptionsRootKey = TypeName Text -> Text
modifier}) ->
        let
          key :: Text
key = Text -> Text
modifier (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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
        in
          case Text -> Map Text (KeyTree Text Text) -> Maybe (KeyTree Text Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text (KeyTree Text Text)
keyForest of
            Just KeyTree Text Text
subTree -> f p -> M1 D d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D d f p)
-> Either ConfigParseError (f p)
-> Either ConfigParseError (M1 D d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
subTree
            Maybe (KeyTree Text Text)
Nothing -> ConfigParseError -> Either ConfigParseError (M1 D d f p)
forall a b. a -> Either a b
Left (ConfigParseError -> Either ConfigParseError (M1 D d f p))
-> ConfigParseError -> Either ConfigParseError (M1 D d f p)
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> ConfigParseError
MissingKey Text
key KeyTree Text Text
t
      ConfigOptions
_ -> f p -> M1 D d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D d f p)
-> Either ConfigParseError (f p)
-> Either ConfigParseError (M1 D d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
t
  gParseConfig ConfigOptions
opts (Pure Text
value) = ConfigParseError -> Either ConfigParseError (M1 D d f p)
forall a b. a -> Either a b
Left (ConfigParseError -> Either ConfigParseError (M1 D d f p))
-> ConfigParseError -> Either ConfigParseError (M1 D d f p)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ConfigParseError
ExpectedKeyFoundValue Text
key Text
value
   where
    key :: Text
key = ConfigOptions -> Text -> Text
keyModifier ConfigOptions
opts (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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 is the data constructor case, if we are dealing with a
-- 'Cfg.Deriving.Config.ConfigRoot' instance, then we have lookup the \"root
-- key\", but in all other cases we just keep recursing.
--
-- @since 0.0.2.0
instance (Constructor c, GConfigParser f) => GConfigParser (M1 C c f) where
  gParseConfig :: forall p.
ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError (M1 C c f p)
gParseConfig ConfigOptions
opts t :: KeyTree Text Text
t@(Free Map Text (KeyTree Text Text)
keyForest) =
    case ConfigOptions
opts of
      Root (RootOptions{rootOptionsRootKey :: RootOptions -> RootKey (Text -> Text)
rootOptionsRootKey = ConstructorName Text -> Text
modifier}) ->
        let
          key :: Text
key = Text -> Text
modifier (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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
        in
          case Text -> Map Text (KeyTree Text Text) -> Maybe (KeyTree Text Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text (KeyTree Text Text)
keyForest of
            Just KeyTree Text Text
subTree -> f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p)
-> Either ConfigParseError (f p)
-> Either ConfigParseError (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
subTree
            Maybe (KeyTree Text Text)
Nothing -> ConfigParseError -> Either ConfigParseError (M1 C c f p)
forall a b. a -> Either a b
Left (ConfigParseError -> Either ConfigParseError (M1 C c f p))
-> ConfigParseError -> Either ConfigParseError (M1 C c f p)
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> ConfigParseError
MissingKey Text
key KeyTree Text Text
t
      ConfigOptions
_ -> f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p)
-> Either ConfigParseError (f p)
-> Either ConfigParseError (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
t
  gParseConfig ConfigOptions
opts (Pure Text
value) = ConfigParseError -> Either ConfigParseError (M1 C c f p)
forall a b. a -> Either a b
Left (ConfigParseError -> Either ConfigParseError (M1 C c f p))
-> ConfigParseError -> Either ConfigParseError (M1 C c f p)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ConfigParseError
ExpectedKeyFoundValue Text
key Text
value
   where
    key :: Text
key = ConfigOptions -> Text -> Text
keyModifier ConfigOptions
opts (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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 most important case, we need to look up the subconfig by key
-- (just the record field with all key modifiers applied), and then recursively
-- parse the sub tree.
--
-- @since 0.0.2.0
instance (Selector s, GConfigParser f) => GConfigParser (M1 S s f) where
  gParseConfig :: forall p.
ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError (M1 S s f p)
gParseConfig ConfigOptions
opts (Pure Text
value) = ConfigParseError -> Either ConfigParseError (M1 S s f p)
forall a b. a -> Either a b
Left (ConfigParseError -> Either ConfigParseError (M1 S s f p))
-> ConfigParseError -> Either ConfigParseError (M1 S s f p)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ConfigParseError
ExpectedKeyFoundValue Text
key Text
value
   where
    key :: Text
key = ConfigOptions -> Text -> Text
keyModifier ConfigOptions
opts (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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
  gParseConfig ConfigOptions
opts t :: KeyTree Text Text
t@(Free Map Text (KeyTree Text Text)
keyForest) =
    case Text -> Map Text (KeyTree Text Text) -> Maybe (KeyTree Text Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
selectorName Map Text (KeyTree Text Text)
keyForest of
      Maybe (KeyTree Text Text)
Nothing -> ConfigParseError -> Either ConfigParseError (M1 S s f p)
forall a b. a -> Either a b
Left (ConfigParseError -> Either ConfigParseError (M1 S s f p))
-> ConfigParseError -> Either ConfigParseError (M1 S s f p)
forall a b. (a -> b) -> a -> b
$ Text -> KeyTree Text Text -> ConfigParseError
MissingKey Text
selectorName KeyTree Text Text
t
      Just KeyTree Text Text
subTree -> f p -> M1 S s f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 S s f p)
-> Either ConfigParseError (f p)
-> Either ConfigParseError (M1 S s f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
subTree
   where
    selectorName :: Text
selectorName = ConfigOptions -> Text -> Text
keyModifier ConfigOptions
opts (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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

-- | This is the product case, we just distribute the parsers over the
-- different product fields.
--
-- Notably, there is no sum type case. We could potentially add that in the future,
-- allowing users to specify different cases of configuration. But right now
-- that seems like it would be more confusing than helpful, so we just give a
-- type error by eliding the instance.
--
-- @since 0.0.2.0
instance (GConfigParser a, GConfigParser b) => GConfigParser (a :*: b) where
  gParseConfig :: forall p.
ConfigOptions
-> KeyTree Text Text -> Either ConfigParseError ((:*:) a b p)
gParseConfig ConfigOptions
opts KeyTree Text Text
xs = do
    a p
a <- ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (a p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (a p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
xs
    b p
b <- ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (b p)
forall p.
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (b p)
forall (f :: * -> *) p.
GConfigParser f =>
ConfigOptions -> KeyTree Text Text -> Either ConfigParseError (f p)
gParseConfig ConfigOptions
opts KeyTree Text Text
xs
    (:*:) a b p -> Either ConfigParseError ((:*:) a b p)
forall a. a -> Either ConfigParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((:*:) a b p -> Either ConfigParseError ((:*:) a b p))
-> (:*:) a b p -> Either ConfigParseError ((:*:) a b p)
forall a b. (a -> b) -> a -> b
$ a p
a a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
b