{-# 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 a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser [Directive] -> Parser Text () -> Parser [Directive]
forall a b. Parser Text a -> Parser Text b -> Parser Text a
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 Text
"import" Parser Text -> Parser Text () -> Parser Text ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipLWS Parser Text () -> Parser Directive -> Parser Directive
forall a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser Text -> Parser Text Char -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
'=' Parser Text -> Parser Text () -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS) Parser Text (Value -> Directive)
-> Parser Value -> Parser Directive
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser 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 a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser Text -> Parser Text Char -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
'{' Parser Text -> Parser Text () -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS)
          Parser Text ([Directive] -> Directive)
-> Parser [Directive] -> Parser Directive
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Directive]
directives Parser Directive -> Parser Text () -> Parser Directive
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS Parser Directive -> Parser Text Char -> Parser Directive
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
'}'
  ]

directives :: Parser [Directive]
directives :: Parser [Directive]
directives = (Parser Text ()
skipLWS Parser Text () -> Parser Directive -> Parser Directive
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Directive
directive Parser Directive -> Parser Text () -> Parser Directive
forall a b. Parser Text a -> Parser Text b -> Parser Text a
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
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\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 a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser Text ()
forall a. a -> Parser Text a
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 = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Skip
Space Char
'#'           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment
        go Skip
Space Char
_             = Maybe Skip
forall a. Maybe a
Nothing
        go Skip
Comment Char
'\r'        = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Skip
Comment Char
'\n'        = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Skip
Comment Char
_           = 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 a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser Text ()
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where go :: Skip -> Char -> Maybe Skip
go Skip
Space Char
' '           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Skip
Space Char
'\t'          = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Space
        go Skip
Space Char
'#'           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment
        go Skip
Space Char
_             = Maybe Skip
forall a. Maybe a
Nothing
        go Skip
Comment Char
'\r'        = Maybe Skip
forall a. Maybe a
Nothing
        go Skip
Comment Char
'\n'        = Maybe Skip
forall a. Maybe a
Nothing
        go Skip
Comment Char
_           = Skip -> Maybe Skip
forall a. a -> Maybe a
Just Skip
Comment

ident :: Parser Name
ident :: Parser Text
ident = do
  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 a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
isCont
  when (n == "import") $
    throw (ParseError "" $ "reserved word (" ++ show n ++ ") used as identifier")
  return n
 where
  isCont :: Char -> Bool
isCont Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

value :: Parser Value
value :: Parser Value
value = [Parser Value] -> Parser Value
forall a. Monoid a => [a] -> a
mconcat [
          Text -> Parser Text
string Text
"on" Parser Text -> Parser Value -> Parser Value
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Value
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
True)
        , Text -> Parser Text
string Text
"off" Parser Text -> Parser Value -> Parser Value
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Value
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
False)
        , Text -> Parser Text
string Text
"true" Parser Text -> Parser Value -> Parser Value
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Value
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
True)
        , Text -> Parser Text
string Text
"false" Parser Text -> Parser Value -> Parser Value
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Parser Value
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
Bool Bool
False)
        , Text -> Value
String (Text -> Value) -> Parser Text -> Parser 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 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 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 Char
'[' Char
']'
                   ((Parser Value
value Parser Value -> Parser Text () -> Parser Value
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS) Parser 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 Char
',' Parser Text Char -> Parser Text () -> Parser Text Char
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipLWS))
        ]

string_ :: Parser Text
string_ :: Parser Text
string_ = do
  s <- Char -> Parser Text Char
char Char
'"' Parser Text Char -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
'"'
  if "\\" `T.isInfixOf` s
    then unescape s
    else return s
 where
  isChar :: Bool -> Char -> Maybe Bool
isChar Bool
True Char
_ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  isChar Bool
_ Char
'"'  = Maybe Bool
forall a. Maybe a
Nothing
  isChar Bool
_ Char
c    = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Char
c Char -> Char -> Bool
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 Text Char
char Char
open Parser Text Char -> Parser Text () -> Parser Text ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipLWS Parser Text () -> Parser a -> Parser a
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser Text Char -> Parser a
forall a b. Parser Text a -> Parser Text b -> Parser Text 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 :: forall a. Parser a -> Text -> Parser a
embed Parser a
p Text
s = case Parser a -> Text -> Either [Char] a
forall a. Parser a -> Text -> Either [Char] a
parseOnly Parser a
p Text
s of
              Left [Char]
err -> [Char] -> Parser a
forall a. [Char] -> Parser Text a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
              Right a
v  -> a -> Parser a
forall a. a -> Parser Text 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 a b. (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LazyText -> Text
L.toStrict (LazyText -> Text) -> (Builder -> LazyText) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
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 Builder
acc = do
    h <- (Char -> Bool) -> Parser Text
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\\')
    let rest = do
          let cont :: Char -> Parser Text Builder
cont 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)
          c <- Char -> Parser Text Char
char Char
'\\' Parser Text Char -> Parser Text Char -> Parser Text Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Char
satisfy ([Char] -> Char -> Bool
inClass [Char]
"ntru\"\\")
          case 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 (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
    done <- atEnd
    if done
      then return (acc `mappend` fromText h)
      else rest

hexQuad :: Parser Char
hexQuad :: Parser Text Char
hexQuad = do
  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 Int
4
  if a < 0xd800 || a > 0xdfff
    then return (chr a)
    else do
      b <- embed hexadecimal =<< string "\\u" *> A.take 4
      if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
        then return $! chr (((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000)
        else 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 [Interpolate]
acc = do
    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
/=Char
'$')
    let rest = do
          let cont :: Interpolate -> Parser [Interpolate]
cont 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)
          c <- Char -> Parser Text Char
char Char
'$' Parser Text Char -> Parser Text Char -> Parser Text Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(')
          case c of
            Char
'$' -> Interpolate -> Parser [Interpolate]
cont (Text -> Interpolate
Literal (Char -> Text
T.singleton Char
'$'))
            Char
_   -> (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
/=Char
')') Parser Text -> Parser Text Char -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
')'
    done <- atEnd
    if done
      then return (h : acc)
      else rest