diff options
Diffstat (limited to 'mustache/src/Text/Mustache/Parser.hs')
| -rw-r--r-- | mustache/src/Text/Mustache/Parser.hs | 311 |
1 files changed, 311 insertions, 0 deletions
diff --git a/mustache/src/Text/Mustache/Parser.hs b/mustache/src/Text/Mustache/Parser.hs new file mode 100644 index 0000000..317e7aa --- /dev/null +++ b/mustache/src/Text/Mustache/Parser.hs @@ -0,0 +1,311 @@ +{-| +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 FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +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 +import Data.Char (isAlphaNum, isSpace) +import Data.List (nub) +import Data.Monoid ((<>)) +import Data.Text as T (Text, null, pack) +import Prelude as Prel +import Text.Mustache.Types +import Text.Parsec as P hiding (endOfLine, parse) + + +-- | Initial configuration for the parser +data 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 . Prel.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' + return $ 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 = P.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 <> 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 } + return $ if T.null text + then [] + else [TextBlock 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 (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 = return name } + innerSectionContent <- parseText + let sectionTag = + if inverted + then InvertedSection + else Section + modifyState $ \s -> s { currentSectionName = previousSection } + outerSectionContent <- parseText + return (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 + return $ textNodes <> return 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 (return $ snd unescape2)) + , Tag . Partial Nothing + <$> (try (char partialBegin) >> spaces >> (noneOf (nub end) `manyTill` try (spaces >> string end))) + , return HandledTag + << (try (char delimiterChange) >> parseDelimChange) + , SectionBegin True + <$> (try (char invertedSectionBegin) >> genParseTagEnd mempty >>= \case + n@(NamedData _) -> return n + _ -> parserFail "Inverted Sections can not be implicit." + ) + , return 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) + <|> (const mempty <$> (spaces >> string nEnd)) + return $ pack one : others + spaces + (try (char implicitIterator) >> spaces >> string nEnd >> return Implicit) + <|> (NamedData <$> parseOne) |