{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}

module Conftrack
  ( Config(..)
  , Warning(..)
  , runFetchConfig
  , readValue
  , readOptionalValue
  , readRequiredValue
  , readNested
  , SomeSource
  , ConfigError(..)
  , Key(..)
  , Value(..)
  ) where

import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith)
import Conftrack.Source (SomeSource (..), ConfigSource (..))

import Prelude hiding (unzip)
import Control.Monad.State (get, StateT (..), MonadState (..), modify)
import Data.Functor ((<&>))
import Control.Monad.Reader (MonadIO (liftIO))
import Data.List.NonEmpty (NonEmpty, unzip)
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad (forM, foldM)
import Data.Either (isRight)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
import Control.Monad.Trans (lift)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (isJust)


class Config a where
  readConfig :: FetchMonad a

type FetchMonad = StateT (NonEmpty SomeSource, [KeyPart], [Origin], [Warning]) (ExceptT [ConfigError] IO)

newtype Warning = Warning Text
 deriving Show

runFetchConfig :: Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
runFetchConfig sources = do
  results <- runExceptT $ runStateT readConfig (sources, [], [], [])
  case results of
    Left a -> pure $ Left a
    Right (result, (sources, _prefix, origins, warnings)) -> do
      unusedWarnings <- collectUnused sources
      pure $ Right (result, origins, unusedWarnings <> warnings)

readOptionalValue :: ConfigValue a => Key -> FetchMonad (Maybe a)
readOptionalValue bareKey = do
  (sources, prefix, origins, warnings) <- get

  let key = bareKey `prefixedWith` prefix

  stuff <- liftIO $ firstMatchInSources key (NonEmpty.toList sources) <&> NonEmpty.fromList

  let (maybeValues, states) = unzip stuff

  let values = maybeValues <&> \case
        Right (val, text) -> fromConfig val <&> (\val -> (val, Origin key text))
        Left e -> Left e

  val <- case fmap (\(Right a) -> a) $ NonEmpty.filter isRight values of
    [] -> pure (Nothing, Origin key "default value")
    (value, origin):_ -> pure (Just value, origin)

  put (states, prefix, snd val : origins, warnings)
  pure (fst val)

readRequiredValue :: ConfigValue a => Key -> FetchMonad a
readRequiredValue key =
  readOptionalValue key >>= \case
    Nothing -> lift $ throwE [NotPresent key]
    Just a -> pure a

readValue :: ConfigValue a => a -> Key -> FetchMonad a
readValue defaultValue key =
  readOptionalValue key >>= \case
    Just a -> pure a
    Nothing -> do
      modify (\(states, prefix, origins, warnings) ->
                (states, prefix, Origin key "default value" : origins, warnings))
      pure defaultValue

firstMatchInSources :: Key -> [SomeSource] -> IO [(Either ConfigError (Value, Text), SomeSource)]
firstMatchInSources _ [] = pure []
firstMatchInSources key (SomeSource (source, sourceState):sources) = do
  (eitherValue, newState) <- runStateT (fetchValue key source) sourceState

  case eitherValue of
    Left _ -> do
      firstMatchInSources key sources
        <&> (\a -> (eitherValue, SomeSource (source, newState)) : a)
    Right _ ->
      pure $ (eitherValue, SomeSource (source, newState)) : fmap (Left Shadowed ,) sources


readNested :: forall a. Config a => Key -> FetchMonad a
readNested (Key prefix') = do
  prefix <- state (\(sources, prefix, origins, warnings) ->
                     (prefix, (sources, prefix <> NonEmpty.toList prefix', origins, warnings)))
  config <- readConfig
  modify (\(sources, _, origins, warnings) -> (sources, prefix, origins, warnings))
  pure config

collectUnused :: NonEmpty SomeSource -> IO [Warning]
collectUnused sources = do
  forM sources (\(SomeSource (source, sourceState)) ->
    runStateT (leftovers source) sourceState <&> fst)
    <&> fmap (\(Just a) -> Warning $ "Unused Keys " <> T.pack (show a))
        . filter (\(Just a) -> not (null a))
        . NonEmpty.filter isJust