{-# LANGUAGE UndecidableInstances #-}

module Shrun.Configuration.Toml
  ( Toml (..),
    mergeTomls,
  )
where

import Data.HashSet qualified as HSet
import Shrun.Configuration.Data.Core
  ( CoreConfigP
      ( MkCoreConfigP,
        commandLogging,
        commonLogging,
        consoleLogging,
        fileLogging,
        init,
        legendKeysCache,
        notifications,
        timeout
      ),
    CoreConfigToml,
  )
import Shrun.Configuration.Data.Core.Timeout (Timeout)
import Shrun.Configuration.Data.WithDisabled (WithDisabled)
import Shrun.Configuration.Toml.Legend (KeyVal)
import Shrun.Prelude

-- | Holds toml config.
data Toml notifyEnv = MkToml
  { -- | Core config.
    forall notifyEnv. Toml notifyEnv -> CoreConfigToml notifyEnv
coreConfig :: CoreConfigToml notifyEnv,
    -- | Legend.
    forall notifyEnv. Toml notifyEnv -> Maybe (Seq KeyVal)
legend :: Maybe (Seq KeyVal)
  }
  deriving stock (Toml notifyEnv -> Toml notifyEnv -> Bool
(Toml notifyEnv -> Toml notifyEnv -> Bool)
-> (Toml notifyEnv -> Toml notifyEnv -> Bool)
-> Eq (Toml notifyEnv)
forall notifyEnv. Toml notifyEnv -> Toml notifyEnv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall notifyEnv. Toml notifyEnv -> Toml notifyEnv -> Bool
== :: Toml notifyEnv -> Toml notifyEnv -> Bool
$c/= :: forall notifyEnv. Toml notifyEnv -> Toml notifyEnv -> Bool
/= :: Toml notifyEnv -> Toml notifyEnv -> Bool
Eq, Int -> Toml notifyEnv -> ShowS
[Toml notifyEnv] -> ShowS
Toml notifyEnv -> String
(Int -> Toml notifyEnv -> ShowS)
-> (Toml notifyEnv -> String)
-> ([Toml notifyEnv] -> ShowS)
-> Show (Toml notifyEnv)
forall notifyEnv. Int -> Toml notifyEnv -> ShowS
forall notifyEnv. [Toml notifyEnv] -> ShowS
forall notifyEnv. Toml notifyEnv -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall notifyEnv. Int -> Toml notifyEnv -> ShowS
showsPrec :: Int -> Toml notifyEnv -> ShowS
$cshow :: forall notifyEnv. Toml notifyEnv -> String
show :: Toml notifyEnv -> String
$cshowList :: forall notifyEnv. [Toml notifyEnv] -> ShowS
showList :: [Toml notifyEnv] -> ShowS
Show)

instance
  (k ~ A_Lens, a ~ CoreConfigToml notifyEnv, b ~ CoreConfigToml notifyEnv) =>
  LabelOptic "coreConfig" k (Toml notifyEnv) (Toml notifyEnv) a b
  where
  labelOptic :: Optic k NoIx (Toml notifyEnv) (Toml notifyEnv) a b
labelOptic = LensVL (Toml notifyEnv) (Toml notifyEnv) a b
-> Lens (Toml notifyEnv) (Toml notifyEnv) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL (Toml notifyEnv) (Toml notifyEnv) a b
 -> Lens (Toml notifyEnv) (Toml notifyEnv) a b)
-> LensVL (Toml notifyEnv) (Toml notifyEnv) a b
-> Lens (Toml notifyEnv) (Toml notifyEnv) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkToml CoreConfigToml notifyEnv
a1 Maybe (Seq KeyVal)
a2) ->
    (CoreConfigToml notifyEnv -> Toml notifyEnv)
-> f (CoreConfigToml notifyEnv) -> f (Toml notifyEnv)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CoreConfigToml notifyEnv
b -> CoreConfigToml notifyEnv -> Maybe (Seq KeyVal) -> Toml notifyEnv
forall notifyEnv.
CoreConfigToml notifyEnv -> Maybe (Seq KeyVal) -> Toml notifyEnv
MkToml CoreConfigToml notifyEnv
b Maybe (Seq KeyVal)
a2) (a -> f b
f a
CoreConfigToml notifyEnv
a1)
  {-# INLINE labelOptic #-}

instance
  (k ~ A_Lens, a ~ Maybe (Seq KeyVal), b ~ Maybe (Seq KeyVal)) =>
  LabelOptic "legend" k (Toml notifyEnv) (Toml notifyEnv) a b
  where
  labelOptic :: Optic k NoIx (Toml notifyEnv) (Toml notifyEnv) a b
labelOptic = LensVL (Toml notifyEnv) (Toml notifyEnv) a b
-> Lens (Toml notifyEnv) (Toml notifyEnv) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL (Toml notifyEnv) (Toml notifyEnv) a b
 -> Lens (Toml notifyEnv) (Toml notifyEnv) a b)
-> LensVL (Toml notifyEnv) (Toml notifyEnv) a b
-> Lens (Toml notifyEnv) (Toml notifyEnv) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkToml CoreConfigToml notifyEnv
a1 Maybe (Seq KeyVal)
a2) ->
    (Maybe (Seq KeyVal) -> Toml notifyEnv)
-> f (Maybe (Seq KeyVal)) -> f (Toml notifyEnv)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (Seq KeyVal)
b -> CoreConfigToml notifyEnv -> Maybe (Seq KeyVal) -> Toml notifyEnv
forall notifyEnv.
CoreConfigToml notifyEnv -> Maybe (Seq KeyVal) -> Toml notifyEnv
MkToml CoreConfigToml notifyEnv
a1 Maybe (Seq KeyVal)
b) (a -> f b
f a
Maybe (Seq KeyVal)
a2)
  {-# INLINE labelOptic #-}

instance DecodeTOML (Toml notifyEnv) where
  tomlDecoder :: Decoder (Toml notifyEnv)
tomlDecoder = do
    Maybe (WithDisabled Timeout)
timeout <- Decoder (Maybe (WithDisabled Timeout))
decodeTimeout
    Maybe (WithDisabled Text)
init <- Decoder (Maybe (WithDisabled Text))
decodeInit
    Maybe LegendKeysCache
legendKeysCache <- Decoder LegendKeysCache -> Text -> Decoder (Maybe LegendKeysCache)
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder LegendKeysCache
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"legend-keys-cache"
    Maybe (CommonLoggingP 'ConfigPhaseToml)
commonLogging <- Decoder (CommonLoggingP 'ConfigPhaseToml)
-> Text -> Decoder (Maybe (CommonLoggingP 'ConfigPhaseToml))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (CommonLoggingP 'ConfigPhaseToml)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"common-log"
    Maybe (CommandLoggingP 'ConfigPhaseToml)
commandLogging <- Decoder (CommandLoggingP 'ConfigPhaseToml)
-> Text -> Decoder (Maybe (CommandLoggingP 'ConfigPhaseToml))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (CommandLoggingP 'ConfigPhaseToml)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"command-log"
    Maybe (ConsoleLoggingP 'ConfigPhaseToml)
consoleLogging <- Decoder (ConsoleLoggingP 'ConfigPhaseToml)
-> Text -> Decoder (Maybe (ConsoleLoggingP 'ConfigPhaseToml))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (ConsoleLoggingP 'ConfigPhaseToml)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"console-log"
    Maybe (FileLoggingP 'ConfigPhaseToml)
fileLogging <- Decoder (FileLoggingP 'ConfigPhaseToml)
-> Text -> Decoder (Maybe (FileLoggingP 'ConfigPhaseToml))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (FileLoggingP 'ConfigPhaseToml)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"file-log"
    Maybe (NotifyP 'ConfigPhaseToml notifyEnv)
notifications <- Decoder (NotifyP 'ConfigPhaseToml notifyEnv)
-> Text -> Decoder (Maybe (NotifyP 'ConfigPhaseToml notifyEnv))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (NotifyP 'ConfigPhaseToml notifyEnv)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"notify"

    Maybe (Seq KeyVal)
legend <- Decoder (Maybe (Seq KeyVal))
decodeLegend
    pure
      $ MkToml
        { coreConfig :: CoreConfigToml notifyEnv
coreConfig =
            MkCoreConfigP
              { Maybe (WithDisabled Timeout)
TimeoutF 'ConfigPhaseToml
timeout :: TimeoutF 'ConfigPhaseToml
timeout :: Maybe (WithDisabled Timeout)
timeout,
                Maybe LegendKeysCache
LegendKeysCacheF 'ConfigPhaseToml
legendKeysCache :: LegendKeysCacheF 'ConfigPhaseToml
legendKeysCache :: Maybe LegendKeysCache
legendKeysCache,
                Maybe (WithDisabled Text)
ConfigPhaseDisabledMaybeF 'ConfigPhaseToml Text
init :: ConfigPhaseDisabledMaybeF 'ConfigPhaseToml Text
init :: Maybe (WithDisabled Text)
init,
                Maybe (CommonLoggingP 'ConfigPhaseToml)
TomlOptF 'ConfigPhaseToml (CommonLoggingP 'ConfigPhaseToml)
commonLogging :: TomlOptF 'ConfigPhaseToml (CommonLoggingP 'ConfigPhaseToml)
commonLogging :: Maybe (CommonLoggingP 'ConfigPhaseToml)
commonLogging,
                Maybe (CommandLoggingP 'ConfigPhaseToml)
TomlOptF 'ConfigPhaseToml (CommandLoggingP 'ConfigPhaseToml)
commandLogging :: TomlOptF 'ConfigPhaseToml (CommandLoggingP 'ConfigPhaseToml)
commandLogging :: Maybe (CommandLoggingP 'ConfigPhaseToml)
commandLogging,
                Maybe (ConsoleLoggingP 'ConfigPhaseToml)
TomlOptF 'ConfigPhaseToml (ConsoleLoggingP 'ConfigPhaseToml)
consoleLogging :: TomlOptF 'ConfigPhaseToml (ConsoleLoggingP 'ConfigPhaseToml)
consoleLogging :: Maybe (ConsoleLoggingP 'ConfigPhaseToml)
consoleLogging,
                Maybe (FileLoggingP 'ConfigPhaseToml)
ArgsOnlyDetF 'ConfigPhaseToml (FileLoggingP 'ConfigPhaseToml)
fileLogging :: ArgsOnlyDetF 'ConfigPhaseToml (FileLoggingP 'ConfigPhaseToml)
fileLogging :: Maybe (FileLoggingP 'ConfigPhaseToml)
fileLogging,
                Maybe (NotifyP 'ConfigPhaseToml notifyEnv)
ArgsOnlyDetF 'ConfigPhaseToml (NotifyP 'ConfigPhaseToml notifyEnv)
notifications :: ArgsOnlyDetF 'ConfigPhaseToml (NotifyP 'ConfigPhaseToml notifyEnv)
notifications :: Maybe (NotifyP 'ConfigPhaseToml notifyEnv)
notifications
              },
          Maybe (Seq KeyVal)
legend :: Maybe (Seq KeyVal)
legend :: Maybe (Seq KeyVal)
legend
        }

decodeTimeout :: Decoder (Maybe (WithDisabled Timeout))
decodeTimeout :: Decoder (Maybe (WithDisabled Timeout))
decodeTimeout = Decoder (WithDisabled Timeout)
-> Text -> Decoder (Maybe (WithDisabled Timeout))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (WithDisabled Timeout)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"timeout"

decodeInit :: Decoder (Maybe (WithDisabled Text))
decodeInit :: Decoder (Maybe (WithDisabled Text))
decodeInit = Decoder (WithDisabled Text)
-> Text -> Decoder (Maybe (WithDisabled Text))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (WithDisabled Text)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"init"

decodeLegend :: Decoder (Maybe (Seq KeyVal))
decodeLegend :: Decoder (Maybe (Seq KeyVal))
decodeLegend = Decoder (Seq KeyVal) -> Text -> Decoder (Maybe (Seq KeyVal))
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder (Seq KeyVal)
forall a. DecodeTOML a => Decoder a
tomlDecoder Text
"legend"

-- | Note that our Semigroup is /not/ commutative, hence the order matters.
-- In particular, mconcat is safe because it is foldr, hence respects the
-- input order.
mergeTomls :: Seq (Toml notifyEnv) -> Toml notifyEnv
mergeTomls :: forall notifyEnv. Seq (Toml notifyEnv) -> Toml notifyEnv
mergeTomls = [Toml notifyEnv] -> Toml notifyEnv
forall a. Monoid a => [a] -> a
mconcat ([Toml notifyEnv] -> Toml notifyEnv)
-> (Seq (Toml notifyEnv) -> [Toml notifyEnv])
-> Seq (Toml notifyEnv)
-> Toml notifyEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Seq (Toml notifyEnv) -> [Toml notifyEnv]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList

-- NOTE: [Toml Semigroup]
--
-- The Toml semigroup is used to combine multiple tomls into a single toml,
-- for further combining with CLI args. The general strategy is to take
-- the "more defined" fields i.e. if an element is set on the LHS or RHS,
-- we take it. The instance is left-biased in the sense that we favor the
-- LHS when there is a conflict i.e. both elements have defined the same
-- field.
--
-- This is essentially Maybe's Alternative instance semantics. In fact,
-- since every field is ultimately a Maybe (all fields are optional),
-- most fields are indeed using Maybe's (<|>) and empty.
--
-- It is only "non-scaler" types (i.e. aggregate types like FileLogging) that
-- declare their own Semigroup/Monoid instances, in terms of their fields'
-- Alternative instances. This way we ensure we "reach down" deeply into
-- each field, when they exist.
--
-- The LHS bias is actually designed to favor the /right-most/ element
-- in the CLI, with the potential xdg at the very left e.g.
--
--   xdg, cfg1, cfg2, ..., cfgn
--
-- See NOTE: [Toml order] for more details.
--
-- Also, because we want Tomls to use Alternative or Monoid instances, we
-- deliberately do not provide Default instances for non-scalar types e.g.
-- CommandLogging. Instances should exist only for *Args, as Merged does
-- not need them either.

instance Semigroup (Toml notifyEnv) where
  Toml notifyEnv
l <> :: Toml notifyEnv -> Toml notifyEnv -> Toml notifyEnv
<> Toml notifyEnv
r =
    MkToml
      { coreConfig :: CoreConfigToml notifyEnv
coreConfig = Toml notifyEnv
l Toml notifyEnv
-> Optic' A_Lens NoIx (Toml notifyEnv) (CoreConfigToml notifyEnv)
-> CoreConfigToml notifyEnv
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Toml notifyEnv) (CoreConfigToml notifyEnv)
#coreConfig CoreConfigToml notifyEnv
-> CoreConfigToml notifyEnv -> CoreConfigToml notifyEnv
forall a. Semigroup a => a -> a -> a
<> Toml notifyEnv
r Toml notifyEnv
-> Optic' A_Lens NoIx (Toml notifyEnv) (CoreConfigToml notifyEnv)
-> CoreConfigToml notifyEnv
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Toml notifyEnv) (CoreConfigToml notifyEnv)
#coreConfig,
        legend :: Maybe (Seq KeyVal)
legend = Maybe (Seq KeyVal) -> Maybe (Seq KeyVal) -> Maybe (Seq KeyVal)
forall {k} {a}.
(LabelOptic "key" k a a Text Text, Is k A_Getter) =>
Maybe (Seq a) -> Maybe (Seq a) -> Maybe (Seq a)
unionLegend (Toml notifyEnv
l Toml notifyEnv
-> Optic' A_Lens NoIx (Toml notifyEnv) (Maybe (Seq KeyVal))
-> Maybe (Seq KeyVal)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Toml notifyEnv) (Maybe (Seq KeyVal))
#legend) (Toml notifyEnv
r Toml notifyEnv
-> Optic' A_Lens NoIx (Toml notifyEnv) (Maybe (Seq KeyVal))
-> Maybe (Seq KeyVal)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Toml notifyEnv) (Maybe (Seq KeyVal))
#legend)
      }
    where
      unionLegend :: Maybe (Seq a) -> Maybe (Seq a) -> Maybe (Seq a)
unionLegend Maybe (Seq a)
Nothing Maybe (Seq a)
Nothing = Maybe (Seq a)
forall a. Maybe a
Nothing
      unionLegend (Just Seq a
xs) Maybe (Seq a)
Nothing = Seq a -> Maybe (Seq a)
forall a. a -> Maybe a
Just Seq a
xs
      unionLegend Maybe (Seq a)
Nothing (Just Seq a
ys) = Seq a -> Maybe (Seq a)
forall a. a -> Maybe a
Just Seq a
ys
      unionLegend (Just Seq a
xs) (Just Seq a
ys) = Seq a -> Maybe (Seq a)
forall a. a -> Maybe a
Just (Seq a -> Seq a -> Seq a
forall {t :: Type -> Type} {k} {a}.
(Foldable t, LabelOptic "key" k a a Text Text, Is k A_Getter) =>
Seq a -> t a -> Seq a
uniqKeys Seq a
xs Seq a
ys)

      -- When combining two files' legends, we want the following behavor:
      --
      --   1. LHS keys override the RHS.
      --   2. Duplicates /within the same legend/ are allowed (assuming
      --     RHS duplicates are not overwritten).
      --
      -- We want 2 so that we later report an error for any found duplicates
      -- in the same config, as this is likely an error. But duplicates across
      -- multiple configs should merely override.
      --
      -- Hence we take everything from the LHS, then add everything from the
      -- RHS that is not a duplicate.
      uniqKeys :: Seq a -> t a -> Seq a
uniqKeys Seq a
xs t a
ys =
        let lhsKeys :: HashSet Text
lhsKeys = [Text] -> HashSet Text
forall a. Hashable a => [a] -> HashSet a
HSet.fromList (Seq Text -> [Text]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (Seq Text -> [Text]) -> Seq Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Optic' k NoIx a Text -> a -> Text
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a Text
#key (a -> Text) -> Seq a -> Seq Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq a
xs)
         in (Seq a -> a -> Seq a) -> Seq a -> t a -> Seq a
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HashSet Text -> Seq a -> a -> Seq a
forall {k} {a}.
(Is k A_Getter, LabelOptic "key" k a a Text Text) =>
HashSet Text -> Seq a -> a -> Seq a
go HashSet Text
lhsKeys) Seq a
xs t a
ys

      go :: HashSet Text -> Seq a -> a -> Seq a
go HashSet Text
lhsKeys Seq a
acc a
kv
        | Text -> HashSet Text -> Bool
forall a. Hashable a => a -> HashSet a -> Bool
HSet.member Text
key HashSet Text
lhsKeys = Seq a
acc
        | Bool
otherwise = Seq a
acc Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
:|> a
kv
        where
          key :: Text
          key :: Text
key = a
kv a -> Optic' k NoIx a Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' k NoIx a Text
#key

instance Monoid (Toml notifyEnv) where
  mempty :: Toml notifyEnv
mempty =
    MkToml
      { coreConfig :: CoreConfigToml notifyEnv
coreConfig = CoreConfigToml notifyEnv
forall a. Monoid a => a
mempty,
        legend :: Maybe (Seq KeyVal)
legend = Maybe (Seq KeyVal)
forall a. Maybe a
Nothing
      }