{-# 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
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
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)))
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
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
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)
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"
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
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"
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"
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"