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

module Conftrack.Source.Aeson (JsonSource(..), mkJsonSource, mkJsonSourceWith, mkJsonFileSource) where

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

import Prelude hiding (readFile)
import qualified Data.Aeson as A
import Control.Monad.State (get, modify, MonadState (..))
import Data.Function ((&))
import Data.Text (Text)
import qualified Data.Aeson.Text as A
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Aeson.Types as A
import qualified Data.Aeson.Key as A
import Data.Aeson.Types (unexpected)
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad ((>=>))
import Data.Functor ((<&>))
import System.OsPath (OsPath)
import qualified System.OsPath as OS
import System.File.OsPath (readFile)
import qualified Data.Aeson.KeyMap as A
import qualified Data.Text.Encoding as BS

data JsonSource = JsonSource
  { jsonSourceValue :: A.Value
  , jsonSourceDescription :: Text
  } deriving (Show)

mkJsonSource :: A.Value -> SomeSource
mkJsonSource value = mkJsonSourceWith ("JSON string " <> LT.toStrict (A.encodeToLazyText value)) value

mkJsonSourceWith :: Text -> A.Value -> SomeSource
mkJsonSourceWith description value = SomeSource (source, [])
  where source = JsonSource value description

mkJsonFileSource :: OsPath -> IO (Maybe SomeSource)
mkJsonFileSource path = do
  bytes <- readFile path
  pathAsText <- OS.decodeUtf path <&> LT.toStrict . LT.pack
  pure $ A.decode bytes
    <&> mkJsonSourceWith ("JSON file " <> pathAsText)

instance ConfigSource JsonSource where
  type SourceState JsonSource = [Key]

  fetchValue key@(Key parts) JsonSource{..} = do
    case A.parseEither (lookupJsonPath (NonEmpty.toList parts) >=> parseJsonValue) jsonSourceValue of
      Left a -> pure $ Left (ParseError (T.pack a))
      Right val -> do
        modify (key :)
        pure $ Right (val, jsonSourceDescription)

  leftovers JsonSource{..} = do
    used <- get

    allJsonPaths jsonSourceValue
     & filter (`notElem` used)
     & Just
     & pure

-- | this is essentially a FromJSON instance for Value, but not written as one
-- so as to not introduce an orphan
parseJsonValue :: A.Value -> A.Parser Value
parseJsonValue = \case
  (A.String bytes) -> pure $ ConfigString (BS.encodeUtf8 bytes)
  (A.Number num) ->
    A.parseJSON (A.Number num) <&> ConfigInteger
  (A.Bool b) -> pure $ ConfigBool b
  A.Null -> pure ConfigNull
  (A.Object _) -> unexpected "unexpected json object"
  (A.Array _) -> unexpected "unexpected json array"

lookupJsonPath ::  [KeyPart] -> A.Value -> A.Parser A.Value
lookupJsonPath [] value = pure value
lookupJsonPath (part:parts) value = do
  A.withObject "blub" (\obj -> obj A..: A.fromText part) value
  >>= lookupJsonPath parts

allJsonPaths :: A.Value -> [Key]
allJsonPaths = fmap keyToKey . subKeys []
  where
    keyToKey keys = Key (fmap aesonKeyToText keys)
    aesonKeyToText (key :: A.Key) = case A.parseMaybe A.parseJSON (A.toJSON key) of
      Nothing -> error "key not representable as text; this is a bug in conftrack-aeson."
      Just a -> a
    subKeys prefix (A.Object keymap) =
      A.foldMapWithKey (\key v -> subKeys (prefix <> [key]) v) keymap
    subKeys prefix _ = case NonEmpty.nonEmpty prefix of
      Just key -> [key]
      _ -> undefined