Parser.hs

{-|
Module      : $Header$
Description : Basic functions for dealing with mustache templates.
Copyright   : (c) Justus Adam, 2015
License     : BSD3
Maintainer  : dev@justus.science
Stability   : experimental
Portability : POSIX
-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
module Text.Mustache.Parser
  (
    -- * Generic parsing functions
    parse
  , parseWithConf
    -- * Configurations
  , MustacheConf (..)
  , defaultConf
    -- * Parser
  , Parser
  , MustacheState
    -- * Mustache Constants
  , sectionBegin
  , sectionEnd
  , invertedSectionBegin
  , unescape2
  , unescape1
  , delimiterChange
  , nestingSeparator
  ) where


import           Control.Monad ( void, when )
import           Data.Char ( isAlphaNum, isSpace )
import           Data.List ( nub )
#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid ( (<>) )
#endif
import           Data.Text ( Text )
import qualified Data.Text as T
import           Text.Mustache.Types ( DataIdentifier (..), Node (..), STree )
import           Text.Parsec
                   ( Parsec, ParseError, (<|>), anyChar, char, choice, eof
                   , getState, lookAhead, many, manyTill, modifyState, noneOf
                   , optionMaybe, oneOf, parserFail, putState, runParser
                   , satisfy, skipMany, space, spaces, string, try
                   )


-- | Initial configuration for the parser
newtype MustacheConf = MustacheConf
  { delimiters :: (String, String)
  }


-- | User state for the parser
data MustacheState = MustacheState
  { sDelimiters        :: (String, String)
  , textStack          :: Text
  , isBeginngingOfLine :: Bool
  , currentSectionName :: Maybe DataIdentifier
  }


data ParseTagRes
  = SectionBegin Bool DataIdentifier
  | SectionEnd DataIdentifier
  | Tag (Node Text)
  | HandledTag


-- | @#@
sectionBegin :: Char
sectionBegin = '#'


-- | @/@
sectionEnd :: Char
sectionEnd = '/'


-- | @>@
partialBegin :: Char
partialBegin = '>'


-- | @^@
invertedSectionBegin :: Char
invertedSectionBegin = '^'


-- | @{@ and @}@
unescape2 :: (Char, Char)
unescape2 = ('{', '}')


-- | @&@
unescape1 :: Char
unescape1 = '&'


-- | @=@
delimiterChange :: Char
delimiterChange = '='


-- | @.@
nestingSeparator :: Char
nestingSeparator = '.'


-- | @!@
comment :: Char
comment = '!'


-- | @.@
implicitIterator :: Char
implicitIterator = '.'


-- | Cannot be a letter, number or the nesting separation Character @.@
isAllowedDelimiterCharacter :: Char -> Bool
isAllowedDelimiterCharacter =
  not . or . sequence
    [ isSpace, isAlphaNum, (== nestingSeparator) ]


allowedDelimiterCharacter :: Parser Char
allowedDelimiterCharacter =
  satisfy isAllowedDelimiterCharacter


-- | Empty configuration
emptyState :: MustacheState
emptyState = MustacheState ("", "") mempty True Nothing


-- | Default configuration (delimiters = ("{{", "}}"))
defaultConf :: MustacheConf
defaultConf = MustacheConf ("{{", "}}")


initState :: MustacheConf -> MustacheState
initState (MustacheConf { delimiters }) = emptyState { sDelimiters = delimiters }


setIsBeginning :: Bool -> Parser ()
setIsBeginning b = modifyState (\s -> s { isBeginngingOfLine = b })


-- | The parser monad in use
type Parser = Parsec Text MustacheState


(<<) :: Monad m => m b -> m a -> m b
(<<) = flip (>>)


endOfLine :: Parser String
endOfLine = do
  r <- optionMaybe $ char '\r'
  n <- char '\n'
  pure $ maybe id (:) r [n]


{-|
  Runs the parser for a mustache template, returning the syntax tree.
-}
parse :: FilePath -> Text -> Either ParseError STree
parse = parseWithConf defaultConf


-- | Parse using a custom initial configuration
parseWithConf :: MustacheConf -> FilePath -> Text -> Either ParseError STree
parseWithConf = runParser parseText . initState


parseText :: Parser STree
parseText = do
  (MustacheState { isBeginngingOfLine }) <- getState
  if isBeginngingOfLine
    then parseLine
    else continueLine


appendStringStack :: String -> Parser ()
appendStringStack t = modifyState (\s -> s { textStack = textStack s <> T.pack t})


continueLine :: Parser STree
continueLine = do
  (MustacheState { sDelimiters = ( start@(x:_), _ )}) <- getState
  let forbidden = x : "\n\r"

  many (noneOf forbidden) >>= appendStringStack

  (try endOfLine >>= appendStringStack >> setIsBeginning True >> parseLine)
    <|> (try (string start) >> switchOnTag >>= continueFromTag)
    <|> (try eof >> finishFile)
    <|> (anyChar >>= appendStringStack . (:[]) >> continueLine)


flushText :: Parser STree
flushText = do
  s@(MustacheState { textStack = text }) <- getState
  putState $ s { textStack = mempty }
  pure [TextBlock text | not (T.null text)]


finishFile :: Parser STree
finishFile =
  getState >>= \case
    (MustacheState {currentSectionName = Nothing}) -> flushText
    (MustacheState {currentSectionName = Just name}) ->
      parserFail $ "Unclosed section " <> show name


parseLine :: Parser STree
parseLine = do
  (MustacheState { sDelimiters = ( start, _ ) }) <- getState
  initialWhitespace <- many (oneOf " \t")
  let handleStandalone = do
        tag <- switchOnTag
        let continueNoStandalone = do
              appendStringStack initialWhitespace
              setIsBeginning False
              continueFromTag tag
            standaloneEnding = do
              try (skipMany (oneOf " \t") >> (eof <|> void endOfLine))
              setIsBeginning True
        case tag of
          Tag (Partial _ name) ->
            ( standaloneEnding >>
              continueFromTag (Tag (Partial (Just (T.pack initialWhitespace)) name))
            ) <|> continueNoStandalone
          Tag _ -> continueNoStandalone
          _     ->
            ( standaloneEnding >>
              continueFromTag tag
            ) <|> continueNoStandalone
  (try (string start) >> handleStandalone)
    <|> (try eof >> appendStringStack initialWhitespace >> finishFile)
    <|> (appendStringStack initialWhitespace >> setIsBeginning False >> continueLine)


continueFromTag :: ParseTagRes -> Parser STree
continueFromTag (SectionBegin inverted name) = do
  textNodes <- flushText
  state@(MustacheState
    { currentSectionName = previousSection }) <- getState
  putState $ state { currentSectionName = pure name }
  innerSectionContent <- parseText
  let sectionTag =
        if inverted
          then InvertedSection
          else Section
  modifyState $ \s -> s { currentSectionName = previousSection }
  outerSectionContent <- parseText
  pure (textNodes <> [sectionTag name innerSectionContent] <> outerSectionContent)
continueFromTag (SectionEnd name) = do
  (MustacheState
    { currentSectionName }) <- getState
  case currentSectionName of
    Just name' | name' == name -> flushText
    Just name' -> parserFail $
         "Expected closing sequence for \""
      <> show name
      <> "\" got \""
      <> show name'
      <> "\"."
    Nothing -> parserFail $
         "Encountered closing sequence for \""
      <> show name
      <> "\" which has never been opened."
continueFromTag (Tag tag) = do
  textNodes    <- flushText
  furtherNodes <- parseText
  pure $ textNodes <> pure tag <> furtherNodes
continueFromTag HandledTag = parseText


switchOnTag :: Parser ParseTagRes
switchOnTag = do
  (MustacheState { sDelimiters = ( _, end )}) <- getState

  choice
    [ SectionBegin False <$> (try (char sectionBegin) >> genParseTagEnd mempty)
    , SectionEnd
        <$> (try (char sectionEnd) >> genParseTagEnd mempty)
    , Tag . Variable False
        <$> (try (char unescape1) >> genParseTagEnd mempty)
    , Tag . Variable False
        <$> (try (char (fst unescape2)) >> genParseTagEnd (pure $ snd unescape2))
    , Tag . Partial Nothing
        <$> (  try (char partialBegin)
            >> spaces
            >> (noneOf (nub end) `manyTill` try (spaces >> string end))
            )
    , pure HandledTag
        << (try (char delimiterChange) >> parseDelimChange)
    , SectionBegin True
        <$> (try (char invertedSectionBegin) >> genParseTagEnd mempty >>= \case
              n@(NamedData _) -> pure n
              _ -> parserFail "Inverted Sections can not be implicit."
            )
    , pure HandledTag << (try (char comment) >> manyTill anyChar (try $ string end))
    , Tag . Variable True
        <$> genParseTagEnd mempty
    ]
  where
    parseDelimChange = do
      (MustacheState { sDelimiters = ( _, end )}) <- getState
      spaces
      delim1 <- allowedDelimiterCharacter `manyTill` space
      spaces
      delim2 <- allowedDelimiterCharacter `manyTill` try (spaces >> string (delimiterChange : end))
      when (delim1 == mempty || delim2 == mempty)
        $ parserFail "Tags must contain more than 0 characters"
      oldState <- getState
      putState $ oldState { sDelimiters = (delim1, delim2) }


genParseTagEnd :: String -> Parser DataIdentifier
genParseTagEnd emod = do
  (MustacheState { sDelimiters = ( start, end ) }) <- getState

  let nEnd = emod <> end
      disallowed = nub $ nestingSeparator : start <> end

      parseOne :: Parser [Text]
      parseOne = do

        one <- noneOf disallowed
          `manyTill` lookAhead
            (try (spaces >> void (string nEnd))
            <|> try (void $ char nestingSeparator))

        others <- (char nestingSeparator >> parseOne)
                  <|> (mempty <$ (spaces >> string nEnd))
        pure $ T.pack one : others
  spaces
  (try (char implicitIterator) >> spaces >> string nEnd >> pure Implicit)
    <|> (NamedData <$> parseOne)