{-# 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 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 | Comment

-- | Skip lines, comments, or horizontal white 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

-- | Skip comments or horizontal white space.
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"
                   
-- | 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
<$> [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