Muse reader: replace ParserState with MuseState

1 files changed, 104 insertions, 29 deletions

diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs
index c4175c4b2..4e1bb95ec 100644
--- a/src/Text/Pandoc/Readers/Muse.hs
+++ b/src/Text/Pandoc/Readers/Muse.hs
@@ -42,9 +42,11 @@ module Text.Pandoc.Readers.Muse (readMuse) where
 import Control.Monad
 import Control.Monad.Except (throwError)
 import Data.Char (isLetter)
+import Data.Default
 import Data.List (stripPrefix, intercalate)
 import Data.List.Split (splitOn)
 import qualified Data.Map as M
+import qualified Data.Set as Set
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, unpack)
 import System.FilePath (takeExtension)
@@ -55,7 +57,7 @@ import Text.Pandoc.Class (PandocMonad (..))
 import Text.Pandoc.Definition
 import Text.Pandoc.Logging
 import Text.Pandoc.Options
-import Text.Pandoc.Parsing
+import Text.Pandoc.Parsing hiding (F)
 import Text.Pandoc.Readers.HTML (htmlTag)
 import Text.Pandoc.Shared (crFilter, underlineSpan)
 
@@ -65,12 +67,61 @@ readMuse :: PandocMonad m
          -> Text
          -> m Pandoc
 readMuse opts s = do
-  res <- readWithM parseMuse def{ stateOptions = opts } (unpack (crFilter s))
+  res <- readWithM parseMuse def{ museOptions = opts } (unpack (crFilter s))
   case res of
        Left e  -> throwError e
        Right d -> return d
 
-type MuseParser = ParserT String ParserState
+type F = Future MuseState
+
+data MuseState = MuseState { museMeta :: F Meta -- ^ Document metadata
+                           , museOptions :: ReaderOptions
+                           , museHeaders :: M.Map Inlines String -- ^ List of headers and ids (used for implicit ref links)
+                           , museIdentifierList :: Set.Set String
+                           , museLastStrPos :: Maybe SourcePos -- ^ Position after last str parsed
+                           , museLogMessages :: [LogMessage]
+                           , museNotes :: M.Map String (SourcePos, F Blocks)
+                           , museInQuote :: Bool
+                           , museInList :: Bool
+                           , museInLink :: Bool
+                           }
+
+instance Default MuseState where
+  def = defaultMuseState
+
+defaultMuseState :: MuseState
+defaultMuseState = MuseState { museMeta = return nullMeta
+                             , museOptions = def
+                             , museHeaders = M.empty
+                             , museIdentifierList = Set.empty
+                             , museLastStrPos = Nothing
+                             , museLogMessages = []
+                             , museNotes = M.empty
+                             , museInQuote = False
+                             , museInList = False
+                             , museInLink = False
+                             }
+
+type MuseParser = ParserT String MuseState
+
+instance HasReaderOptions MuseState where
+  extractReaderOptions = museOptions
+
+instance HasHeaderMap MuseState where
+  extractHeaderMap     = museHeaders
+  updateHeaderMap f st = st{ museHeaders = f $ museHeaders st }
+
+instance HasIdentifierList MuseState where
+  extractIdentifierList     = museIdentifierList
+  updateIdentifierList f st = st{ museIdentifierList = f $ museIdentifierList st }
+
+instance HasLastStrPosition MuseState where
+  setLastStrPos pos st = st{ museLastStrPos = Just pos }
+  getLastStrPos st     = museLastStrPos st
+
+instance HasLogMessages MuseState where
+  addLogMessage m s = s{ museLogMessages = m : museLogMessages s }
+  getLogMessages = reverse . museLogMessages
 
 --
 -- main parser
@@ -83,7 +134,7 @@ parseMuse = do
   eof
   st <- getState
   let doc = runF (do Pandoc _ bs <- B.doc <$> blocks
-                     meta <- stateMeta' st
+                     meta <- museMeta st
                      return $ Pandoc meta bs) st
   reportLogMessages
   return doc
@@ -131,7 +182,7 @@ atStart :: PandocMonad m => MuseParser m a -> MuseParser m a
 atStart p = do
   pos <- getPosition
   st <- getState
-  guard $ stateLastStrPos st /= Just pos
+  guard $ museLastStrPos st /= Just pos
   p
 
 --
@@ -167,7 +218,7 @@ directive :: PandocMonad m => MuseParser m ()
 directive = do
   ext <- getOption readerExtensions
   (key, value) <- if extensionEnabled Ext_amuse ext then parseAmuseDirective else parseEmacsDirective
-  updateState $ \st -> st { stateMeta' = B.setMeta (translateKey key) <$> value <*> stateMeta' st }
+  updateState $ \st -> st { museMeta = B.setMeta (translateKey key) <$> value <*> museMeta st }
   where translateKey "cover" = "cover-image"
         translateKey x = x
 
@@ -179,7 +230,7 @@ parseBlock :: PandocMonad m => MuseParser m (F Blocks)
 parseBlock = do
   res <- blockElements <|> para
   optionMaybe blankline
-  trace (take 60 $ show $ B.toList $ runF res defaultParserState)
+  trace (take 60 $ show $ B.toList $ runF res def)
   return res
 
 blockElements :: PandocMonad m => MuseParser m (F Blocks)
@@ -222,15 +273,15 @@ separator = try $ do
 
 header :: PandocMonad m => MuseParser m (F Blocks)
 header = try $ do
-  st <- stateParserContext <$> getState
-  q <- stateQuoteContext <$> getState
-  getPosition >>= \pos -> guard (st == NullState && q == NoQuote && sourceColumn pos == 1)
+  st <- museInList <$> getState
+  q <- museInQuote <$> getState
+  getPosition >>= \pos -> guard (not st && not q && sourceColumn pos == 1)
   level <- fmap length $ many1 $ char '*'
   guard $ level <= 5
   spaceChar
   content <- trimInlinesF . mconcat <$> manyTill inline eol
   anchorId <- option "" parseAnchor
-  attr <- registerHeader (anchorId, [], []) (runF content defaultParserState)
+  attr <- registerHeader (anchorId, [], []) (runF content def)
   return $ B.headerWith attr level <$> content
 
 example :: PandocMonad m => MuseParser m (F Blocks)
@@ -284,7 +335,11 @@ rightTag = snd <$> parseHtmlContent "right"
 
 quoteTag :: PandocMonad m => MuseParser m (F Blocks)
 quoteTag = do
-  res <- snd <$> withQuoteContext InDoubleQuote (parseHtmlContent "quote")
+  st <- getState
+  let oldInQuote = museInQuote st
+  setState $ st{ museInQuote = True }
+  res <- snd <$> (parseHtmlContent "quote")
+  setState $ st{ museInQuote = oldInQuote }
   return $ B.blockQuote <$> res
 
 -- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025
@@ -316,8 +371,8 @@ commentTag = htmlElement "comment" >> return mempty
 para :: PandocMonad m => MuseParser m (F Blocks)
 para = do
  indent <- length <$> many spaceChar
- st <- stateParserContext <$> getState
- let f = if st /= ListItemState && indent >= 2 && indent < 6 then B.blockQuote else id
+ st <- museInList <$> getState
+ let f = if not st && indent >= 2 && indent < 6 then B.blockQuote else id
  fmap (f . B.para) . trimInlinesF . mconcat <$> many1Till inline endOfParaElement
  where
    endOfParaElement = lookAhead $ try (eof <|> newBlockElement)
@@ -338,11 +393,11 @@ amuseNoteBlock = try $ do
   pos <- getPosition
   ref <- noteMarker <* spaceChar
   content <- listItemContents
-  oldnotes <- stateNotes' <$> getState
+  oldnotes <- museNotes <$> getState
   case M.lookup ref oldnotes of
     Just _  -> logMessage $ DuplicateNoteReference ref pos
     Nothing -> return ()
-  updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }
+  updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes }
   return mempty
 
 -- Emacs version of note
@@ -353,11 +408,11 @@ emacsNoteBlock = try $ do
   pos <- getPosition
   ref <- noteMarker <* skipSpaces
   content <- mconcat <$> blocksTillNote
-  oldnotes <- stateNotes' <$> getState
+  oldnotes <- museNotes <$> getState
   case M.lookup ref oldnotes of
     Just _  -> logMessage $ DuplicateNoteReference ref pos
     Nothing -> return ()
-  updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }
+  updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes }
   return mempty
   where
     blocksTillNote =
@@ -392,10 +447,10 @@ lineBlock = try $ do
 withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a
 withListContext p = do
   state <- getState
-  let oldContext = stateParserContext state
-  setState $ state { stateParserContext = ListItemState }
+  let oldInList = museInList state
+  setState $ state { museInList = True }
   parsed <- p
-  updateState (\st -> st {stateParserContext = oldContext})
+  updateState (\st -> st { museInList = oldInList })
   return parsed
 
 listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks)
@@ -430,18 +485,38 @@ bulletList = try $ do
   rest <- many $ listItem (col - 1) (char '-')
   return $ B.bulletList <$> sequence (first : rest)
 
+-- | Parses an ordered list marker and returns list attributes.
+anyMuseOrderedListMarker :: PandocMonad m => MuseParser m ListAttributes
+anyMuseOrderedListMarker = do
+  (style, start) <- decimal <|> lowerAlpha <|> lowerRoman <|> upperAlpha <|> upperRoman
+  char '.'
+  return (start, style, Period)
+
+museOrderedListMarker :: PandocMonad m
+                      => ListNumberStyle
+                      -> MuseParser m Int
+museOrderedListMarker style = do
+  (_, start) <- case style of
+                  Decimal    -> decimal
+                  UpperRoman -> upperRoman
+                  LowerRoman -> lowerRoman
+                  UpperAlpha -> upperAlpha
+                  LowerAlpha -> lowerAlpha
+                  _          -> fail "Unhandled case"
+  char '.'
+  return start
+
 orderedList :: PandocMonad m => MuseParser m (F Blocks)
 orderedList = try $ do
   many spaceChar
   pos <- getPosition
   let col = sourceColumn pos
   guard $ col /= 1
-  p@(_, style, delim) <- anyOrderedListMarker
+  p@(_, style, _) <- anyMuseOrderedListMarker
   guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]
-  guard $ delim == Period
   void spaceChar <|> lookAhead eol
   first <- listItemContents
-  rest <- many $ listItem (col - 1) (orderedListMarker style delim)
+  rest <- many $ listItem (col - 1) (museOrderedListMarker style)
   return $ B.orderedListWith p <$> sequence (first : rest)
 
 definitionListItem :: PandocMonad m => Int -> MuseParser m (F (Inlines, [Blocks]))
@@ -606,12 +681,12 @@ footnote :: PandocMonad m => MuseParser m (F Inlines)
 footnote = try $ do
   ref <- noteMarker
   return $ do
-    notes <- asksF stateNotes'
+    notes <- asksF museNotes
     case M.lookup ref notes of
       Nothing -> return $ B.str $ "[" ++ ref ++ "]"
       Just (_pos, contents) -> do
         st <- askF
-        let contents' = runF contents st { stateNotes' = M.empty }
+        let contents' = runF contents st { museNotes = M.empty }
         return $ B.note contents'
 
 whitespace :: PandocMonad m => MuseParser m (F Inlines)
@@ -713,10 +788,10 @@ symbol = return . B.str <$> count 1 nonspaceChar
 link :: PandocMonad m => MuseParser m (F Inlines)
 link = try $ do
   st <- getState
-  guard $ stateAllowLinks st
-  setState $ st{ stateAllowLinks = False }
+  guard $ not $ museInLink st
+  setState $ st{ museInLink = True }
   (url, title, content) <- linkText
-  setState $ st{ stateAllowLinks = True }
+  setState $ st{ museInLink = False }
   return $ case stripPrefix "URL:" url of
              Nothing -> if isImageUrl url
                           then B.image url title <$> fromMaybe (return mempty) content