ab85143 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Muse reader: refactor list parsing

ab85143Alexander Krotov9 years ago

src/Text/Pandoc/Readers/Muse.hs+65−75

compare with master

unifiedsplit

@@ -42,7 +42,8 @@ module Text.Pandoc.Readers.Muse (readMuse) where

42import Control.Monad

43import Control.Monad.Except (throwError)

44import Data.Char (isLetter)

45−import Data.List (stripPrefix)

45+import Data.List (stripPrefix, intercalate)

46+import Data.List.Split (splitOn)

46import qualified Data.Map as M

47import qualified Data.Map as M

47import Data.Maybe (fromMaybe)

48import Data.Maybe (fromMaybe)

48import Data.Text (Text, unpack)

49import Data.Text (Text, unpack)

@@ -187,17 +188,19 @@ directive = do

187-- block parsers

188-- block parsers

188--

189--

189

190

190−block :: PandocMonad m => MuseParser m (F Blocks)

191+parseBlock :: PandocMonad m => MuseParser m (F Blocks)

191−block = do

192+parseBlock = do

192− res <- mempty <$ skipMany1 blankline

193− <|> blockElements

193+ res <- blockElements <|> para

194− <|> para

195− skipMany blankline

194+ optionMaybe blankline

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

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

197 return res

196 return res

198

197

198+block :: PandocMonad m => MuseParser m (F Blocks)

199+block = parseBlock <* skipMany blankline

200+

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

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

200−blockElements = choice [ comment

202+blockElements = choice [ mempty <$ blankline

203+ , comment

201 , separator

204 , separator

202 , header

205 , header

203 , example

206 , example

@@ -257,15 +260,26 @@ example = try $ do

257-- in case opening and/or closing tags are on separate lines.

260-- in case opening and/or closing tags are on separate lines.

258chop :: String -> String

261chop :: String -> String

259chop = lchop . rchop

262chop = lchop . rchop

263+

264+lchop :: String -> String

260− where lchop s = case s of

265+lchop s = case s of

261 '\n':ss -> ss

266 '\n':ss -> ss

262 _ -> s

267 _ -> s

268+

269+rchop :: String -> String

263− rchop = reverse . lchop . reverse

270+rchop = reverse . lchop . reverse

271+

272+dropSpacePrefix :: [String] -> [String]

273+dropSpacePrefix lns =

274+ map (drop maxIndent) lns

275+ where flns = filter (not . all (== ' ')) lns

276+ maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns

264

277

265exampleTag :: PandocMonad m => MuseParser m (F Blocks)

278exampleTag :: PandocMonad m => MuseParser m (F Blocks)

266−exampleTag = do

279+exampleTag = try $ do

280+ many spaceChar

267 (attr, contents) <- htmlElement "example"

281 (attr, contents) <- htmlElement "example"

268− return $ return $ B.codeBlockWith attr $ chop contents

282+ return $ return $ B.codeBlockWith attr $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop contents

269

283

270literal :: PandocMonad m => MuseParser m (F Blocks)

284literal :: PandocMonad m => MuseParser m (F Blocks)

271literal = do

285literal = do

@@ -309,7 +323,7 @@ verseLine = do

309

323

310verseLines :: PandocMonad m => MuseParser m (F Blocks)

324verseLines :: PandocMonad m => MuseParser m (F Blocks)

311verseLines = do

325verseLines = do

312− optionMaybe blankline -- Skip blankline after opening tag on separate line

326+ --optionMaybe blankline -- Skip blankline after opening tag on separate line

313 lns <- many verseLine

327 lns <- many verseLine

314 lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns

328 lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns

315 return $ B.lineBlock <$> sequence lns'

329 return $ B.lineBlock <$> sequence lns'

@@ -317,7 +331,7 @@ verseLines = do

317verseTag :: PandocMonad m => MuseParser m (F Blocks)

331verseTag :: PandocMonad m => MuseParser m (F Blocks)

318verseTag = do

332verseTag = do

319 (_, content) <- htmlElement "verse"

333 (_, content) <- htmlElement "verse"

320− parseFromString verseLines content

334+ parseFromString verseLines (intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content)

321

335

322commentTag :: PandocMonad m => MuseParser m (F Blocks)

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

323commentTag = parseHtmlContent "comment" anyChar >> return mempty

337commentTag = parseHtmlContent "comment" anyChar >> return mempty

@@ -349,7 +363,7 @@ amuseNoteBlock = try $ do

349 guardEnabled Ext_amuse

363 guardEnabled Ext_amuse

350 pos <- getPosition

364 pos <- getPosition

351 ref <- noteMarker <* spaceChar

365 ref <- noteMarker <* spaceChar

352− content <- listItemContents $ 3 + length ref

366+ content <- listItemContents

353 oldnotes <- stateNotes' <$> getState

367 oldnotes <- stateNotes' <$> getState

354 case M.lookup ref oldnotes of

368 case M.lookup ref oldnotes of

355 Just _ -> logMessage $ DuplicateNoteReference ref pos

369 Just _ -> logMessage $ DuplicateNoteReference ref pos

@@ -399,11 +413,6 @@ lineBlock = try $ do

399-- lists

413-- lists

400--

414--

401

415

402−listLine :: PandocMonad m => Int -> MuseParser m String

403−listLine markerLength = try $ do

404− indentWith markerLength

405− manyTill anyChar eol

406−

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

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

408withListContext p = do

417withListContext p = do

409 state <- getState

418 state <- getState

@@ -413,66 +422,47 @@ withListContext p = do

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

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

414 return parsed

423 return parsed

415

424

416−listContinuation :: PandocMonad m => Int -> MuseParser m [String]

425+listItemContents :: PandocMonad m => MuseParser m (F Blocks)

417−listContinuation markerLength = try $ do

426+listItemContents = do

418− result <- many1 $ listLine markerLength

427+ pos <- getPosition

419− blank <- option id ((++ [""]) <$ blankline)

420− return $ blank result

421−

422−listStart :: PandocMonad m => MuseParser m Int -> MuseParser m Int

423−listStart marker = try $ do

424− preWhitespace <- length <$> many spaceChar

425− st <- stateParserContext <$> getState

426− getPosition >>= \pos -> guard (st == ListItemState || sourceColumn pos /= 1)

428+ let col = sourceColumn pos - 1

427− markerLength <- marker

429+ first <- try $ withListContext parseBlock

428− void spaceChar <|> eol

430+ rest <- many $ try (skipMany blankline >> indentWith col >> withListContext parseBlock)

429− return $ preWhitespace + markerLength + 1

431+ return $ mconcat (first : rest)

430−

431−dropSpacePrefix :: [String] -> [String]

432−dropSpacePrefix lns =

433− map (drop maxIndent) lns

434− where flns = filter (not . all (== ' ')) lns

435− maxIndent = if null flns then 0 else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns

436−

437−listItemContents :: PandocMonad m => Int -> MuseParser m (F Blocks)

438−listItemContents markerLength = do

439− firstLine <- manyTill anyChar eol

440− restLines <- many $ listLine markerLength

441− blank <- option id ((++ [""]) <$ blankline)

442− let first = firstLine : blank restLines

443− rest <- many $ listContinuation markerLength

444− let allLines = concat (first : rest)

445− parseFromString (withListContext parseBlocks) $ unlines (dropSpacePrefix allLines)

446−

447−listItem :: PandocMonad m => MuseParser m Int -> MuseParser m (F Blocks)

448−listItem start = try $ do

449− markerLength <- start

450− listItemContents markerLength

451−

452−bulletListItems :: PandocMonad m => MuseParser m (F [Blocks])

453−bulletListItems = sequence <$> many1 (listItem bulletListStart)

454

432

455−bulletListStart :: PandocMonad m => MuseParser m Int

433+listItem :: PandocMonad m => Int -> MuseParser m () -> MuseParser m (F Blocks)

456−bulletListStart = listStart (char '-' >> return 1)

434+listItem n p = try $ do

435+ optionMaybe blankline

436+ count n spaceChar

437+ p

438+ void spaceChar <|> lookAhead eol

439+ listItemContents

457

440

458bulletList :: PandocMonad m => MuseParser m (F Blocks)

441bulletList :: PandocMonad m => MuseParser m (F Blocks)

459−bulletList = do

442+bulletList = try $ do

460− listItems <- bulletListItems

443+ many spaceChar

444+ pos <- getPosition

445+ let col = sourceColumn pos

446+ guard $ col /= 1

447+ char '-'

448+ void spaceChar <|> lookAhead eol

449+ first <- listItemContents

450+ rest <- many $ listItem (col - 1) (void (char '-'))

461− return $ B.bulletList <$> listItems

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

462−

463−orderedListStart :: PandocMonad m

464− => ListNumberStyle

465− -> ListNumberDelim

466− -> MuseParser m Int

467−orderedListStart style delim = listStart (snd <$> withHorizDisplacement (orderedListMarker style delim))

468

452

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

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

470orderedList = try $ do

454orderedList = try $ do

455+ many spaceChar

456+ pos <- getPosition

457+ let col = sourceColumn pos

458+ guard $ col /= 1

471− p@(_, style, delim) <- lookAhead (many spaceChar *> anyOrderedListMarker <* (eol <|> void spaceChar))

459+ p@(_, style, delim) <- anyOrderedListMarker

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

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

473 guard $ delim == Period

461 guard $ delim == Period

474− items <- sequence <$> many1 (listItem $ orderedListStart style delim)

462+ void spaceChar <|> lookAhead eol

463+ first <- listItemContents

464+ rest <- many $ listItem (col - 1) (void (orderedListMarker style delim))

475− return $ B.orderedListWith p <$> items

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

476

466

477definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks]))

467definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks]))

478definitionListItem = try $ do

468definitionListItem = try $ do

@@ -482,7 +472,7 @@ definitionListItem = try $ do

482 string "::"

472 string "::"

483 firstLine <- manyTill anyChar eol

473 firstLine <- manyTill anyChar eol

484 restLines <- manyTill anyLine endOfListItemElement

474 restLines <- manyTill anyLine endOfListItemElement

485− let lns = dropWhile (== ' ') firstLine : dropSpacePrefix restLines

475+ let lns = dropWhile (== ' ') firstLine : restLines

486 lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns

476 lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns

487 pure $ do lineContent' <- lineContent

477 pure $ do lineContent' <- lineContent

488 term' <- term

478 term' <- term

@@ -501,8 +491,8 @@ definitionListItems = sequence <$> many1 definitionListItem

501

491

502definitionList :: PandocMonad m => MuseParser m (F Blocks)

492definitionList :: PandocMonad m => MuseParser m (F Blocks)

503definitionList = do

493definitionList = do

504− listItems <- definitionListItems

494+ items <- definitionListItems

505− return $ B.definitionList <$> listItems

495+ return $ B.definitionList <$> items

506

496

507--

497--

508-- tables

498-- tables

test/Tests/Readers/Muse.hs+52−17

@@ -161,6 +161,8 @@ tests =

161

162 , "Verbatim inside code" =: "<code><verbatim>foo</verbatim></code>" =?> para (code "<verbatim>foo</verbatim>")

163

164+ , "Verbatim tag after text" =: "Foo <verbatim>bar</verbatim>" =?> para "Foo bar"

165+

164 , testGroup "Links"

166 , testGroup "Links"

165 [ "Link without description" =:

167 [ "Link without description" =:

166 "[[https://amusewiki.org/]]" =?>

168 "[[https://amusewiki.org/]]" =?>

@@ -279,20 +281,12 @@ tests =

279 , " One two three"

281 , " One two three"

280 , ""

282 , ""

281 , "</verse>"

283 , "</verse>"

282− , "<verse>Foo bar</verse>"

283− , "<verse>"

284− , "Foo bar</verse>"

285− , "<verse>"

286− , " Foo</verse>"

287 ] =?>

284 ] =?>

288 lineBlock [ ""

285 lineBlock [ ""

289 , text "Foo bar baz"

286 , text "Foo bar baz"

290 , text "\160\160One two three"

287 , text "\160\160One two three"

291 , ""

288 , ""

292− ] <>

289+ ]

293− lineBlock [ "Foo bar" ] <>

294− lineBlock [ "Foo bar" ] <>

295− lineBlock [ "\160\160\160Foo" ]

296 , testGroup "Example"

290 , testGroup "Example"

297 [ "Braces on separate lines" =:

291 [ "Braces on separate lines" =:

298 T.unlines [ "{{{"

292 T.unlines [ "{{{"

@@ -356,6 +350,11 @@ tests =

356 , " </example>"

350 , " </example>"

357 ] =?>

351 ] =?>

358 bulletList [ codeBlock "foo" ]

352 bulletList [ codeBlock "foo" ]

353+ , "Empty example inside list" =:

354+ T.unlines [ " - <example>"

355+ , " </example>"

356+ ] =?>

357+ bulletList [ codeBlock "" ]

359 , "Example inside list with empty lines" =:

358 , "Example inside list with empty lines" =:

360 T.unlines [ " - <example>"

359 T.unlines [ " - <example>"

361 , " foo"

360 , " foo"

@@ -537,12 +536,14 @@ tests =

537 , "[1] First footnote paragraph"

536 , "[1] First footnote paragraph"

538 , ""

537 , ""

539 , " Second footnote paragraph"

538 , " Second footnote paragraph"

539+ , "with continuation"

540+ , ""

540 , "Not a note"

541 , "Not a note"

541 , "[2] Second footnote"

542 , "[2] Second footnote"

542 ] =?>

543 ] =?>

543 para (text "Multiparagraph" <>

544 para (text "Multiparagraph" <>

544 note (para "First footnote paragraph" <>

545 note (para "First footnote paragraph" <>

545− para "Second footnote paragraph") <>

546+ para "Second footnote paragraph\nwith continuation") <>

546 text " footnotes" <>

547 text " footnotes" <>

547 note (para "Second footnote")) <>

548 note (para "Second footnote")) <>

548 para (text "Not a note")

549 para (text "Not a note")

@@ -713,8 +714,48 @@ tests =

713 , mempty

714 , mempty

714 , para "Item3"

715 , para "Item3"

715 ]

716 ]

717+ , "Bullet list with last item empty" =:

718+ T.unlines

719+ [ " -"

720+ , ""

721+ , "foo"

722+ ] =?>

723+ bulletList [ mempty ] <>

724+ para "foo"

716 , testGroup "Nested lists"

725 , testGroup "Nested lists"

717− [ "Nested list" =:

726+ [ "Nested bullet list" =:

727+ T.unlines [ " - Item1"

728+ , " - Item2"

729+ , " - Item3"

730+ , " - Item4"

731+ , " - Item5"

732+ , " - Item6"

733+ ] =?>

734+ bulletList [ para "Item1" <>

735+ bulletList [ para "Item2" <>

736+ bulletList [ para "Item3" ]

737+ , para "Item4" <>

738+ bulletList [ para "Item5" ]

739+ ]

740+ , para "Item6"

741+ ]

742+ , "Nested ordered list" =:

743+ T.unlines [ " 1. Item1"

744+ , " 1. Item2"

745+ , " 1. Item3"

746+ , " 2. Item4"

747+ , " 1. Item5"

748+ , " 2. Item6"

749+ ] =?>

750+ orderedListWith (1, Decimal, Period) [ para "Item1" <>

751+ orderedListWith (1, Decimal, Period) [ para "Item2" <>

752+ orderedListWith (1, Decimal, Period) [ para "Item3" ]

753+ , para "Item4" <>

754+ orderedListWith (1, Decimal, Period) [ para "Item5" ]

755+ ]

756+ , para "Item6"

757+ ]

758+ , "Mixed nested list" =:

718 T.unlines

759 T.unlines

719 [ " - Item1"

760 [ " - Item1"

720 , " - Item2"

761 , " - Item2"

@@ -736,12 +777,6 @@ tests =

736 ]

777 ]

737 ]

778 ]

738 ]

779 ]

739− , "Incorrectly indented Text::Amuse nested list" =:

740− T.unlines

741− [ " - First item"

742− , " - Not nested item"

743− ] =?>

744− bulletList [ para "First item", para "Not nested item"]

745 , "Text::Amuse includes only one space in list marker" =:

780 , "Text::Amuse includes only one space in list marker" =:

746 T.unlines

781 T.unlines

747 [ " - First item"

782 [ " - First item"