{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith, key)
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)
import Data.Map (Map)
import qualified Data.Map.Strict as M


class Config a where
  readConfig :: Fetch a

data FetcherState = FetcherState
  { fetcherSources :: [SomeSource]
  , fetcherPrefix :: [KeyPart]
  , fetcherOrigins :: Map Key [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, Map Key [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 _ _ _ _ errors) <- m (FetcherState [] [] [] [] [])

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



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

  let k = bareKey `prefixedWith` fetcherPrefix

  stuff <- firstMatchInSources k fetcherSources

  let (maybeValues, sources) = unzip stuff

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

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

  pure (fst val, s1 { fetcherSources = sources
                    , fetcherOrigins = M.insertWith (<>) k (snd val) fetcherOrigins })


readRequiredValue :: ConfigValue a => Key -> Fetch a
readRequiredValue k =
  let
    Fetch m = readOptionalValue k
  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 (k `prefixedWith` fetcherPrefix s) : fetcherErrors s })
      Just v -> pure (v, s)))

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

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

  case eitherValue of
    Left _ -> do
      firstMatchInSources k 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 })

readNestedOptional :: forall a. Config a => Key -> Fetch (Maybe a)
readNestedOptional (Key prefix) = Fetch $ \s1 -> do
  let (Fetch nested) = readConfig @a
  (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix })

  if null (fetcherErrors s2)
    then pure (Just config, s2 { fetcherPrefix = fetcherPrefix s1 })
    -- TODO: resetting errors like this makes configKeysOf less useful. Perhaps move nested errors to warnings?
    else pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1
                           , fetcherErrors = fetcherErrors 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