{-# 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, withString) 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))

-- | A generic value read from a config source, to be parsed into a more useful type
-- (see the 'ConfigValue' class).
data Value =
  ConfigString BS.ByteString
  | ConfigInteger Integer
  -- | A value which may be an integer, but the source cannot say for sure, e.g. because
  -- its values are entirely untyped. Use 'withString' to handle such cases.
  | ConfigMaybeInteger BS.ByteString Integer
  | ConfigOther Text Text
  | ConfigBool Bool
  | ConfigNull
  deriving Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show

type KeyPart = Text

-- | A configuration key is a non-empty list of parts. By convention, these parts
-- are separated by dots when written, although dots withing parts are not disallowed.
--
-- For writing values easily, consider enabling the @QuasiQuotes@ language extension
-- to use 'key':
--
-- >>> [key|foo.bar|]
-- foo.bar
newtype Key = Key (NonEmpty KeyPart)
  deriving newtype (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: Key -> Key -> Bool
Eq, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Key -> Key -> Ordering
compare :: Key -> Key -> Ordering
$c< :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
>= :: Key -> Key -> Bool
$cmax :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
min :: Key -> Key -> Key
Ord)
  deriving ((forall (m :: * -> *). Quote m => Key -> m Exp)
-> (forall (m :: * -> *). Quote m => Key -> Code m Key) -> Lift Key
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Key -> m Exp
forall (m :: * -> *). Quote m => Key -> Code m Key
$clift :: forall (m :: * -> *). Quote m => Key -> m Exp
lift :: forall (m :: * -> *). Quote m => Key -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Key -> Code m Key
liftTyped :: forall (m :: * -> *). Quote m => Key -> Code m Key
Lift)

instance Show Key where
  show :: Key -> String
show (Key NonEmpty Text
parts) = Text -> String
T.unpack (Text -> [Text] -> Text
T.intercalate Text
"." (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
parts))

-- | to write values of 'Key' easily
key :: QuasiQuoter
key :: QuasiQuoter
key = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = Key -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Key -> m Exp
lift (Key -> Q Exp) -> (String -> Key) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> Key
Key (NonEmpty Text -> Key)
-> (String -> NonEmpty Text) -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> NonEmpty Text
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList ([Text] -> NonEmpty Text)
-> (String -> [Text]) -> String -> NonEmpty Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  , quotePat :: String -> Q Pat
quotePat = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"key quoter cannot be used in patterns"
  , quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"key quasi-quote cannot be used for types"
  , quoteDec :: String -> Q [Dec]
quoteDec = \String
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"key quasi-quote cannot be used in declarations"}


prefixedWith :: Key -> [KeyPart] -> Key
prefixedWith :: Key -> [Text] -> Key
prefixedWith (Key NonEmpty Text
k) [Text]
prefix = NonEmpty Text -> Key
Key ([Text] -> NonEmpty Text -> NonEmpty Text
forall a. [a] -> NonEmpty a -> NonEmpty a
prependList [Text]
prefix NonEmpty Text
k)

data ConfigError =
  ParseError Text
  | TypeMismatch Text Value
  | NotPresent Key
  | Shadowed
  deriving Int -> ConfigError -> ShowS
[ConfigError] -> ShowS
ConfigError -> String
(Int -> ConfigError -> ShowS)
-> (ConfigError -> String)
-> ([ConfigError] -> ShowS)
-> Show ConfigError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigError -> ShowS
showsPrec :: Int -> ConfigError -> ShowS
$cshow :: ConfigError -> String
show :: ConfigError -> String
$cshowList :: [ConfigError] -> ShowS
showList :: [ConfigError] -> ShowS
Show

-- | Values which can be read from a config source must implement this class
class ConfigValue a where
  fromConfig :: Value -> Either ConfigError a
  -- | optionally, a function to pretty-print values of this type, used by the
  -- functions of "Conftrack.Pretty". If not given, defaults to @a@'s 'Show' instance.
  prettyValue :: a -> Text

  default prettyValue :: Show a => a -> Text
  prettyValue = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

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

instance Show Origin where
  show :: Origin -> String
show (Origin a
a Text
text) = String
"Origin " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (a -> Text
forall a. ConfigValue a => a -> Text
prettyValue a
a) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
text

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

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

instance ConfigValue Text where
  fromConfig :: Value -> Either ConfigError Text
fromConfig = (ByteString -> Either ConfigError Text)
-> Value -> Either ConfigError Text
forall a.
(ByteString -> Either ConfigError a)
-> Value -> Either ConfigError a
withString (Text -> Either ConfigError Text
forall a b. b -> Either a b
Right (Text -> Either ConfigError Text)
-> (ByteString -> Text) -> ByteString -> Either ConfigError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
BS.decodeUtf8)

instance ConfigValue Integer where
  fromConfig :: Value -> Either ConfigError Integer
fromConfig = (Integer -> Either ConfigError Integer)
-> Value -> Either ConfigError Integer
forall a.
(Integer -> Either ConfigError a) -> Value -> Either ConfigError a
withInteger Integer -> Either ConfigError Integer
forall a b. b -> Either a b
Right

instance ConfigValue Int where
  fromConfig :: Value -> Either ConfigError Int
fromConfig = (Integer -> Either ConfigError Int)
-> Value -> Either ConfigError Int
forall a.
(Integer -> Either ConfigError a) -> Value -> Either ConfigError a
withInteger (Int -> Either ConfigError Int
forall a b. b -> Either a b
Right (Int -> Either ConfigError Int)
-> (Integer -> Int) -> Integer -> Either ConfigError Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger)

instance ConfigValue Bool where
  fromConfig :: Value -> Either ConfigError Bool
fromConfig (ConfigBool Bool
b) = Bool -> Either ConfigError Bool
forall a b. b -> Either a b
Right Bool
b
  fromConfig Value
val = ConfigError -> Either ConfigError Bool
forall a b. a -> Either a b
Left (Text -> Value -> ConfigError
TypeMismatch Text
"bool" Value
val)

instance ConfigValue a => ConfigValue (Maybe a) where
  fromConfig :: Value -> Either ConfigError (Maybe a)
fromConfig Value
ConfigNull = Maybe a -> Either ConfigError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
  fromConfig Value
just = (a -> Maybe a)
-> Either ConfigError a -> Either ConfigError (Maybe a)
forall a b.
(a -> b) -> Either ConfigError a -> Either ConfigError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Value -> Either ConfigError a
forall a. ConfigValue a => Value -> Either ConfigError a
fromConfig Value
just)

  prettyValue :: Maybe a -> Text
prettyValue Maybe a
Nothing = Text
"null"
  prettyValue (Just a
a) = a -> Text
forall a. ConfigValue a => a -> Text
prettyValue a
a

instance ConfigValue OsPath where
  fromConfig :: Value -> Either ConfigError OsPath
fromConfig = \case
    (ConfigString ByteString
text) -> ByteString -> Either ConfigError OsPath
stringToPath ByteString
text
    (ConfigMaybeInteger ByteString
text Integer
_) -> ByteString -> Either ConfigError OsPath
stringToPath ByteString
text
    Value
val -> ConfigError -> Either ConfigError OsPath
forall a b. a -> Either a b
Left (Text -> Value -> ConfigError
TypeMismatch Text
"path" Value
val)
   where stringToPath :: ByteString -> Either ConfigError OsPath
stringToPath ByteString
text = case String -> Either SomeException OsPath
forall (m :: * -> *). MonadThrow m => String -> m OsPath
encodeUtf (Text -> String
T.unpack (ByteString -> Text
BS.decodeUtf8 ByteString
text)) of
          Right OsPath
path -> OsPath -> Either ConfigError OsPath
forall a b. b -> Either a b
Right OsPath
path
          Left SomeException
err -> ConfigError -> Either ConfigError OsPath
forall a b. a -> Either a b
Left (Text -> ConfigError
ParseError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
err))

instance ConfigValue LB.ByteString where
  fromConfig :: Value -> Either ConfigError ByteString
fromConfig = (ByteString -> Either ConfigError ByteString)
-> Value -> Either ConfigError ByteString
forall a.
(ByteString -> Either ConfigError a)
-> Value -> Either ConfigError a
withString (ByteString -> Either ConfigError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either ConfigError ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Either ConfigError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.fromStrict)

instance ConfigValue BS.ByteString where
  fromConfig :: Value -> Either ConfigError ByteString
fromConfig = (ByteString -> Either ConfigError ByteString)
-> Value -> Either ConfigError ByteString
forall a.
(ByteString -> Either ConfigError a)
-> Value -> Either ConfigError a
withString ByteString -> Either ConfigError ByteString
forall a b. b -> Either a b
Right