{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.Mustache.Parser
-- Copyright   :  © 2016–present Stack Builders
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Megaparsec parser for Mustache templates. You don't usually need to
-- import the module, because "Text.Mustache" re-exports everything you may
-- need, import that module instead.
module Text.Mustache.Parser
  ( parseMustache,
  )
where

import Control.Monad
import Control.Monad.State.Strict
import Data.Char (isSpace)
import Data.Maybe (catMaybes)
import Data.Text (Text, stripEnd)
import qualified Data.Text as T
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Mustache.Type

----------------------------------------------------------------------------
-- Parser

-- | Parse a given Mustache template.
parseMustache ::
  -- | Location of the file to parse
  FilePath ->
  -- | File contents (Mustache template)
  Text ->
  -- | Parsed nodes or parse error
  Either (ParseErrorBundle Text Void) [Node]
parseMustache :: String -> Text -> Either (ParseErrorBundle Text Void) [Node]
parseMustache =
  forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Parser () -> Parser [Node]
pMustache forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) (Text -> Text -> Int -> St
St Text
"{{" Text
"}}" Int
0)

pMustache :: Parser () -> Parser [Node]
pMustache :: Parser () -> Parser [Node]
pMustache = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [StateT St (Parsec Void Text) (Maybe Node)]
alts)
  where
    alts :: [StateT St (Parsec Void Text) (Maybe Node)]
alts =
      [ forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Parser a -> Parser a
withStandalone Parser ()
pComment,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> (Key -> [Node] -> Node) -> Parser Node
pSection Text
"#" Key -> [Node] -> Node
Section,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> (Key -> [Node] -> Node) -> Parser Node
pSection Text
"^" Key -> [Node] -> Node
InvertedSection,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
pStandalone ((Pos -> Maybe Pos) -> Parser Node
pPartial forall a. a -> Maybe a
Just),
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pos -> Maybe Pos) -> Parser Node
pPartial (forall a b. a -> b -> a
const forall a. Maybe a
Nothing),
        forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Parser a -> Parser a
withStandalone Parser ()
pSetDelimiters,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Node
pUnescapedVariable,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Node
pUnescapedSpecial,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Node
pEscapedVariable,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Node
pTextBlock,
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Node
pEmptyLnTextBlock
      ]
{-# INLINE pMustache #-}

pEmptyLnTextBlock :: Parser Node
pEmptyLnTextBlock :: Parser Node
pEmptyLnTextBlock = Text -> Node
TextBlock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
eol'
{-# INLINE pEmptyLnTextBlock #-}

pTextBlock :: Parser Node
pTextBlock :: Parser Node
pTextBlock = do
  Text
start <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
openingDel
  Text
txt <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
T.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ do
    (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string) Text
start
    let textChar :: Char -> Bool
textChar Char
x = Char
x forall a. Eq a => a -> a -> Bool
/= Text -> Char
T.head Text
start Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\n'
    forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Int -> Text -> Text
T.take Int
1 Text
start) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"text char") Char -> Bool
textChar
  Maybe Text
meol <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
eol'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
meol of
    Maybe Text
Nothing -> Text -> Node
TextBlock Text
txt
    Just Text
txt' -> Text -> Node
TextBlock (Text
txt forall a. Semigroup a => a -> a -> a
<> Text
txt')
{-# INLINE pTextBlock #-}

pUnescapedVariable :: Parser Node
pUnescapedVariable :: Parser Node
pUnescapedVariable = Key -> Node
UnescapedVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Key
pTag Text
"&"
{-# INLINE pUnescapedVariable #-}

pUnescapedSpecial :: Parser Node
pUnescapedSpecial :: Parser Node
pUnescapedSpecial = do
  Text
start <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
openingDel
  Text
end <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
closingDel
  forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol forall a b. (a -> b) -> a -> b
$ Text
start forall a. Semigroup a => a -> a -> a
<> Text
"{") (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string forall a b. (a -> b) -> a -> b
$ Text
"}" forall a. Semigroup a => a -> a -> a
<> Text
end) forall a b. (a -> b) -> a -> b
$
    Key -> Node
UnescapedVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Key
pKey
{-# INLINE pUnescapedSpecial #-}

pSection :: Text -> (Key -> [Node] -> Node) -> Parser Node
pSection :: Text -> (Key -> [Node] -> Node) -> Parser Node
pSection Text
suffix Key -> [Node] -> Node
f = do
  Key
key <- forall a. Parser a -> Parser a
withStandalone (Text -> Parser Key
pTag Text
suffix)
  [Node]
nodes <- (Parser () -> Parser [Node]
pMustache forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Parser a
withStandalone forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Parser ()
pClosingTag) Key
key
  forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> [Node] -> Node
f Key
key [Node]
nodes)
{-# INLINE pSection #-}

pPartial :: (Pos -> Maybe Pos) -> Parser Node
pPartial :: (Pos -> Maybe Pos) -> Parser Node
pPartial Pos -> Maybe Pos
f = do
  Maybe Pos
pos <- Pos -> Maybe Pos
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m Pos
L.indentLevel
  Key
key <- Text -> Parser Key
pTag Text
">"
  let pname :: PName
pname = Text -> PName
PName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate (String -> Text
T.pack String
".") (Key -> [Text]
unKey Key
key)
  forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Maybe Pos -> Node
Partial PName
pname Maybe Pos
pos)
{-# INLINE pPartial #-}

pComment :: Parser ()
pComment :: Parser ()
pComment = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
  Text
start <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
openingDel
  Text
end <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
closingDel
  (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
symbol) (Text
start forall a. Semigroup a => a -> a -> a
<> Text
"!")
  forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"character") (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
end)
{-# INLINE pComment #-}

pSetDelimiters :: Parser ()
pSetDelimiters :: Parser ()
pSetDelimiters = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
  Text
start <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
openingDel
  Text
end <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
closingDel
  (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
symbol) (Text
start forall a. Semigroup a => a -> a -> a
<> Text
"=")
  Text
start' <- Parser Text
pDelimiter forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
  Text
end' <- Parser Text
pDelimiter forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
  (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string) (Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
end)
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \St
st ->
    St
st
      { openingDel :: Text
openingDel = Text
start',
        closingDel :: Text
closingDel = Text
end'
      }
{-# INLINE pSetDelimiters #-}

pEscapedVariable :: Parser Node
pEscapedVariable :: Parser Node
pEscapedVariable = Key -> Node
EscapedVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Key
pTag Text
""
{-# INLINE pEscapedVariable #-}

withStandalone :: Parser a -> Parser a
withStandalone :: forall a. Parser a -> Parser a
withStandalone Parser a
p = forall a. Parser a -> Parser a
pStandalone Parser a
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a
p
{-# INLINE withStandalone #-}

pStandalone :: Parser a -> Parser a
pStandalone :: forall a. Parser a -> Parser a
pStandalone Parser a
p = Parser ()
pBol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between Parser ()
sc (Parser ()
sc forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Text
eol' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)) Parser a
p)
{-# INLINE pStandalone #-}

pTag :: Text -> Parser Key
pTag :: Text -> Parser Key
pTag Text
suffix = do
  Text
start <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
openingDel
  Text
end <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
closingDel
  forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol forall a b. (a -> b) -> a -> b
$ Text
start forall a. Semigroup a => a -> a -> a
<> Text
suffix) (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
end) Parser Key
pKey
{-# INLINE pTag #-}

pClosingTag :: Key -> Parser ()
pClosingTag :: Key -> Parser ()
pClosingTag Key
key = do
  Text
start <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
openingDel
  Text
end <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
closingDel
  let str :: Text
str = Key -> Text
keyToText Key
key
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol forall a b. (a -> b) -> a -> b
$ Text
start forall a. Semigroup a => a -> a -> a
<> Text
"/") (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
end) (Text -> Parser Text
symbol Text
str)
{-# INLINE pClosingTag #-}

pKey :: Parser Key
pKey :: Parser Key
pKey = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Key
Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"key") (forall {a}. StateT St (Parsec Void Text) [a]
implicit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT St (Parsec Void Text) [Text]
other)
  where
    implicit :: StateT St (Parsec Void Text) [a]
implicit = [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.'
    other :: StateT St (Parsec Void Text) [Text]
other = do
      Text
end <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Text
closingDel
      let f :: Char -> Bool
f Char
x = Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Char
'.' forall a. a -> [a] -> [a]
: Char
'}' forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
end)
          lbl :: String
lbl = String
"key-constituent characters"
      [Text] -> [Text]
stripLast forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
sepBy1 (forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
lbl) Char -> Bool
f) (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.')
    stripLast :: [Text] -> [Text]
stripLast [] = []
    stripLast [Text
x] = [Text -> Text
stripEnd Text
x]
    stripLast (Text
x0 : Text
x1 : [Text]
xs) = Text
x0 forall a. a -> [a] -> [a]
: [Text] -> [Text]
stripLast (Text
x1 forall a. a -> [a] -> [a]
: [Text]
xs)
{-# INLINE pKey #-}

pDelimiter :: Parser Text
pDelimiter :: Parser Text
pDelimiter = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"delimiter char") Char -> Bool
delChar forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"delimiter"
  where
    delChar :: Char -> Bool
delChar Char
x = Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'='
{-# INLINE pDelimiter #-}

pBol :: Parser ()
pBol :: Parser ()
pBol = do
  Int
o <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  Int
o' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Int
newlineOffset
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
o forall a. Eq a => a -> a -> Bool
== Int
o') forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE pBol #-}

----------------------------------------------------------------------------
-- Auxiliary types

-- | Type of Mustache parser monad stack.
type Parser = StateT St (Parsec Void Text)

-- | State used in the parser.
data St = St
  { -- | Opening delimiter
    St -> Text
openingDel :: Text,
    -- | Closing delimiter
    St -> Text
closingDel :: Text,
    -- | The offset at which last newline character was parsed
    St -> Int
newlineOffset :: !Int
  }

----------------------------------------------------------------------------
-- Lexer helpers and other

scn :: Parser ()
scn :: Parser ()
scn = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 forall (f :: * -> *) a. Alternative f => f a
empty forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE scn #-}

sc :: Parser ()
sc :: Parser ()
sc = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing Char -> Bool
f) forall (f :: * -> *) a. Alternative f => f a
empty forall (f :: * -> *) a. Alternative f => f a
empty
  where
    f :: Char -> Bool
f Char
x = Char
x forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\t'
{-# INLINE sc #-}

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
scn
{-# INLINE lexeme #-}

symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
scn
{-# INLINE symbol #-}

keyToText :: Key -> Text
keyToText :: Key -> Text
keyToText (Key []) = Text
"."
keyToText (Key [Text]
ks) = Text -> [Text] -> Text
T.intercalate Text
"." [Text]
ks
{-# INLINE keyToText #-}

eol' :: Parser Text
eol' :: Parser Text
eol' = do
  Text
x <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
  Int
o <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\St
st -> St
st {newlineOffset :: Int
newlineOffset = Int
o})
  forall (m :: * -> *) a. Monad m => a -> m a
return Text
x
{-# INLINE eol' #-}