{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module:      Data.Configurator.Syntax
-- Copyright:   (c) 2011 MailRank, Inc.
--              (c) 2015-2016 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
-- Portability: portable
--
-- A parser for configuration files.

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

-- | Skip lines, comments, or horizontal white space.
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')

-- | Skip comments or horizontal white space.
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)

-- | Parse a string interpolation spec.
--
-- The sequence @$$@ is treated as a single @$@ character.  The
-- sequence @$(@ begins a section to be interpolated, and @)@ ends it.
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