@@ -42,9 +42,11 @@ module Text.Pandoc.Readers.Muse (readMuse) where
4242import Control.Monad
4343import Control.Monad.Except (throwError)
4444import Data.Char (isLetter)
45+import Data.Default
4546import Data.List (stripPrefix, intercalate)
4647import Data.List.Split (splitOn)
4748import qualified Data.Map as M
49+import qualified Data.Set as Set
4850import Data.Maybe (fromMaybe)
4951import Data.Text (Text, unpack)
5052import System.FilePath (takeExtension)
@@ -55,7 +57,7 @@ import Text.Pandoc.Class (PandocMonad (..))
5557import Text.Pandoc.Definition
5658import Text.Pandoc.Logging
5759import Text.Pandoc.Options
58−import Text.Pandoc.Parsing
60+import Text.Pandoc.Parsing hiding (F)
5961import Text.Pandoc.Readers.HTML (htmlTag)
6062import Text.Pandoc.Shared (crFilter, underlineSpan)
6163
@@ -65,12 +67,61 @@ readMuse :: PandocMonad m
6567 -> Text
6668 -> m Pandoc
6769readMuse opts s = do
68− res <- readWithM parseMuse def{ stateOptions = opts } (unpack (crFilter s))
70+ res <- readWithM parseMuse def{ museOptions = opts } (unpack (crFilter s))
6971 case res of
7072 Left e -> throwError e
7173 Right d -> return d
7274
73−type MuseParser = ParserT String ParserState
75+type F = Future MuseState
76+
77+data MuseState = MuseState { museMeta :: F Meta -- ^ Document metadata
78+ , museOptions :: ReaderOptions
79+ , museHeaders :: M.Map Inlines String -- ^ List of headers and ids (used for implicit ref links)
80+ , museIdentifierList :: Set.Set String
81+ , museLastStrPos :: Maybe SourcePos -- ^ Position after last str parsed
82+ , museLogMessages :: [LogMessage]
83+ , museNotes :: M.Map String (SourcePos, F Blocks)
84+ , museInQuote :: Bool
85+ , museInList :: Bool
86+ , museInLink :: Bool
87+ }
88+
89+instance Default MuseState where
90+ def = defaultMuseState
91+
92+defaultMuseState :: MuseState
93+defaultMuseState = MuseState { museMeta = return nullMeta
94+ , museOptions = def
95+ , museHeaders = M.empty
96+ , museIdentifierList = Set.empty
97+ , museLastStrPos = Nothing
98+ , museLogMessages = []
99+ , museNotes = M.empty
100+ , museInQuote = False
101+ , museInList = False
102+ , museInLink = False
103+ }
104+
105+type MuseParser = ParserT String MuseState
106+
107+instance HasReaderOptions MuseState where
108+ extractReaderOptions = museOptions
109+
110+instance HasHeaderMap MuseState where
111+ extractHeaderMap = museHeaders
112+ updateHeaderMap f st = st{ museHeaders = f $ museHeaders st }
113+
114+instance HasIdentifierList MuseState where
115+ extractIdentifierList = museIdentifierList
116+ updateIdentifierList f st = st{ museIdentifierList = f $ museIdentifierList st }
117+
118+instance HasLastStrPosition MuseState where
119+ setLastStrPos pos st = st{ museLastStrPos = Just pos }
120+ getLastStrPos st = museLastStrPos st
121+
122+instance HasLogMessages MuseState where
123+ addLogMessage m s = s{ museLogMessages = m : museLogMessages s }
124+ getLogMessages = reverse . museLogMessages
74125
75126--
76127-- main parser
@@ -83,7 +134,7 @@ parseMuse = do
83134 eof
84135 st <- getState
85136 let doc = runF (do Pandoc _ bs <- B.doc <$> blocks
86− meta <- stateMeta' st
137+ meta <- museMeta st
87138 return $ Pandoc meta bs) st
88139 reportLogMessages
89140 return doc
@@ -131,7 +182,7 @@ atStart :: PandocMonad m => MuseParser m a -> MuseParser m a
131182atStart p = do
132183 pos <- getPosition
133184 st <- getState
134− guard $ stateLastStrPos st /= Just pos
185+ guard $ museLastStrPos st /= Just pos
135186 p
136187
137188--
@@ -167,7 +218,7 @@ directive :: PandocMonad m => MuseParser m ()
167218directive = do
168219 ext <- getOption readerExtensions
169220 (key, value) <- if extensionEnabled Ext_amuse ext then parseAmuseDirective else parseEmacsDirective
170− updateState $ \st -> st { stateMeta' = B.setMeta (translateKey key) <$> value <*> stateMeta' st }
221+ updateState $ \st -> st { museMeta = B.setMeta (translateKey key) <$> value <*> museMeta st }
171222 where translateKey "cover" = "cover-image"
172223 translateKey x = x
173224
@@ -179,7 +230,7 @@ parseBlock :: PandocMonad m => MuseParser m (F Blocks)
179230parseBlock = do
180231 res <- blockElements <|> para
181232 optionMaybe blankline
182− trace (take 60 $ show $ B.toList $ runF res defaultParserState)
233+ trace (take 60 $ show $ B.toList $ runF res def)
183234 return res
184235
185236blockElements :: PandocMonad m => MuseParser m (F Blocks)
@@ -222,15 +273,15 @@ separator = try $ do
222273
223274header :: PandocMonad m => MuseParser m (F Blocks)
224275header = try $ do
225− st <- stateParserContext <$> getState
226− q <- stateQuoteContext <$> getState
227− getPosition >>= \pos -> guard (st == NullState && q == NoQuote && sourceColumn pos == 1)
276+ st <- museInList <$> getState
277+ q <- museInQuote <$> getState
278+ getPosition >>= \pos -> guard (not st && not q && sourceColumn pos == 1)
228279 level <- fmap length $ many1 $ char '*'
229280 guard $ level <= 5
230281 spaceChar
231282 content <- trimInlinesF . mconcat <$> manyTill inline eol
232283 anchorId <- option "" parseAnchor
233− attr <- registerHeader (anchorId, [], []) (runF content defaultParserState)
284+ attr <- registerHeader (anchorId, [], []) (runF content def)
234285 return $ B.headerWith attr level <$> content
235286
236287example :: PandocMonad m => MuseParser m (F Blocks)
@@ -284,7 +335,11 @@ rightTag = snd <$> parseHtmlContent "right"
284335
285336quoteTag :: PandocMonad m => MuseParser m (F Blocks)
286337quoteTag = do
287− res <- snd <$> withQuoteContext InDoubleQuote (parseHtmlContent "quote")
338+ st <- getState
339+ let oldInQuote = museInQuote st
340+ setState $ st{ museInQuote = True }
341+ res <- snd <$> (parseHtmlContent "quote")
342+ setState $ st{ museInQuote = oldInQuote }
288343 return $ B.blockQuote <$> res
289344
290345-- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025
@@ -316,8 +371,8 @@ commentTag = htmlElement "comment" >> return mempty
316371para :: PandocMonad m => MuseParser m (F Blocks)
317372para = do
318373 indent <- length <$> many spaceChar
319− st <- stateParserContext <$> getState
320− let f = if st /= ListItemState && indent >= 2 && indent < 6 then B.blockQuote else id
374+ st <- museInList <$> getState
375+ let f = if not st && indent >= 2 && indent < 6 then B.blockQuote else id
321376 fmap (f . B.para) . trimInlinesF . mconcat <$> many1Till inline endOfParaElement
322377 where
323378 endOfParaElement = lookAhead $ try (eof <|> newBlockElement)
@@ -338,11 +393,11 @@ amuseNoteBlock = try $ do
338393 pos <- getPosition
339394 ref <- noteMarker <* spaceChar
340395 content <- listItemContents
341− oldnotes <- stateNotes' <$> getState
396+ oldnotes <- museNotes <$> getState
342397 case M.lookup ref oldnotes of
343398 Just _ -> logMessage $ DuplicateNoteReference ref pos
344399 Nothing -> return ()
345− updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }
400+ updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes }
346401 return mempty
347402
348403-- Emacs version of note
@@ -353,11 +408,11 @@ emacsNoteBlock = try $ do
353408 pos <- getPosition
354409 ref <- noteMarker <* skipSpaces
355410 content <- mconcat <$> blocksTillNote
356− oldnotes <- stateNotes' <$> getState
411+ oldnotes <- museNotes <$> getState
357412 case M.lookup ref oldnotes of
358413 Just _ -> logMessage $ DuplicateNoteReference ref pos
359414 Nothing -> return ()
360− updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }
415+ updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes }
361416 return mempty
362417 where
363418 blocksTillNote =
@@ -392,10 +447,10 @@ lineBlock = try $ do
392447withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a
393448withListContext p = do
394449 state <- getState
395− let oldContext = stateParserContext state
396− setState $ state { stateParserContext = ListItemState }
450+ let oldInList = museInList state
451+ setState $ state { museInList = True }
397452 parsed <- p
398− updateState (\st -> st {stateParserContext = oldContext})
453+ updateState (\st -> st { museInList = oldInList })
399454 return parsed
400455
401456listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks)
@@ -430,18 +485,38 @@ bulletList = try $ do
430485 rest <- many $ listItem (col - 1) (char '-')
431486 return $ B.bulletList <$> sequence (first : rest)
432487
488+-- | Parses an ordered list marker and returns list attributes.
489+anyMuseOrderedListMarker :: PandocMonad m => MuseParser m ListAttributes
490+anyMuseOrderedListMarker = do
491+ (style, start) <- decimal <|> lowerAlpha <|> lowerRoman <|> upperAlpha <|> upperRoman
492+ char '.'
493+ return (start, style, Period)
494+
495+museOrderedListMarker :: PandocMonad m
496+ => ListNumberStyle
497+ -> MuseParser m Int
498+museOrderedListMarker style = do
499+ (_, start) <- case style of
500+ Decimal -> decimal
501+ UpperRoman -> upperRoman
502+ LowerRoman -> lowerRoman
503+ UpperAlpha -> upperAlpha
504+ LowerAlpha -> lowerAlpha
505+ _ -> fail "Unhandled case"
506+ char '.'
507+ return start
508+
433509orderedList :: PandocMonad m => MuseParser m (F Blocks)
434510orderedList = try $ do
435511 many spaceChar
436512 pos <- getPosition
437513 let col = sourceColumn pos
438514 guard $ col /= 1
439− p@(_, style, delim) <- anyOrderedListMarker
515+ p@(_, style, _) <- anyMuseOrderedListMarker
440516 guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]
441− guard $ delim == Period
442517 void spaceChar <|> lookAhead eol
443518 first <- listItemContents
444− rest <- many $ listItem (col - 1) (orderedListMarker style delim)
519+ rest <- many $ listItem (col - 1) (museOrderedListMarker style)
445520 return $ B.orderedListWith p <$> sequence (first : rest)
446521
447522definitionListItem :: PandocMonad m => Int -> MuseParser m (F (Inlines, [Blocks]))
@@ -606,12 +681,12 @@ footnote :: PandocMonad m => MuseParser m (F Inlines)
606681footnote = try $ do
607682 ref <- noteMarker
608683 return $ do
609− notes <- asksF stateNotes'
684+ notes <- asksF museNotes
610685 case M.lookup ref notes of
611686 Nothing -> return $ B.str $ "[" ++ ref ++ "]"
612687 Just (_pos, contents) -> do
613688 st <- askF
614− let contents' = runF contents st { stateNotes' = M.empty }
689+ let contents' = runF contents st { museNotes = M.empty }
615690 return $ B.note contents'
616691
617692whitespace :: PandocMonad m => MuseParser m (F Inlines)
@@ -713,10 +788,10 @@ symbol = return . B.str <$> count 1 nonspaceChar
713788link :: PandocMonad m => MuseParser m (F Inlines)
714789link = try $ do
715790 st <- getState
716− guard $ stateAllowLinks st
717− setState $ st{ stateAllowLinks = False }
791+ guard $ not $ museInLink st
792+ setState $ st{ museInLink = True }
718793 (url, title, content) <- linkText
719− setState $ st{ stateAllowLinks = True }
794+ setState $ st{ museInLink = False }
720795 return $ case stripPrefix "URL:" url of
721796 Nothing -> if isImageUrl url
722797 then B.image url title <$> fromMaybe (return mempty) content