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

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

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

import Prelude hiding (unzip)
import Control.Monad.State (StateT (..))
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty, unzip)
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad (forM, (>=>))
import Data.Either (isRight)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (isJust, mapMaybe)


class Config a where
  readConfig :: Fetch a

data FetcherState = FetcherState
  { fetcherSources :: [SomeSource]
  , fetcherPrefix :: [KeyPart]
  , fetcherOrigins :: [Origin]
  , fetcherWarnings :: [Warning]
  , fetcherErrors :: [ConfigError]
  }

newtype Fetch a = Fetch (FetcherState -> IO (a, FetcherState))
  deriving (Functor)

newtype Warning = Warning Text
 deriving Show

instance Applicative Fetch where
  pure a = Fetch (\s -> pure (a, s))

  liftA2 f (Fetch m) (Fetch n) = Fetch $ \s -> do
    (a, s2) <- m s
    (b, s3) <- n s2
    pure (f a b, s3)


runFetchConfig :: forall a. Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
runFetchConfig sources = do
  let (Fetch m) = readConfig @a

  (result, FetcherState sources2 _ origins warnings errors) <- m (FetcherState (NonEmpty.toList sources) [] [] [] [])
  unusedWarnings <- collectUnused sources2
  if null errors
    then pure $ Right (result, origins, unusedWarnings <> warnings)
    else pure $ Left errors

configKeysOf :: forall a. Config a => IO [Key]
configKeysOf = do
  let (Fetch m) = readConfig @a
  (_, FetcherState _ _ origins warnings errors) <- m (FetcherState [] [] [] [] [])

  let keys = mapMaybe (\case {(NotPresent key) -> Just key; _ -> Nothing }) errors
  pure keys



readOptionalValue :: ConfigValue a => Key -> Fetch (Maybe a)
readOptionalValue bareKey = Fetch $ \s1@FetcherState{..} -> do

  let key = bareKey `prefixedWith` fetcherPrefix

  stuff <- firstMatchInSources key fetcherSources

  let (maybeValues, sources) = 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) $ filter isRight values of
    [] -> pure (Nothing, Origin key "default value")
    (value, origin):_ -> pure (Just value, origin)

  pure (fst val, s1 { fetcherSources = sources, fetcherOrigins = snd val : fetcherOrigins })


readRequiredValue :: ConfigValue a => Key -> Fetch a
readRequiredValue key =
  let
    Fetch m = readOptionalValue key
  in
    Fetch (m >=> (\(a, s) -> case a of
      Nothing ->
        let
          dummy = error "A nonexisting config value was evaluated. This is a bug."
        in
          pure (dummy, s { fetcherErrors = NotPresent (key `prefixedWith` fetcherPrefix s) : fetcherErrors s })
      Just v -> pure (v, s)))

readValue :: forall a. ConfigValue a => a -> Key -> Fetch a
readValue defaultValue key =
  let
    Fetch m = readOptionalValue @a key
  in
    Fetch (m >=> (\(a, s) -> case a of
      Just val -> pure (val, s)
      Nothing -> do
        pure (defaultValue, s { fetcherOrigins = Origin (key `prefixedWith` fetcherPrefix s) "default value" :  fetcherOrigins s })))

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 -> Fetch a
readNested (Key prefix') = Fetch $ \s1 -> do
  let (Fetch nested) = readConfig @a
  (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix' })
  pure (config, s2 { fetcherPrefix = fetcherPrefix s1 })


collectUnused :: [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))
        . filter isJust