00b7ab8 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Muse reader: replace ParserState with MuseState

00b7ab8Alexander Krotov9 years ago

src/Text/Pandoc/Readers/Muse.hs+104−29

compare with master

unifiedsplit

@@ -42,9 +42,11 @@ module Text.Pandoc.Readers.Muse (readMuse) where

42import Control.Monad

43import Control.Monad.Except (throwError)

44import Data.Char (isLetter)

45+import Data.Default

45import Data.List (stripPrefix, intercalate)

46import Data.List (stripPrefix, intercalate)

46import Data.List.Split (splitOn)

47import Data.List.Split (splitOn)

47import qualified Data.Map as M

48import qualified Data.Map as M

49+import qualified Data.Set as Set

48import Data.Maybe (fromMaybe)

50import Data.Maybe (fromMaybe)

49import Data.Text (Text, unpack)

51import Data.Text (Text, unpack)

50import System.FilePath (takeExtension)

52import System.FilePath (takeExtension)

@@ -55,7 +57,7 @@ import Text.Pandoc.Class (PandocMonad (..))

55import Text.Pandoc.Definition

57import Text.Pandoc.Definition

56import Text.Pandoc.Logging

58import Text.Pandoc.Logging

57import Text.Pandoc.Options

59import Text.Pandoc.Options

58−import Text.Pandoc.Parsing

60+import Text.Pandoc.Parsing hiding (F)

59import Text.Pandoc.Readers.HTML (htmlTag)

61import Text.Pandoc.Readers.HTML (htmlTag)

60import Text.Pandoc.Shared (crFilter, underlineSpan)

62import Text.Pandoc.Shared (crFilter, underlineSpan)

@@ -65,12 +67,61 @@ readMuse :: PandocMonad m

65 -> Text

67 -> Text

66 -> m Pandoc

68 -> m Pandoc

67readMuse opts s = do

69readMuse opts s = do

68− res <- readWithM parseMuse def{ stateOptions = opts } (unpack (crFilter s))

70+ res <- readWithM parseMuse def{ museOptions = opts } (unpack (crFilter s))

69 case res of

71 case res of

70 Left e -> throwError e

72 Left e -> throwError e

71 Right d -> return d

73 Right d -> return d

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+

73−type MuseParser = ParserT String ParserState

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

125

75--

126--

76-- main parser

127-- main parser

@@ -83,7 +134,7 @@ parseMuse = do

83 eof

134 eof

84 st <- getState

135 st <- getState

85 let doc = runF (do Pandoc _ bs <- B.doc <$> blocks

136 let doc = runF (do Pandoc _ bs <- B.doc <$> blocks

86− meta <- stateMeta' st

137+ meta <- museMeta st

87 return $ Pandoc meta bs) st

138 return $ Pandoc meta bs) st

88 reportLogMessages

139 reportLogMessages

89 return doc

140 return doc

@@ -131,7 +182,7 @@ atStart :: PandocMonad m => MuseParser m a -> MuseParser m a

131atStart p = do

182atStart p = do

132 pos <- getPosition

183 pos <- getPosition

133 st <- getState

184 st <- getState

134− guard $ stateLastStrPos st /= Just pos

185+ guard $ museLastStrPos st /= Just pos

135 p

186 p

136

187

137--

188--

@@ -167,7 +218,7 @@ directive :: PandocMonad m => MuseParser m ()

167directive = do

218directive = do

168 ext <- getOption readerExtensions

219 ext <- getOption readerExtensions

169 (key, value) <- if extensionEnabled Ext_amuse ext then parseAmuseDirective else parseEmacsDirective

220 (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 }

171 where translateKey "cover" = "cover-image"

222 where translateKey "cover" = "cover-image"

172 translateKey x = x

223 translateKey x = x

173

224

@@ -179,7 +230,7 @@ parseBlock :: PandocMonad m => MuseParser m (F Blocks)

179parseBlock = do

230parseBlock = do

180 res <- blockElements <|> para

231 res <- blockElements <|> para

181 optionMaybe blankline

232 optionMaybe blankline

182− trace (take 60 $ show $ B.toList $ runF res defaultParserState)

233+ trace (take 60 $ show $ B.toList $ runF res def)

183 return res

234 return res

184

235

185blockElements :: PandocMonad m => MuseParser m (F Blocks)

236blockElements :: PandocMonad m => MuseParser m (F Blocks)

@@ -222,15 +273,15 @@ separator = try $ do

222

273

223header :: PandocMonad m => MuseParser m (F Blocks)

274header :: PandocMonad m => MuseParser m (F Blocks)

224header = try $ do

275header = try $ do

225− st <- stateParserContext <$> getState

276+ st <- museInList <$> getState

226− q <- stateQuoteContext <$> getState

277+ q <- museInQuote <$> getState

227− getPosition >>= \pos -> guard (st == NullState && q == NoQuote && sourceColumn pos == 1)

278+ getPosition >>= \pos -> guard (not st && not q && sourceColumn pos == 1)

228 level <- fmap length $ many1 $ char '*'

279 level <- fmap length $ many1 $ char '*'

229 guard $ level <= 5

280 guard $ level <= 5

230 spaceChar

281 spaceChar

231 content <- trimInlinesF . mconcat <$> manyTill inline eol

282 content <- trimInlinesF . mconcat <$> manyTill inline eol

232 anchorId <- option "" parseAnchor

283 anchorId <- option "" parseAnchor

233− attr <- registerHeader (anchorId, [], []) (runF content defaultParserState)

284+ attr <- registerHeader (anchorId, [], []) (runF content def)

234 return $ B.headerWith attr level <$> content

285 return $ B.headerWith attr level <$> content

235

286

236example :: PandocMonad m => MuseParser m (F Blocks)

287example :: PandocMonad m => MuseParser m (F Blocks)

@@ -284,7 +335,11 @@ rightTag = snd <$> parseHtmlContent "right"

284

335

285quoteTag :: PandocMonad m => MuseParser m (F Blocks)

336quoteTag :: PandocMonad m => MuseParser m (F Blocks)

286quoteTag = do

337quoteTag = do

338+ st <- getState

339+ let oldInQuote = museInQuote st

340+ setState $ st{ museInQuote = True }

287− res <- snd <$> withQuoteContext InDoubleQuote (parseHtmlContent "quote")

341+ res <- snd <$> (parseHtmlContent "quote")

342+ setState $ st{ museInQuote = oldInQuote }

288 return $ B.blockQuote <$> res

343 return $ B.blockQuote <$> res

289

344

290-- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025

345-- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025

@@ -316,8 +371,8 @@ commentTag = htmlElement "comment" >> return mempty

316para :: PandocMonad m => MuseParser m (F Blocks)

371para :: PandocMonad m => MuseParser m (F Blocks)

317para = do

372para = do

318 indent <- length <$> many spaceChar

373 indent <- length <$> many spaceChar

319− st <- stateParserContext <$> getState

374+ st <- museInList <$> getState

320− let f = if st /= ListItemState && indent >= 2 && indent < 6 then B.blockQuote else id

375+ let f = if not st && indent >= 2 && indent < 6 then B.blockQuote else id

321 fmap (f . B.para) . trimInlinesF . mconcat <$> many1Till inline endOfParaElement

376 fmap (f . B.para) . trimInlinesF . mconcat <$> many1Till inline endOfParaElement

322 where

377 where

323 endOfParaElement = lookAhead $ try (eof <|> newBlockElement)

378 endOfParaElement = lookAhead $ try (eof <|> newBlockElement)

@@ -338,11 +393,11 @@ amuseNoteBlock = try $ do

338 pos <- getPosition

393 pos <- getPosition

339 ref <- noteMarker <* spaceChar

394 ref <- noteMarker <* spaceChar

340 content <- listItemContents

395 content <- listItemContents

341− oldnotes <- stateNotes' <$> getState

396+ oldnotes <- museNotes <$> getState

342 case M.lookup ref oldnotes of

397 case M.lookup ref oldnotes of

343 Just _ -> logMessage $ DuplicateNoteReference ref pos

398 Just _ -> logMessage $ DuplicateNoteReference ref pos

344 Nothing -> return ()

399 Nothing -> return ()

345− updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }

400+ updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes }

346 return mempty

401 return mempty

347

402

348-- Emacs version of note

403-- Emacs version of note

@@ -353,11 +408,11 @@ emacsNoteBlock = try $ do

353 pos <- getPosition

408 pos <- getPosition

354 ref <- noteMarker <* skipSpaces

409 ref <- noteMarker <* skipSpaces

355 content <- mconcat <$> blocksTillNote

410 content <- mconcat <$> blocksTillNote

356− oldnotes <- stateNotes' <$> getState

411+ oldnotes <- museNotes <$> getState

357 case M.lookup ref oldnotes of

412 case M.lookup ref oldnotes of

358 Just _ -> logMessage $ DuplicateNoteReference ref pos

413 Just _ -> logMessage $ DuplicateNoteReference ref pos

359 Nothing -> return ()

414 Nothing -> return ()

360− updateState $ \s -> s{ stateNotes' = M.insert ref (pos, content) oldnotes }

415+ updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes }

361 return mempty

416 return mempty

362 where

417 where

363 blocksTillNote =

418 blocksTillNote =

@@ -392,10 +447,10 @@ lineBlock = try $ do

392withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a

447withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a

393withListContext p = do

448withListContext p = do

394 state <- getState

449 state <- getState

395− let oldContext = stateParserContext state

450+ let oldInList = museInList state

396− setState $ state { stateParserContext = ListItemState }

451+ setState $ state { museInList = True }

397 parsed <- p

452 parsed <- p

398− updateState (\st -> st {stateParserContext = oldContext})

453+ updateState (\st -> st { museInList = oldInList })

399 return parsed

454 return parsed

400

455

401listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks)

456listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks)

@@ -430,18 +485,38 @@ bulletList = try $ do

430 rest <- many $ listItem (col - 1) (char '-')

485 rest <- many $ listItem (col - 1) (char '-')

431 return $ B.bulletList <$> sequence (first : rest)

486 return $ B.bulletList <$> sequence (first : rest)

432

487

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+

433orderedList :: PandocMonad m => MuseParser m (F Blocks)

509orderedList :: PandocMonad m => MuseParser m (F Blocks)

434orderedList = try $ do

510orderedList = try $ do

435 many spaceChar

511 many spaceChar

436 pos <- getPosition

512 pos <- getPosition

437 let col = sourceColumn pos

513 let col = sourceColumn pos

438 guard $ col /= 1

514 guard $ col /= 1

439− p@(_, style, delim) <- anyOrderedListMarker

515+ p@(_, style, _) <- anyMuseOrderedListMarker

440 guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]

516 guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]

441− guard $ delim == Period

442 void spaceChar <|> lookAhead eol

517 void spaceChar <|> lookAhead eol

443 first <- listItemContents

518 first <- listItemContents

444− rest <- many $ listItem (col - 1) (orderedListMarker style delim)

519+ rest <- many $ listItem (col - 1) (museOrderedListMarker style)

445 return $ B.orderedListWith p <$> sequence (first : rest)

520 return $ B.orderedListWith p <$> sequence (first : rest)

446

521

447definitionListItem :: PandocMonad m => Int -> MuseParser m (F (Inlines, [Blocks]))

522definitionListItem :: PandocMonad m => Int -> MuseParser m (F (Inlines, [Blocks]))

@@ -606,12 +681,12 @@ footnote :: PandocMonad m => MuseParser m (F Inlines)

606footnote = try $ do

681footnote = try $ do

607 ref <- noteMarker

682 ref <- noteMarker

608 return $ do

683 return $ do

609− notes <- asksF stateNotes'

684+ notes <- asksF museNotes

610 case M.lookup ref notes of

685 case M.lookup ref notes of

611 Nothing -> return $ B.str $ "[" ++ ref ++ "]"

686 Nothing -> return $ B.str $ "[" ++ ref ++ "]"

612 Just (_pos, contents) -> do

687 Just (_pos, contents) -> do

613 st <- askF

688 st <- askF

614− let contents' = runF contents st { stateNotes' = M.empty }

689+ let contents' = runF contents st { museNotes = M.empty }

615 return $ B.note contents'

690 return $ B.note contents'

616

691

617whitespace :: PandocMonad m => MuseParser m (F Inlines)

692whitespace :: PandocMonad m => MuseParser m (F Inlines)

@@ -713,10 +788,10 @@ symbol = return . B.str <$> count 1 nonspaceChar

713link :: PandocMonad m => MuseParser m (F Inlines)

788link :: PandocMonad m => MuseParser m (F Inlines)

714link = try $ do

789link = try $ do

715 st <- getState

790 st <- getState

716− guard $ stateAllowLinks st

791+ guard $ not $ museInLink st

717− setState $ st{ stateAllowLinks = False }

792+ setState $ st{ museInLink = True }

718 (url, title, content) <- linkText

793 (url, title, content) <- linkText

719− setState $ st{ stateAllowLinks = True }

794+ setState $ st{ museInLink = False }

720 return $ case stripPrefix "URL:" url of

795 return $ case stripPrefix "URL:" url of

721 Nothing -> if isImageUrl url

796 Nothing -> if isImageUrl url

722 then B.image url title <$> fromMaybe (return mempty) content

797 then B.image url title <$> fromMaybe (return mempty) content