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

module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where

import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import Data.List.NonEmpty (NonEmpty, prependList)
import qualified Data.List.NonEmpty as NonEmpty
import System.OsPath (OsPath, encodeUtf)
import qualified Data.Text.Encoding as BS
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (Lift(lift))

data Value =
  ConfigString BS.ByteString
  | ConfigInteger Integer
  | ConfigMaybeInteger BS.ByteString Integer
  | ConfigOther Text Text
  | ConfigBool Bool
  | ConfigNull
  deriving Show

type KeyPart = Text

newtype Key = Key (NonEmpty KeyPart)
  deriving newtype (Eq, Ord)
  deriving (Lift)

instance Show Key where
  show (Key parts) = T.unpack (T.intercalate "." (NonEmpty.toList parts))

key :: QuasiQuoter
key = QuasiQuoter
  { quoteExp = lift . Key . NonEmpty.fromList . T.splitOn "." . T.pack
  , quotePat = \_ -> fail "key quoter cannot be used in patterns"
  , quoteType = \_ -> fail "key quasi-quote cannot be used for types"
  , quoteDec = \_ -> fail "key quasi-quote cannot be used in declarations"}


prefixedWith :: Key -> [KeyPart] -> Key
prefixedWith (Key key) prefix = Key (prependList prefix key)

data ConfigError =
  ParseError Text
  | TypeMismatch Text Value
  | NotPresent Key
  | Shadowed
  deriving Show

class ConfigValue a where
  fromConfig :: Value -> Either ConfigError a
  prettyValue :: a -> Text

  default prettyValue :: Show a => a -> Text
  prettyValue = T.pack . show

data Origin = forall a. ConfigValue a => Origin a Text

instance Show Origin where
  show (Origin a text) = "Origin " <> T.unpack (prettyValue a) <> " " <> T.unpack text

withString :: (BS.ByteString -> Either ConfigError a) -> Value -> Either ConfigError a
withString f (ConfigString a) = f a
withString f (ConfigMaybeInteger a _) = f a
withString _ val = Left (TypeMismatch "text" val)

withInteger :: (Integer -> Either ConfigError a) -> Value -> Either ConfigError a
withInteger f (ConfigInteger a) = f a
withInteger f (ConfigMaybeInteger _ a) = f a
withInteger _ val = Left (TypeMismatch "integer" val)

instance ConfigValue Text where
  fromConfig = withString (Right . BS.decodeUtf8)

instance ConfigValue Integer where
  fromConfig = withInteger Right

instance ConfigValue Int where
  fromConfig = withInteger (Right . fromInteger)

instance ConfigValue Bool where
  fromConfig (ConfigBool b) = Right b
  fromConfig val = Left (TypeMismatch "bool" val)

instance ConfigValue a => ConfigValue (Maybe a) where
  fromConfig ConfigNull = Right Nothing
  fromConfig just = fmap Just (fromConfig just)

  prettyValue Nothing = "null"
  prettyValue (Just a) = prettyValue a

instance ConfigValue OsPath where
  fromConfig = \case
    (ConfigString text) -> stringToPath text
    (ConfigMaybeInteger text _) -> stringToPath text
    val -> Left (TypeMismatch "path" val)
   where stringToPath text = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
          Right path -> Right path
          Left err -> Left (ParseError (T.pack $ show err))

instance ConfigValue LB.ByteString where
  fromConfig = withString (Right . LB.fromStrict)

instance ConfigValue BS.ByteString where
  fromConfig = withString Right