{-# 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 { forall a b. Parser a b -> Compose ((->) a) (Either Text) b
getParser :: Compose ((->) a) (Either Text) b }
  deriving (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
<$ :: forall a b. a -> Parser a b -> Parser a a
$c<$ :: forall a a b. a -> Parser a b -> Parser a a
fmap :: forall a b. (a -> b) -> Parser a a -> Parser a b
$cfmap :: forall a a b. (a -> b) -> Parser a a -> Parser a b
Functor, 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
<* :: forall a b. Parser a a -> Parser a b -> Parser a a
$c<* :: forall a a b. Parser a a -> Parser a b -> Parser a a
*> :: forall a b. Parser a a -> Parser a b -> Parser a b
$c*> :: forall a a b. Parser a a -> Parser a b -> Parser a b
liftA2 :: forall a b c.
(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
<*> :: forall a b. 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 :: forall a. a -> Parser a a
$cpure :: forall a a. a -> Parser a a
Applicative)

makeParser :: (a -> Either Text b) -> Parser a b
makeParser :: forall a b. (a -> Either Text b) -> Parser a b
makeParser = forall a b. Compose ((->) a) (Either Text) b -> Parser a b
Parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a b. Parser a b -> a -> Either Text b
runParser = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Parser a b -> Compose ((->) a) (Either Text) b
getParser

instance Monad (Parser a) where
  Parser a a
p >>= :: forall a b. Parser a a -> (a -> Parser a b) -> Parser a b
>>= a -> Parser a b
f = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \a
v -> forall a b. Parser a b -> a -> Either Text b
runParser Parser a a
p a
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
w -> 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 :: forall a. String -> Parser a a
fail String
s = forall a b. (a -> Either Text b) -> Parser a b
makeParser (forall a b. a -> b -> a
const (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 :: forall a. Text -> Parser Value a -> Parser Config a
required Text
key Parser Value a
pv = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
                case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Config
cfg of
                       Maybe Value
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"missing key: " forall a. Semigroup a => a -> a -> a
<> Text
key
                       Just Value
v  -> 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 :: forall a. Text -> Parser Value a -> Parser Config (Maybe a)
optional Text
key Parser Value a
pv = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
                case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Config
cfg of
                       Maybe Value
Nothing -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
                       Just Value
v  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall a. Text -> Parser Value a -> Parser Config [(Text, a)]
subassocs Text
prefix Parser Value a
pv = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
  forall k a. Map k a -> [(k, a)]
M.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. Parser a b -> a -> Either Text b
runParser Parser Value a
pv) (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey 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 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 :: forall a. Parser Value a -> Parser Value [a]
list Parser Value a
p = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \case
  List [Value]
vs -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. Parser a b -> a -> Either Text b
runParser Parser Value a
p) [Value]
vs
  Value
_       -> 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 = forall a b. (a -> Either Text b) -> Parser a b
makeParser 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 = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \case
  String Text
s -> forall a b. b -> Either a b
Right Text
s
  Value
_        -> 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 = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \case
  Number Scientific
n -> if Scientific -> Bool
Scientific.isInteger Scientific
n
                then case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger Scientific
n of
                      Just Int
x  -> forall a b. b -> Either a b
Right Int
x
                      Maybe Int
Nothing -> forall a b. a -> Either a b
Left Text
"int out of bounds"
                else forall a b. a -> Either a b
Left Text
"expected an integer"
  Value
_        -> 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 = forall a b. (a -> Either Text b) -> Parser a b
makeParser forall a b. (a -> b) -> a -> b
$ \case
  Bool Bool
b -> forall a b. b -> Either a b
Right Bool
b
  Value
_      -> forall a b. a -> Either a b
Left Text
"expected a boolean"