{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module:      Data.Configurator.Parser
-- Copyright:   (c) 2011 MailRank, Inc.
-- License:     BSD3
-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
-- Stability:   experimental
-- Portability: portable
--
-- A parser for configuration files.

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 Parser [Directive] -> Parser Text () -> Parser [Directive]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser [Directive] -> Parser Text () -> Parser [Directive]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput
  
directive :: Parser Directive
directive :: Parser Directive
directive =
  [Parser Directive] -> Parser Directive
forall a. Monoid a => [a] -> a
mconcat [
    Text -> Parser Text
string "import" Parser Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipLWS Parser Text () -> Parser Directive -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Directive
Import (Text -> Directive) -> Parser Text -> Parser Directive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_)
  , Text -> Value -> Directive
Bind (Text -> Value -> Directive)
-> Parser Text -> Parser Text (Value -> Directive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text
forall i a. Parser i a -> Parser i a
try (Parser Text
ident Parser Text -> Parser Text () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser Text -> Parser Text Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '=' Parser Text -> Parser Text () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS) Parser Text (Value -> Directive)
-> Parser Text Value -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Value
value
  , Text -> [Directive] -> Directive
Group (Text -> [Directive] -> Directive)
-> Parser Text -> Parser Text ([Directive] -> Directive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text
forall i a. Parser i a -> Parser i a
try (Parser Text
ident Parser Text -> Parser Text () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser Text -> Parser Text Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '{' Parser Text -> Parser Text () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS)
          Parser Text ([Directive] -> Directive)
-> Parser [Directive] -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Directive]
directives Parser Directive -> Parser Text () -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser Directive -> Parser Text Char -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '}'
  ]

directives :: Parser [Directive]
directives :: Parser [Directive]
directives = (Parser Text ()
skipLWS Parser Text () -> Parser Directive -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Directive
directive Parser Directive -> Parser Text () -> Parser Directive
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipHWS) Parser Directive -> Parser Text Char -> Parser [Directive]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy`
             ((Char -> Bool) -> Parser Text Char
satisfy ((Char -> Bool) -> Parser Text Char)
-> (Char -> Bool) -> Parser Text Char
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n')

data Skip = Space | Comment

-- | Skip lines, comments, or horizontal white space.
skipLWS :: Parser ()
skipLWS :: Parser Text ()
skipLWS = Skip -> (Skip -> Char -> Maybe Skip) -> Parser Text
forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan Skip
Space Skip -> Char -> Maybe Skip
go Parser Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where go :: Skip -> Char -> Maybe Skip
go Space c :: Char
c | Char -> Bool
isSpace Char
c = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Space '#'           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment
        go Space _             = Maybe Skip
forall a. Maybe a
Nothing
        go Comment '\r'        = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Comment '\n'        = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Comment _           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment

-- | Skip comments or horizontal white space.
skipHWS :: Parser ()
skipHWS :: Parser Text ()
skipHWS = Skip -> (Skip -> Char -> Maybe Skip) -> Parser Text
forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan Skip
Space Skip -> Char -> Maybe Skip
go Parser Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where go :: Skip -> Char -> Maybe Skip
go Space ' '           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Space '\t'          = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Space '#'           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment
        go Space _             = Maybe Skip
forall a. Maybe a
Nothing
        go Comment '\r'        = Maybe Skip
forall a. Maybe a
Nothing
        go Comment '\n'        = Maybe Skip
forall a. Maybe a
Nothing
        go Comment _           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment

ident :: Parser Name
ident :: Parser Text
ident = do
  Text
n <- Char -> Text -> Text
T.cons (Char -> Text -> Text)
-> Parser Text Char -> Parser Text (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Char
satisfy Char -> Bool
isAlpha Parser Text (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
isCont
  Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "import") (Parser Text () -> Parser Text ())
-> Parser Text () -> Parser Text ()
forall a b. (a -> b) -> a -> b
$
    ConfigError -> Parser Text ()
forall a e. Exception e => e -> a
throw (FilePath -> FilePath -> ConfigError
ParseError "" (FilePath -> ConfigError) -> FilePath -> ConfigError
forall a b. (a -> b) -> a -> b
$ "reserved word (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ") used as identifier")
  Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
 where
  isCont :: Char -> Bool
isCont c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-'

value :: Parser Value
value :: Parser Text Value
value = [Parser Text Value] -> Parser Text Value
forall a. Monoid a => [a] -> a
mconcat [
          Text -> Parser Text
string "on" Parser Text -> Parser Text Value -> Parser Text Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
True)
        , Text -> Parser Text
string "off" Parser Text -> Parser Text Value -> Parser Text Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
False)
        , Text -> Parser Text
string "true" Parser Text -> Parser Text Value -> Parser Text Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
True)
        , Text -> Parser Text
string "false" Parser Text -> Parser Text Value -> Parser Text Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Text Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
False)
        , Text -> Value
String (Text -> Value) -> Parser Text -> Parser Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
string_
        , Rational -> Value
Number (Rational -> Value) -> Parser Text Rational -> Parser Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Rational
forall a. Fractional a => Parser a
rational
        , [Value] -> Value
List ([Value] -> Value) -> Parser Text [Value] -> Parser Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> Parser Text [Value] -> Parser Text [Value]
forall a. Char -> Char -> Parser a -> Parser a
brackets '[' ']'
                   ((Parser Text Value
value Parser Text Value -> Parser Text () -> Parser Text Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS) Parser Text Value -> Parser Text Char -> Parser Text [Value]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser Text Char
char ',' Parser Text Char -> Parser Text () -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS))
        ]

string_ :: Parser Text
string_ :: Parser Text
string_ = do
  Text
s <- Char -> Parser Text Char
char '"' Parser Text Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> (Bool -> Char -> Maybe Bool) -> Parser Text
forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan Bool
False Bool -> Char -> Maybe Bool
isChar Parser Text -> Parser Text Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '"'
  if "\\" Text -> Text -> Bool
`T.isInfixOf` Text
s
    then Text -> Parser Text
unescape Text
s
    else Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
 where
  isChar :: Bool -> Char -> Maybe Bool
isChar True _ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  isChar _ '"'  = Maybe Bool
forall a. Maybe a
Nothing
  isChar _ c :: Char
c    = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\')

brackets :: Char -> Char -> Parser a -> Parser a
brackets :: Char -> Char -> Parser a -> Parser a
brackets open :: Char
open close :: Char
close p :: Parser a
p = Char -> Parser Text Char
char Char
open Parser Text Char -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipLWS Parser Text () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser Text Char -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
close

embed :: Parser a -> Text -> Parser a
embed :: Parser a -> Text -> Parser a
embed p :: Parser a
p s :: Text
s = case Parser a -> Text -> Either FilePath a
forall a. Parser a -> Text -> Either FilePath a
parseOnly Parser a
p Text
s of
              Left err :: FilePath
err -> FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err
              Right v :: a
v  -> a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

unescape :: Text -> Parser Text
unescape :: Text -> Parser Text
unescape = (Builder -> Text) -> Parser Text Builder -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
L.toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText) (Parser Text Builder -> Parser Text)
-> (Text -> Parser Text Builder) -> Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text Builder -> Text -> Parser Text Builder
forall a. Parser a -> Text -> Parser a
embed (Builder -> Parser Text Builder
p Builder
forall a. Monoid a => a
mempty)
 where
  p :: Builder -> Parser Text Builder
p acc :: Builder
acc = do
    Text
h <- (Char -> Bool) -> Parser Text
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='\\')
    let rest :: Parser Text Builder
rest = do
          let cont :: Char -> Parser Text Builder
cont c :: Char
c = Builder -> Parser Text Builder
p (Builder
acc Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
h Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
singleton Char
c)
          Char
c <- Char -> Parser Text Char
char '\\' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Char
satisfy (FilePath -> Char -> Bool
inClass "ntru\"\\")
          case Char
c of
            'n'  -> Char -> Parser Text Builder
cont '\n'
            't'  -> Char -> Parser Text Builder
cont '\t'
            'r'  -> Char -> Parser Text Builder
cont '\r'
            '"'  -> Char -> Parser Text Builder
cont '"'
            '\\' -> Char -> Parser Text Builder
cont '\\'
            _    -> Char -> Parser Text Builder
cont (Char -> Parser Text Builder)
-> Parser Text Char -> Parser Text Builder
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Text Char
hexQuad
    Bool
done <- Parser Text Bool
forall t. Chunk t => Parser t Bool
atEnd
    if Bool
done
      then Builder -> Parser Text Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder
acc Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Text -> Builder
fromText Text
h)
      else Parser Text Builder
rest

hexQuad :: Parser Char
hexQuad :: Parser Text Char
hexQuad = do
  Int
a <- Parser Int -> Text -> Parser Int
forall a. Parser a -> Text -> Parser a
embed Parser Int
forall a. (Integral a, Bits a) => Parser a
hexadecimal (Text -> Parser Int) -> Parser Text -> Parser Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parser Text
A.take 4
  if Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0xd800 Bool -> Bool -> Bool
|| Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0xdfff
    then Char -> Parser Text Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
a)
    else do
      Int
b <- Parser Int -> Text -> Parser Int
forall a. Parser a -> Text -> Parser a
embed Parser Int
forall a. (Integral a, Bits a) => Parser a
hexadecimal (Text -> Parser Int) -> Parser Text -> Parser Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Parser Text
string "\\u" Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text
A.take 4
      if Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xdbff Bool -> Bool -> Bool
&& Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0xdc00 Bool -> Bool -> Bool
&& Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xdfff
        then Char -> Parser Text Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Parser Text Char) -> Char -> Parser Text Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (((Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- 0xd800) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 10) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- 0xdc00) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 0x10000)
        else FilePath -> Parser Text Char
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail "invalid UTF-16 surrogates"
                   
-- | 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 = [Interpolate] -> [Interpolate]
forall a. [a] -> [a]
reverse ([Interpolate] -> [Interpolate])
-> Parser [Interpolate] -> Parser [Interpolate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Interpolate] -> Parser [Interpolate]
p []
 where
  p :: [Interpolate] -> Parser [Interpolate]
p acc :: [Interpolate]
acc = do
    Interpolate
h <- Text -> Interpolate
Literal (Text -> Interpolate) -> Parser Text -> Parser Text Interpolate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='$')
    let rest :: Parser [Interpolate]
rest = do
          let cont :: Interpolate -> Parser [Interpolate]
cont x :: Interpolate
x = [Interpolate] -> Parser [Interpolate]
p (Interpolate
x Interpolate -> [Interpolate] -> [Interpolate]
forall a. a -> [a] -> [a]
: Interpolate
h Interpolate -> [Interpolate] -> [Interpolate]
forall a. a -> [a] -> [a]
: [Interpolate]
acc)
          Char
c <- Char -> Parser Text Char
char '$' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '$' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '(')
          case Char
c of
            '$' -> Interpolate -> Parser [Interpolate]
cont (Text -> Interpolate
Literal (Char -> Text
T.singleton '$'))
            _   -> (Interpolate -> Parser [Interpolate]
cont (Interpolate -> Parser [Interpolate])
-> (Text -> Interpolate) -> Text -> Parser [Interpolate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Interpolate
Interpolate) (Text -> Parser [Interpolate])
-> Parser Text -> Parser [Interpolate]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Text
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=')') Parser Text -> Parser Text Char -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char ')'
    Bool
done <- Parser Text Bool
forall t. Chunk t => Parser t Bool
atEnd
    if Bool
done
      then [Interpolate] -> Parser [Interpolate]
forall (m :: * -> *) a. Monad m => a -> m a
return (Interpolate
h Interpolate -> [Interpolate] -> [Interpolate]
forall a. a -> [a] -> [a]
: [Interpolate]
acc)
      else Parser [Interpolate]
rest