Pass through raw text in parser

src/Text/Mustache/Parser.hs

@@ -39,10 +39,12 @@ import           Control.Monad
 import           Data.Char           (isAlphaNum, isSpace)
 import           Data.List           (nub)
 import           Data.Monoid         ((<>))
+import           Data.Semigroup      as Sem
+import           Data.String         (IsString(..))
 import           Data.Text           as T (Text, null, pack)
 import           Prelude             as Prel
 import           Text.Mustache.Types
-import           Text.Parsec         as P hiding (endOfLine, parse)
+import           Text.Parsec         as P hiding (endOfLine, manyTill, parse, spaces)
 
 
 -- | Initial configuration for the parser
@@ -60,6 +62,10 @@ data MustacheState = MustacheState
   }
 
 
+-- | Contains ParseTagRes and the raw text parsed.
+type WithRawText a = (a, Text)
+
+
 data ParseTagRes
   = SectionBegin Bool DataIdentifier
   | SectionEnd DataIdentifier
@@ -106,6 +112,24 @@ allowedDelimiterCharacter :: Parser Char
 allowedDelimiterCharacter =
   satisfy isAllowedDelimiterCharacter
 
+{- Versions of Parsec functions parsing raw text -}
+char' :: IsString s => Char -> Parser s
+char' = fmap (fromString . pure) . char
+spaces :: IsString s => Parser s
+spaces = fromString <$> many space
+manyTill :: (Sem.Semigroup s, IsString s) => Parser Char -> Parser s -> Parser (s, s)
+manyTill p pEnd = choice
+  [ try $ do
+      res <- fromString . pure <$> p
+      end <- pEnd
+      return (res, res <> end)
+  , try $ do
+      res <- fromString . pure <$> p
+      (next, nextRaw) <- manyTill p pEnd
+      return (res <> next, res <> nextRaw)
+  , return ("", "")
+  ]
+
 
 -- | Empty configuration
 emptyState :: MustacheState
@@ -129,10 +153,6 @@ setIsBeginning b = modifyState (\s -> s { isBeginngingOfLine = b })
 type Parser = Parsec Text MustacheState
 
 
-(<<) :: Monad m => m b -> m a -> m b
-(<<) = flip (>>)
-
-
 endOfLine :: Parser String
 endOfLine = do
   r <- optionMaybe $ char '\r'
@@ -171,10 +191,15 @@ continueLine = do
 
   many (noneOf forbidden) >>= appendStringStack
 
-  (try endOfLine >>= appendStringStack >> setIsBeginning True >> parseLine)
-    <|> (try (string start) >> switchOnTag >>= continueFromTag)
-    <|> (try eof >> finishFile)
-    <|> (anyChar >>= appendStringStack . (:[]) >> continueLine)
+  choice
+    [ try $ endOfLine >>= appendStringStack >> setIsBeginning True >> parseLine
+    , try $ do
+        s1 <- string start
+        (tag, tagRaw) <- switchOnTag
+        continueFromTag (tag, pack s1 <> tagRaw)
+    , try $ eof >> finishFile
+    , anyChar >>= appendStringStack . (:[]) >> continueLine
+    ]
 
 
 flushText :: Parser STree
@@ -198,32 +223,34 @@ parseLine :: Parser STree
 parseLine = do
   (MustacheState { sDelimiters = ( start, _ ) }) <- getState
   initialWhitespace <- many (oneOf " \t")
-  let handleStandalone = do
-        tag <- switchOnTag
+  let handleStandalone startRaw = do
+        (tag, tagRaw') <- switchOnTag
+        let tagRaw = pack startRaw <> tagRaw'
         let continueNoStandalone = do
               appendStringStack initialWhitespace
               setIsBeginning False
-              continueFromTag tag
+              continueFromTag (tag, tagRaw)
             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))
+              continueFromTag (Tag (Partial (Just (pack initialWhitespace)) name), tagRaw)
             ) <|> continueNoStandalone
           Tag _ -> continueNoStandalone
           _     ->
             ( standaloneEnding >>
-              continueFromTag tag
+              continueFromTag (tag, tagRaw)
             ) <|> continueNoStandalone
-  (try (string start) >> handleStandalone)
+
+  (try (string start) >>= handleStandalone)
     <|> (try eof >> appendStringStack initialWhitespace >> finishFile)
     <|> (appendStringStack initialWhitespace >> setIsBeginning False >> continueLine)
 
 
-continueFromTag :: ParseTagRes -> Parser STree
-continueFromTag (SectionBegin inverted name) = do
+continueFromTag :: WithRawText ParseTagRes -> Parser STree
+continueFromTag (SectionBegin inverted name, _) = do
   textNodes <- flushText
   state@(MustacheState
     { currentSectionName = previousSection }) <- getState
@@ -233,80 +260,121 @@ continueFromTag (SectionBegin inverted name) = do
         if inverted
           then InvertedSection
           else Section
-      innerSection = ASTree [sectionTag name innerSectionContent] ("" {- TODO -})
+      innerSection = ASTree [sectionTag name innerSectionContent] (rawText innerSectionContent)
   modifyState $ \s -> s { currentSectionName = previousSection }
   outerSectionContent <- parseText
   return (textNodes <> innerSection <> outerSectionContent)
-continueFromTag (SectionEnd name) = do
+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
+continueFromTag (Tag tag, tagRawText) = do
   textNodes    <- flushText
   furtherNodes <- parseText
-  return $ textNodes <> ASTree [tag] ("" {- TODO -}) <> furtherNodes
-continueFromTag HandledTag = parseText
+  return $ textNodes <> ASTree [tag] tagRawText <> furtherNodes
+continueFromTag (HandledTag, _) = parseText
 
 
-switchOnTag :: Parser ParseTagRes
+switchOnTag :: Parser (WithRawText 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
+    [ try $ do
+        s1 <- char' sectionBegin
+        (dataId, dataIdRaw) <- genParseTagEnd mempty
+        return (SectionBegin False dataId, s1 <> dataIdRaw)
+    , try $ do
+        s1 <- char' sectionEnd
+        (dataId, dataIdRaw) <- genParseTagEnd mempty
+        return (SectionEnd dataId, s1 <> dataIdRaw)
+    , try $ do
+        s1 <- char' unescape1
+        (dataId, dataIdRaw) <- genParseTagEnd mempty
+        return (Tag $ Variable False dataId, s1 <> dataIdRaw)
+    , try $ do
+        s1 <- char' $ fst unescape2
+        (dataId, dataIdRaw) <- genParseTagEnd $ return $ snd unescape2
+        return (Tag $ Variable False dataId, s1 <> dataIdRaw)
+    , try $ do
+        s1 <- char' partialBegin
+        s2 <- spaces
+        (ref, refRaw) <- noneOf (nub end) `manyTill` try (spaces <> string end)
+        return (Tag $ Partial Nothing ref, s1 <> s2 <> pack refRaw)
+    , try $ do
+        s1 <- char' delimiterChange
+        delimChangeRaw <- parseDelimChange
+        return (HandledTag, s1 <> delimChangeRaw)
+    , try $ do
+        s1 <- char' invertedSectionBegin
+        (dataId, dataIdRaw) <- genParseTagEnd mempty
+        case dataId of
+          NamedData _ -> return (SectionBegin True dataId, s1 <> dataIdRaw)
+          _ -> parserFail "Inverted Sections can not be implicit."
+    , try $ do
+        s1 <- char' comment
+        (_, s2) <- anyChar `manyTill` try (string end)
+        return (HandledTag, pack $ s1 <> s2)
+    , do
+        (dataId, dataIdRaw) <- genParseTagEnd mempty
+        return (Tag $ Variable True dataId, dataIdRaw)
     ]
   where
     parseDelimChange = do
       (MustacheState { sDelimiters = ( _, end )}) <- getState
-      spaces
-      delim1 <- allowedDelimiterCharacter `manyTill` space
-      spaces
-      delim2 <- allowedDelimiterCharacter `manyTill` try (spaces >> string (delimiterChange : end))
+      s1 <- spaces
+      (delim1, delim1Raw) <- allowedDelimiterCharacter `manyTill` (pure <$> space)
+      s2 <- spaces
+      (delim2, delim2Raw) <- 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) }
+      return $ pack $ s1 <> delim1Raw <> s2 <> delim2Raw
 
 
-genParseTagEnd :: String -> Parser DataIdentifier
+genParseTagEnd :: String -> Parser (WithRawText DataIdentifier)
 genParseTagEnd emod = do
   (MustacheState { sDelimiters = ( start, end ) }) <- getState
 
   let nEnd = emod <> end
       disallowed = nub $ nestingSeparator : start <> end
 
-      parseOne :: Parser [Text]
+      parseOne :: Parser (WithRawText [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)
+        (one, oneRaw) <- noneOf disallowed `manyTill` (do
+            void $ lookAhead $
+              choice
+              [ try $ spaces <> string nEnd
+              , try $ char' nestingSeparator
+              ]
+            return mempty
+          )
+
+        (others, othersRaw) <- choice
+          [ try $ do
+              s1 <- char' nestingSeparator
+              (next, nextRaw) <- parseOne
+              return (next, s1 <> nextRaw)
+          , do
+              s1 <- spaces
+              s2 <- string nEnd
+              return ([], pack $ s1 <> s2)
+          ]
+
+        return (pack one : others, pack oneRaw <> othersRaw)
+
+  s1 <- spaces
+  choice
+    [ try $ do
+        s2 <- char' implicitIterator
+        s3 <- spaces
+        s4 <- string nEnd
+        return (Implicit, pack $ s1 <> s2 <> s3 <> s4)
+    , do
+        (name, nameRaw) <- parseOne
+        return (NamedData name, pack s1 <> nameRaw)
+    ]