{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}

module Data.Configurator.Parser
    ( Parser
    , runParser
    , bool
    , int
    , string
    , value
    , list
    , optional
    , required
    , subassocs
    ) where

import Protolude hiding (bool, list, optional)

import           Control.Monad.Fail
import           Data.Functor.Compose
import qualified Data.Map.Strict      as M
import qualified Data.Scientific      as Scientific
import qualified Data.Text            as T

import Data.Configurator.Types

-- | A generic parser.
--
-- A @'Parser' a b@ knows how to extract a @b@ from an @a@. Typical
-- instances are @'Parser' 'Value' a@, which handles the parsing of
-- individual configuration values, and @'Parser' 'Config' a@, which
-- handles extracting data from a full keyed configuration file.
newtype Parser a b = Parser { Parser a b -> Compose ((->) a) (Either Text) b
getParser :: Compose ((->) a) (Either Text) b }
  deriving (a -> Parser a b -> Parser a a
(a -> b) -> Parser a a -> Parser a b
(forall a b. (a -> b) -> Parser a a -> Parser a b)
-> (forall a b. a -> Parser a b -> Parser a a)
-> Functor (Parser a)
forall a b. a -> Parser a b -> Parser a a
forall a b. (a -> b) -> Parser a a -> Parser a b
forall a a b. a -> Parser a b -> Parser a a
forall a a b. (a -> b) -> Parser a a -> Parser a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Parser a b -> Parser a a
$c<$ :: forall a a b. a -> Parser a b -> Parser a a
fmap :: (a -> b) -> Parser a a -> Parser a b
$cfmap :: forall a a b. (a -> b) -> Parser a a -> Parser a b
Functor, Functor (Parser a)
a -> Parser a a
Functor (Parser a)
-> (forall a. a -> Parser a a)
-> (forall a b. Parser a (a -> b) -> Parser a a -> Parser a b)
-> (forall a b c.
    (a -> b -> c) -> Parser a a -> Parser a b -> Parser a c)
-> (forall a b. Parser a a -> Parser a b -> Parser a b)
-> (forall a b. Parser a a -> Parser a b -> Parser a a)
-> Applicative (Parser a)
Parser a a -> Parser a b -> Parser a b
Parser a a -> Parser a b -> Parser a a
Parser a (a -> b) -> Parser a a -> Parser a b
(a -> b -> c) -> Parser a a -> Parser a b -> Parser a c
forall a. Functor (Parser a)
forall a. a -> Parser a a
forall a a. a -> Parser a a
forall a b. Parser a a -> Parser a b -> Parser a a
forall a b. Parser a a -> Parser a b -> Parser a b
forall a b. Parser a (a -> b) -> Parser a a -> Parser a b
forall a a b. Parser a a -> Parser a b -> Parser a a
forall a a b. Parser a a -> Parser a b -> Parser a b
forall a a b. Parser a (a -> b) -> Parser a a -> Parser a b
forall a b c.
(a -> b -> c) -> Parser a a -> Parser a b -> Parser a c
forall a a b c.
(a -> b -> c) -> Parser a a -> Parser a b -> Parser a c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Parser a a -> Parser a b -> Parser a a
$c<* :: forall a a b. Parser a a -> Parser a b -> Parser a a
*> :: Parser a a -> Parser a b -> Parser a b
$c*> :: forall a a b. Parser a a -> Parser a b -> Parser a b
liftA2 :: (a -> b -> c) -> Parser a a -> Parser a b -> Parser a c
$cliftA2 :: forall a a b c.
(a -> b -> c) -> Parser a a -> Parser a b -> Parser a c
<*> :: Parser a (a -> b) -> Parser a a -> Parser a b
$c<*> :: forall a a b. Parser a (a -> b) -> Parser a a -> Parser a b
pure :: a -> Parser a a
$cpure :: forall a a. a -> Parser a a
$cp1Applicative :: forall a. Functor (Parser a)
Applicative)

makeParser :: (a -> Either Text b) -> Parser a b
makeParser :: (a -> Either Text b) -> Parser a b
makeParser = Compose ((->) a) (Either Text) b -> Parser a b
forall a b. Compose ((->) a) (Either Text) b -> Parser a b
Parser (Compose ((->) a) (Either Text) b -> Parser a b)
-> ((a -> Either Text b) -> Compose ((->) a) (Either Text) b)
-> (a -> Either Text b)
-> Parser a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either Text b) -> Compose ((->) a) (Either Text) b
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose

-- | Run a parser.
--
-- @'runParser' p x@ runs the parser @p@ on the input @x@, returning
-- a value @'Right' v@ on success, or @'Left' err@ on error.
runParser :: Parser a b -> a -> Either Text b
runParser :: Parser a b -> a -> Either Text b
runParser = Compose ((->) a) (Either Text) b -> a -> Either Text b
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose ((->) a) (Either Text) b -> a -> Either Text b)
-> (Parser a b -> Compose ((->) a) (Either Text) b)
-> Parser a b
-> a
-> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a b -> Compose ((->) a) (Either Text) b
forall a b. Parser a b -> Compose ((->) a) (Either Text) b
getParser

instance Monad (Parser a) where
  Parser a a
p >>= :: Parser a a -> (a -> Parser a b) -> Parser a b
>>= a -> Parser a b
f = (a -> Either Text b) -> Parser a b
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((a -> Either Text b) -> Parser a b)
-> (a -> Either Text b) -> Parser a b
forall a b. (a -> b) -> a -> b
$ \a
v -> Parser a a -> a -> Either Text a
forall a b. Parser a b -> a -> Either Text b
runParser Parser a a
p a
v Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
w -> Parser a b -> a -> Either Text b
forall a b. Parser a b -> a -> Either Text b
runParser (a -> Parser a b
f a
w) a
v

instance MonadFail (Parser a) where
  fail :: String -> Parser a a
fail String
s = (a -> Either Text a) -> Parser a a
forall a b. (a -> Either Text b) -> Parser a b
makeParser (Either Text a -> a -> Either Text a
forall a b. a -> b -> a
const (Text -> Either Text a
forall a b. a -> Either a b
Left (String -> Text
T.pack String
s)))

-- | Parse a required configuration field.
--
-- @'required' key p@ expects the field @key@ to be present, and parses
-- its value with @p@.
required :: Key -> Parser Value a -> Parser Config a
required :: Text -> Parser Value a -> Parser Config a
required Text
key Parser Value a
pv = (Config -> Either Text a) -> Parser Config a
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Config -> Either Text a) -> Parser Config a)
-> (Config -> Either Text a) -> Parser Config a
forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
                case Text -> Config -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Config
cfg of
                       Maybe Value
Nothing -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"missing key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key
                       Just Value
v  -> Parser Value a -> Value -> Either Text a
forall a b. Parser a b -> a -> Either Text b
runParser Parser Value a
pv Value
v

-- | Parse an optional configuration field.
--
-- @'optional' key p@ returns 'Nothing' if the field @key@ is not present.
-- Otherwise it returns @'Just' v@, where @v@ is the result of parsing the
-- field value with @p@.
optional :: Key -> Parser Value a -> Parser Config (Maybe a)
optional :: Text -> Parser Value a -> Parser Config (Maybe a)
optional Text
key Parser Value a
pv = (Config -> Either Text (Maybe a)) -> Parser Config (Maybe a)
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Config -> Either Text (Maybe a)) -> Parser Config (Maybe a))
-> (Config -> Either Text (Maybe a)) -> Parser Config (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
                case Text -> Config -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Config
cfg of
                       Maybe Value
Nothing -> Maybe a -> Either Text (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
                       Just Value
v  -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either Text a -> Either Text (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Value a -> Value -> Either Text a
forall a b. Parser a b -> a -> Either Text b
runParser Parser Value a
pv Value
v

-- | Parse a set of fields with a shared prefix.
--
-- @'subassocs' prefix p@ extracts all configuration keys one level
-- below @prefix@, and collects pairs of the full keys and the
-- corresponding field values parsed with @p@.
subassocs :: Key -> Parser Value a -> Parser Config [(Key, a)]
subassocs :: Text -> Parser Value a -> Parser Config [(Text, a)]
subassocs Text
prefix Parser Value a
pv = (Config -> Either Text [(Text, a)]) -> Parser Config [(Text, a)]
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Config -> Either Text [(Text, a)]) -> Parser Config [(Text, a)])
-> (Config -> Either Text [(Text, a)]) -> Parser Config [(Text, a)]
forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
  Map Text a -> [(Text, a)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text a -> [(Text, a)])
-> Either Text (Map Text a) -> Either Text [(Text, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either Text a) -> Config -> Either Text (Map Text a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Parser Value a -> Value -> Either Text a
forall a b. Parser a b -> a -> Either Text b
runParser Parser Value a
pv) ((Text -> Value -> Bool) -> Config -> Config
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey Text -> Value -> Bool
forall p. Text -> p -> Bool
match Config
cfg)
 where
  match :: Text -> p -> Bool
match Text
k p
_ = if Text -> Bool
T.null Text
prefix
                then Bool -> Bool
not (Text -> Text -> Bool
T.isInfixOf Text
"." Text
k)
                else case Text -> Text -> Maybe Text
T.stripPrefix (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".") Text
k of
                       Maybe Text
Nothing   -> Bool
False
                       Just Text
suff -> Bool -> Bool
not (Text -> Text -> Bool
T.isInfixOf Text
"." Text
suff)

-- | Parse a list of values.
--
-- @'list' p@ expects a list value, and parses each entry with @p@.
list :: Parser Value a -> Parser Value [a]
list :: Parser Value a -> Parser Value [a]
list Parser Value a
p = (Value -> Either Text [a]) -> Parser Value [a]
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Value -> Either Text [a]) -> Parser Value [a])
-> (Value -> Either Text [a]) -> Parser Value [a]
forall a b. (a -> b) -> a -> b
$ \case
  List [Value]
vs -> (Value -> Either Text a) -> [Value] -> Either Text [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Parser Value a -> Value -> Either Text a
forall a b. Parser a b -> a -> Either Text b
runParser Parser Value a
p) [Value]
vs
  Value
_       -> Text -> Either Text [a]
forall a b. a -> Either a b
Left Text
"expected a list"

-- | Extract a raw value.
--
-- 'value' returns a configuration value in its raw form.
value :: Parser Value Value
value :: Parser Value Value
value = (Value -> Either Text Value) -> Parser Value Value
forall a b. (a -> Either Text b) -> Parser a b
makeParser Value -> Either Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Extract a string value.
--
-- 'string' expects the given value to be a string.
string :: Parser Value Text
string :: Parser Value Text
string = (Value -> Either Text Text) -> Parser Value Text
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Value -> Either Text Text) -> Parser Value Text)
-> (Value -> Either Text Text) -> Parser Value Text
forall a b. (a -> b) -> a -> b
$ \case
  String Text
s -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
s
  Value
_        -> Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"expected a string"

-- | Extract an integer value.
--
-- 'int' expects the given value to be an 'Int'.
int :: Parser Value Int
int :: Parser Value Int
int = (Value -> Either Text Int) -> Parser Value Int
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Value -> Either Text Int) -> Parser Value Int)
-> (Value -> Either Text Int) -> Parser Value Int
forall a b. (a -> b) -> a -> b
$ \case
  Number Scientific
n -> if Scientific -> Bool
Scientific.isInteger Scientific
n
                then case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger Scientific
n of
                      Just Int
x  -> Int -> Either Text Int
forall a b. b -> Either a b
Right Int
x
                      Maybe Int
Nothing -> Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"int out of bounds"
                else Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"expected an integer"
  Value
_        -> Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"expected an integer"

-- | Extract a boolean value.
--
-- 'bool' expects the given value to be boolean.
bool :: Parser Value Bool
bool :: Parser Value Bool
bool = (Value -> Either Text Bool) -> Parser Value Bool
forall a b. (a -> Either Text b) -> Parser a b
makeParser ((Value -> Either Text Bool) -> Parser Value Bool)
-> (Value -> Either Text Bool) -> Parser Value Bool
forall a b. (a -> b) -> a -> b
$ \case
  Bool Bool
b -> Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
b
  Value
_      -> Text -> Either Text Bool
forall a b. a -> Either a b
Left Text
"expected a boolean"