Generalised more in Parsing.hs to enable the use of custom state

1 files changed, 53 insertions, 40 deletions

diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs
index eec4a3bc9..66ebca253 100644
--- a/src/Text/Pandoc/Parsing.hs
+++ b/src/Text/Pandoc/Parsing.hs
@@ -2,6 +2,7 @@
   FlexibleContexts
 , GeneralizedNewtypeDeriving
 , TypeSynonymInstances
+, MultiParamTypeClasses
 , FlexibleInstances #-}
 {-
 Copyright (C) 2006-2014 John MacFarlane <jgm@berkeley.edu>
@@ -80,6 +81,7 @@ module Text.Pandoc.Parsing ( anyLine,
                              HeaderType (..),
                              ParserContext (..),
                              QuoteContext (..),
+                             HasQuoteContext (..),
                              NoteTable,
                              NoteTable',
                              KeyTable,
@@ -88,7 +90,6 @@ module Text.Pandoc.Parsing ( anyLine,
                              toKey,
                              registerHeader,
                              smartPunctuation,
-                             withQuoteContext,
                              singleQuoteStart,
                              singleQuoteEnd,
                              doubleQuoteStart,
@@ -106,6 +107,7 @@ module Text.Pandoc.Parsing ( anyLine,
                              runF,
                              askF,
                              asksF,
+                             token,
                              -- * Re-exports from Text.Pandoc.Parsec
                              Stream,
                              runParser,
@@ -160,7 +162,6 @@ module Text.Pandoc.Parsing ( anyLine,
                              setSourceColumn,
                              setSourceLine,
                              newPos,
-                             token
                              )
 where
 
@@ -170,7 +171,7 @@ import Text.Pandoc.Builder (Blocks, Inlines, rawBlock, HasMeta(..))
 import qualified Text.Pandoc.Builder as B
 import Text.Pandoc.XML (fromEntities)
 import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)
-import Text.Parsec
+import Text.Parsec hiding (token)
 import Text.Parsec.Pos (newPos)
 import Data.Char ( toLower, toUpper, ord, chr, isAscii, isAlphaNum,
                    isHexDigit, isSpace )
@@ -484,7 +485,8 @@ mathDisplayWith op cl = try $ do
   string op
   many1Till (noneOf "\n" <|> (newline <* notFollowedBy' blankline)) (try $ string cl)
 
-mathDisplay :: Stream s m Char => ParserT s ParserState m String
+mathDisplay :: (HasReaderOptions st, Stream s m Char)
+            => ParserT s st m String
 mathDisplay =
       (guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$")
   <|> (guardEnabled Ext_tex_math_single_backslash >>
@@ -492,7 +494,8 @@ mathDisplay =
   <|> (guardEnabled Ext_tex_math_double_backslash >>
        mathDisplayWith "\\\\[" "\\\\]")
 
-mathInline :: Stream s m Char => ParserT s ParserState m String
+mathInline :: (HasReaderOptions st , Stream s m Char)
+           => ParserT s st m String
 mathInline =
       (guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$")
   <|> (guardEnabled Ext_tex_math_single_backslash >>
@@ -909,6 +912,21 @@ class HasReaderOptions st where
   -- default
   getOption  f         = (f . extractReaderOptions) <$> getState
 
+class HasQuoteContext st m where
+  getQuoteContext :: (Stream s m t) => ParsecT s st m QuoteContext
+  withQuoteContext :: QuoteContext -> ParsecT s st m a -> ParsecT s st m a
+
+instance Monad m => HasQuoteContext ParserState m where
+  getQuoteContext = stateQuoteContext <$> getState
+  withQuoteContext context parser = do
+    oldState <- getState
+    let oldQuoteContext = stateQuoteContext oldState
+    setState oldState { stateQuoteContext = context }
+    result <- parser
+    newState <- getState
+    setState newState { stateQuoteContext = oldQuoteContext }
+    return result
+
 instance HasReaderOptions ParserState where
   extractReaderOptions = stateOptions
 
@@ -1051,9 +1069,9 @@ registerHeader (ident,classes,kvs) header' = do
 failUnlessSmart :: (Stream s m a, HasReaderOptions st) => ParserT s st m ()
 failUnlessSmart = getOption readerSmart >>= guard
 
-smartPunctuation :: Stream s m Char
-                 => ParserT s ParserState m Inlines
-                 -> ParserT s ParserState m Inlines
+smartPunctuation :: (HasReaderOptions st, HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
+                 => ParserT s st m Inlines
+                 -> ParserT s st m Inlines
 smartPunctuation inlineParser = do
   failUnlessSmart
   choice [ quoted inlineParser, apostrophe, dash, ellipses ]
@@ -1061,46 +1079,33 @@ smartPunctuation inlineParser = do
 apostrophe :: Stream s m Char => ParserT s st m Inlines
 apostrophe = (char '\'' <|> char '\8217') >> return (B.str "\x2019")
 
-quoted :: Stream s m Char
-       => ParserT s  ParserState m Inlines
-       -> ParserT s  ParserState m Inlines
+quoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
+       => ParserT s st m Inlines
+       -> ParserT s st m Inlines
 quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser
 
-withQuoteContext :: Stream s m t
-                 => QuoteContext
-                 -> ParserT s ParserState m a
-                 -> ParserT s ParserState m a
-withQuoteContext context parser = do
-  oldState <- getState
-  let oldQuoteContext = stateQuoteContext oldState
-  setState oldState { stateQuoteContext = context }
-  result <- parser
-  newState <- getState
-  setState newState { stateQuoteContext = oldQuoteContext }
-  return result
-
-singleQuoted :: Stream s m Char
-             => ParserT s ParserState m Inlines
-             -> ParserT s ParserState m Inlines
+singleQuoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
+             => ParserT s st m Inlines
+             -> ParserT s st m Inlines
 singleQuoted inlineParser = try $ do
   singleQuoteStart
   withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=
     return . B.singleQuoted . mconcat
 
-doubleQuoted :: Stream s m Char
-             => ParserT s ParserState m Inlines
-             -> ParserT s ParserState m Inlines
+doubleQuoted :: (HasQuoteContext st m, Stream s m Char)
+             => ParserT s st m Inlines
+             -> ParserT s st m Inlines
 doubleQuoted inlineParser = try $ do
   doubleQuoteStart
   withQuoteContext InDoubleQuote $ manyTill inlineParser doubleQuoteEnd >>=
     return . B.doubleQuoted . mconcat
 
-failIfInQuoteContext :: Stream s m t
+failIfInQuoteContext :: (HasQuoteContext st m, Stream s m t)
                      => QuoteContext
-                     -> ParserT s ParserState m ()
+                     -> ParserT s st m ()
 failIfInQuoteContext context = do
-  st <- getState
-  if stateQuoteContext st == context
+  context' <- getQuoteContext
+  if context' == context
      then fail "already inside quotes"
      else return ()
 
@@ -1110,8 +1115,8 @@ charOrRef cs =
                        guard (c `elem` cs)
                        return c)
 
-singleQuoteStart :: Stream s m Char
-                 => ParserT s ParserState m ()
+singleQuoteStart :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
+                 => ParserT s st m ()
 singleQuoteStart = do
   failIfInQuoteContext InSingleQuote
   -- single quote start can't be right after str
@@ -1124,8 +1129,8 @@ singleQuoteEnd = try $ do
   charOrRef "'\8217\146"
   notFollowedBy alphaNum
 
-doubleQuoteStart :: Stream s m Char
-                 => ParserT s ParserState m ()
+doubleQuoteStart :: (HasQuoteContext st m, Stream s m Char)
+                 => ParserT s st m ()
 doubleQuoteStart = do
   failIfInQuoteContext InDoubleQuote
   try $ do charOrRef "\"\8220\147"
@@ -1179,6 +1184,14 @@ citeKey = try $ do
   let key = firstChar:rest
   return (suppress_author, key)
 
+
+token :: (Stream s m t)
+      => (t -> String)
+      -> (t -> SourcePos)
+      -> (t -> Maybe a)
+      -> ParsecT s st m a
+token pp pos match = tokenPrim pp (\_ t _ -> pos t) match
+
 --
 -- Macros
 --
@@ -1200,9 +1213,9 @@ macro = do
                            else return $ rawBlock "latex" def'
 
 -- | Apply current macros to string.
-applyMacros' :: Stream [Char] m Char
+applyMacros' :: (HasReaderOptions st, HasMacros st, Stream [Char] m Char)
              => String
-             -> ParserT [Char] ParserState m String
+             -> ParserT [Char] st m String
 applyMacros' target = do
   apply <- getOption readerApplyMacros
   if apply