{-# LANGUAGE OverloadedStrings #-}
module Data.Configurator.Parser
(
topLevel
, interp
) where
import Control.Applicative
import Control.Exception (throw)
import Control.Monad (when)
import Data.Attoparsec.Text as A
import Data.Bits (shiftL)
import Data.Char (chr, isAlpha, isAlphaNum, isSpace)
import Data.Configurator.Types.Internal
import Data.Monoid (Monoid(..))
import Data.Text (Text)
import Data.Text.Lazy.Builder (fromText, singleton, toLazyText)
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
topLevel :: Parser [Directive]
topLevel :: Parser [Directive]
topLevel = Parser [Directive]
directives forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput
directive :: Parser Directive
directive :: Parser Directive
directive =
forall a. Monoid a => [a] -> a
mconcat [
Text -> Parser Text
string Text
"import" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Directive
Import forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_)
, Text -> Value -> Directive
Bind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i a. Parser i a -> Parser i a
try (Parser Text
ident forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Value
value
, Text -> [Directive] -> Directive
Group forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i a. Parser i a -> Parser i a
try (Parser Text
ident forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'{' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Directive]
directives forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'}'
]
directives :: Parser [Directive]
directives :: Parser [Directive]
directives = (Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Directive
directive forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHWS) forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy`
((Char -> Bool) -> Parser Char
satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n')
data Skip = Space |
skipLWS :: Parser ()
skipLWS :: Parser ()
skipLWS = forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan Skip
Space Skip -> Char -> Maybe Skip
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where go :: Skip -> Char -> Maybe Skip
go Skip
Space Char
c | Char -> Bool
isSpace Char
c = forall a. a -> Maybe a
Just Skip
Space
go Skip
Space Char
'#' = forall a. a -> Maybe a
Just Skip
Comment
go Skip
Space Char
_ = forall a. Maybe a
Nothing
go Skip
Comment Char
'\r' = forall a. a -> Maybe a
Just Skip
Space
go Skip
Comment Char
'\n' = forall a. a -> Maybe a
Just Skip
Space
go Skip
Comment Char
_ = forall a. a -> Maybe a
Just Skip
Comment
skipHWS :: Parser ()
skipHWS :: Parser ()
skipHWS = forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan Skip
Space Skip -> Char -> Maybe Skip
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where go :: Skip -> Char -> Maybe Skip
go Skip
Space Char
' ' = forall a. a -> Maybe a
Just Skip
Space
go Skip
Space Char
'\t' = forall a. a -> Maybe a
Just Skip
Space
go Skip
Space Char
'#' = forall a. a -> Maybe a
Just Skip
Comment
go Skip
Space Char
_ = forall a. Maybe a
Nothing
go Skip
Comment Char
'\r' = forall a. Maybe a
Nothing
go Skip
Comment Char
'\n' = forall a. Maybe a
Nothing
go Skip
Comment Char
_ = forall a. a -> Maybe a
Just Skip
Comment
ident :: Parser Name
ident :: Parser Text
ident = do
Text
n <- Char -> Text -> Text
T.cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isAlpha forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
isCont
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
n forall a. Eq a => a -> a -> Bool
== Text
"import") forall a b. (a -> b) -> a -> b
$
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> ConfigError
ParseError [Char]
"" forall a b. (a -> b) -> a -> b
$ [Char]
"reserved word (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
n forall a. [a] -> [a] -> [a]
++ [Char]
") used as identifier")
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
where
isCont :: Char -> Bool
isCont Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'
value :: Parser Value
value :: Parser Value
value = forall a. Monoid a => [a] -> a
mconcat [
Text -> Parser Text
string Text
"on" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
True)
, Text -> Parser Text
string Text
"off" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
False)
, Text -> Parser Text
string Text
"true" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
True)
, Text -> Parser Text
string Text
"false" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
False)
, Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_
, Rational -> Value
Number forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Fractional a => Parser a
rational
, [Value] -> Value
List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Char -> Char -> Parser a -> Parser a
brackets Char
'[' Char
']'
((Parser Value
value forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS) forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser Char
char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS))
]
string_ :: Parser Text
string_ :: Parser Text
string_ = do
Text
s <- Char -> Parser Char
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan Bool
False Bool -> Char -> Maybe Bool
isChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'"'
if Text
"\\" Text -> Text -> Bool
`T.isInfixOf` Text
s
then Text -> Parser Text
unescape Text
s
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
where
isChar :: Bool -> Char -> Maybe Bool
isChar Bool
True Char
_ = forall a. a -> Maybe a
Just Bool
False
isChar Bool
_ Char
'"' = forall a. Maybe a
Nothing
isChar Bool
_ Char
c = forall a. a -> Maybe a
Just (Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\')
brackets :: Char -> Char -> Parser a -> Parser a
brackets :: forall a. Char -> Char -> Parser a -> Parser a
brackets Char
open Char
close Parser a
p = Char -> Parser Char
char Char
open forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
close
embed :: Parser a -> Text -> Parser a
embed :: forall a. Parser a -> Text -> Parser a
embed Parser a
p Text
s = case forall a. Parser a -> Text -> Either [Char] a
parseOnly Parser a
p Text
s of
Left [Char]
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
Right a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
unescape :: Text -> Parser Text
unescape :: Text -> Parser Text
unescape = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
L.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Parser a
embed (Builder -> Parser Text Builder
p forall a. Monoid a => a
mempty)
where
p :: Builder -> Parser Text Builder
p Builder
acc = do
Text
h <- (Char -> Bool) -> Parser Text
A.takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\\')
let rest :: Parser Text Builder
rest = do
let cont :: Char -> Parser Text Builder
cont Char
c = Builder -> Parser Text Builder
p (Builder
acc forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
h forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
singleton Char
c)
Char
c <- Char -> Parser Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy ([Char] -> Char -> Bool
inClass [Char]
"ntru\"\\")
case Char
c of
Char
'n' -> Char -> Parser Text Builder
cont Char
'\n'
Char
't' -> Char -> Parser Text Builder
cont Char
'\t'
Char
'r' -> Char -> Parser Text Builder
cont Char
'\r'
Char
'"' -> Char -> Parser Text Builder
cont Char
'"'
Char
'\\' -> Char -> Parser Text Builder
cont Char
'\\'
Char
_ -> Char -> Parser Text Builder
cont forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Char
hexQuad
Bool
done <- forall t. Chunk t => Parser t Bool
atEnd
if Bool
done
then forall (m :: * -> *) a. Monad m => a -> m a
return (Builder
acc forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
h)
else Parser Text Builder
rest
hexQuad :: Parser Char
hexQuad :: Parser Char
hexQuad = do
Int
a <- forall a. Parser a -> Text -> Parser a
embed forall a. (Integral a, Bits a) => Parser a
hexadecimal forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parser Text
A.take Int
4
if Int
a forall a. Ord a => a -> a -> Bool
< Int
0xd800 Bool -> Bool -> Bool
|| Int
a forall a. Ord a => a -> a -> Bool
> Int
0xdfff
then forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
a)
else do
Int
b <- forall a. Parser a -> Text -> Parser a
embed forall a. (Integral a, Bits a) => Parser a
hexadecimal forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Parser Text
string Text
"\\u" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text
A.take Int
4
if Int
a forall a. Ord a => a -> a -> Bool
<= Int
0xdbff Bool -> Bool -> Bool
&& Int
b forall a. Ord a => a -> a -> Bool
>= Int
0xdc00 Bool -> Bool -> Bool
&& Int
b forall a. Ord a => a -> a -> Bool
<= Int
0xdfff
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (((Int
a forall a. Num a => a -> a -> a
- Int
0xd800) forall a. Bits a => a -> Int -> a
`shiftL` Int
10) forall a. Num a => a -> a -> a
+ (Int
b forall a. Num a => a -> a -> a
- Int
0xdc00) forall a. Num a => a -> a -> a
+ Int
0x10000)
else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid UTF-16 surrogates"
interp :: Parser [Interpolate]
interp :: Parser [Interpolate]
interp = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Interpolate] -> Parser [Interpolate]
p []
where
p :: [Interpolate] -> Parser [Interpolate]
p [Interpolate]
acc = do
Interpolate
h <- Text -> Interpolate
Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
A.takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'$')
let rest :: Parser [Interpolate]
rest = do
let cont :: Interpolate -> Parser [Interpolate]
cont Interpolate
x = [Interpolate] -> Parser [Interpolate]
p (Interpolate
x forall a. a -> [a] -> [a]
: Interpolate
h forall a. a -> [a] -> [a]
: [Interpolate]
acc)
Char
c <- Char -> Parser Char
char Char
'$' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'(')
case Char
c of
Char
'$' -> Interpolate -> Parser [Interpolate]
cont (Text -> Interpolate
Literal (Char -> Text
T.singleton Char
'$'))
Char
_ -> (Interpolate -> Parser [Interpolate]
cont forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Interpolate
Interpolate) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Text
A.takeWhile1 (forall a. Eq a => a -> a -> Bool
/=Char
')') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
')'
Bool
done <- forall t. Chunk t => Parser t Bool
atEnd
if Bool
done
then forall (m :: * -> *) a. Monad m => a -> m a
return (Interpolate
h forall a. a -> [a] -> [a]
: [Interpolate]
acc)
else Parser [Interpolate]
rest