{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Configurator.Syntax
(
topLevel
, interp
) where
import Protolude hiding (First, try)
import Control.Monad (fail)
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as Lexer
import qualified Data.Char as Char
import Data.Configurator.Types
import qualified Data.Text as T
type Parser = Parsec Void Text
topLevel :: Parser [Directive]
topLevel :: Parser [Directive]
topLevel = Parser ()
skipLWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> 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
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
directive :: Parser Directive
directive :: Parser Directive
directive =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ do forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Text -> Parser ()
keyword Text
"import") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS
Text -> Directive
Import forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_
, do Text
ident <- Parser Text
identifier forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ Text -> Value -> Directive
Bind Text
ident forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'=' 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
*> ParsecT Void Text Identity Value
value)
, Text -> [Directive] -> Directive
Group Text
ident forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Char -> Char -> Parser a -> Parser a
brackets Char
'{' Char
'}' Parser [Directive]
directives
]
, do forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"#;" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHWS
Directive -> Directive
DirectiveComment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Directive
directive
]
directives :: Parser [Directive]
directives :: Parser [Directive]
directives = (Parser Directive
directive forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHWS) forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol 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 a
<* Parser ()
skipLWS
skipLWS :: Parser ()
skipLWS :: Parser ()
skipLWS = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
Lexer.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser ()
comment forall (f :: * -> *) a. Alternative f => f a
empty
where
beginComment :: Parser ()
beginComment = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
';')
comment :: Parser ()
comment = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser ()
beginComment forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
'\r' Bool -> Bool -> Bool
&& Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
'\n')
skipHWS :: Parser ()
skipHWS :: Parser ()
skipHWS = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
Lexer.space
(forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'\t') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())
(forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
Lexer.skipLineComment Tokens Text
"#")
forall (f :: * -> *) a. Alternative f => f a
empty
isIdentifier :: Char -> Bool
isIdentifier :: Char -> Bool
isIdentifier Char
c = Char -> Bool
Char.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
'-'
keyword :: Text -> Parser ()
keyword :: Text -> Parser ()
keyword Text
kw = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
kw forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAnyIdentifier)
where
isAnyIdentifier :: Char -> Bool
isAnyIdentifier Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char -> Bool
isIdentifier Char
c
identifier :: Parser Key
identifier :: Parser Text
identifier = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match (Parser Text
word forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.')
where
word :: Parser Text
word = Char -> Text -> Text
T.cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"alphanumeric character") Char -> Bool
isIdentifier
value :: Parser Value
value :: ParsecT Void Text Identity Value
value = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [
Bool -> Value
Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Bool
boolean
, Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_
, Scientific -> Value
Number forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Scientific
Lexer.scientific
, [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
']'
((ParsecT Void Text Identity Value
value forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS) forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipLWS))
]
where
boolean :: ParsecT Void Text Identity Bool
boolean = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"on" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
, forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"off" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
, forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"true" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
, forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"false" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
]
string_ :: Parser Text
string_ :: Parser Text
string_ = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
str
where
str :: ParsecT Void Text Identity String
str = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill Parser Char
charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char 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 = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
open forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipLWS) (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
close) Parser a
p
charLiteral :: Parser Char
charLiteral :: Parser Char
charLiteral = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
parseEscape
, forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
]
where
parseEscape :: Parser Char
parseEscape = do
Char
c <- forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (String
"ntru\"\\" :: [Char])
case Char
c of
Char
'n' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\n'
Char
't' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\t'
Char
'r' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\r'
Char
'"' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'"'
Char
'\\' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'\\'
Char
_ -> Parser Char
hexQuad
hexQuad :: Parser Char
hexQuad :: Parser Char
hexQuad = do
Int
a <- ParsecT Void Text Identity Int
quad
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 e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"\\u" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Int
quad
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 => String -> m a
fail String
"invalid UTF-16 surrogates"
where
quad :: ParsecT Void Text Identity Int
quad = String -> Int
mkNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Char.isHexDigit forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"hexadecimal digit")
mkNum :: String -> Int
mkNum = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => a -> Char -> a
step Int
0
step :: a -> Char -> a
step a
a Char
c = a
a forall a. Num a => a -> a -> a
* a
16 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
Char.digitToInt Char
c)
interp :: Parser [Interpolate]
interp :: Parser [Interpolate]
interp = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {s} {m :: * -> *} {e}.
(Token s ~ Char, Tokens s ~ Text, MonadParsec e s m) =>
[Interpolate] -> m [Interpolate]
p []
where
p :: [Interpolate] -> m [Interpolate]
p [Interpolate]
acc = do
Interpolate
h <- Text -> Interpolate
Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
/=Char
'$')
let rest :: m [Interpolate]
rest = do
let cont :: Interpolate -> m [Interpolate]
cont Interpolate
x = [Interpolate] -> m [Interpolate]
p (Interpolate
x forall a. a -> [a] -> [a]
: Interpolate
h forall a. a -> [a] -> [a]
: [Interpolate]
acc)
Char
c <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'$' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token s
c -> Token s
c forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Token s
c forall a. Eq a => a -> a -> Bool
== Char
'(')
case Char
c of
Char
'$' -> Interpolate -> m [Interpolate]
cont (Text -> Interpolate
Literal (Char -> Text
T.singleton Char
'$'))
Char
_ -> (Interpolate -> m [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
=<< forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
/=Char
')') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
')'
Bool
done <- forall e s (m :: * -> *). MonadParsec e s m => m 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 m [Interpolate]
rest