@@ -47,7 +47,7 @@ import Data.List (stripPrefix, intercalate)
4747import Data.List.Split (splitOn)
4848import qualified Data.Map as M
4949import qualified Data.Set as Set
50−import Data.Maybe (fromMaybe)
50+import Data.Maybe (fromMaybe, isNothing)
5151import Data.Text (Text, unpack)
5252import System.FilePath (takeExtension)
5353import Text.HTML.TagSoup
@@ -82,6 +82,7 @@ data MuseState = MuseState { museMeta :: F Meta -- ^ Document metadata
8282 , museLogMessages :: [LogMessage]
8383 , museNotes :: M.Map String (SourcePos, F Blocks)
8484 , museInLink :: Bool
85+ , museInPara :: Bool
8586 }
8687
8788instance Default MuseState where
@@ -96,6 +97,7 @@ defaultMuseState = MuseState { museMeta = return nullMeta
9697 , museLogMessages = []
9798 , museNotes = M.empty
9899 , museInLink = False
100+ , museInPara = False
99101 }
100102
101103type MuseParser = ParserT String MuseState
@@ -149,6 +151,12 @@ htmlElement tag = try $ do
149151 where
150152 endtag = void $ htmlTag (~== TagClose tag)
151153
154+htmlBlock :: PandocMonad m => String -> MuseParser m (Attr, String)
155+htmlBlock tag = try $ do
156+ res <- htmlElement tag
157+ manyTill spaceChar eol
158+ return res
159+
152160htmlAttrToPandoc :: [Attribute String] -> Attr
153161htmlAttrToPandoc attrs = (ident, classes, keyvals)
154162 where
@@ -159,13 +167,13 @@ htmlAttrToPandoc attrs = (ident, classes, keyvals)
159167parseHtmlContent :: PandocMonad m
160168 => String -> MuseParser m (Attr, F Blocks)
161169parseHtmlContent tag = do
162− (attr, content) <- htmlElement tag
163− parsedContent <- parseContent (content ++ "\n")
170+ (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag [])
171+ manyTill spaceChar eol
172+ content <- parseBlocksTill (manyTill spaceChar endtag)
164173 manyTill spaceChar eol -- closing tag must be followed by optional whitespace and newline
165− return (attr, mconcat parsedContent)
174+ return (htmlAttrToPandoc attr, content)
166175 where
167− parseContent = parseFromString $ manyTill parseBlock endOfContent
168− endOfContent = try $ skipMany blankline >> skipSpaces >> eof
176+ endtag = void $ htmlTag (~== TagClose tag)
169177
170178commonPrefix :: String -> String -> String
171179commonPrefix _ [] = []
@@ -248,19 +256,85 @@ directive = do
248256parseBlocks :: PandocMonad m
249257 => MuseParser m (F Blocks)
250258parseBlocks =
251− try (mempty <$ eof) <|>
259+ try parseEnd <|>
252260 try blockStart <|>
261+ try listStart <|>
253262 try paraStart
254263 where
264+ parseEnd = mempty <$ eof
255265 blockStart = do first <- header <|> blockElements <|> amuseNoteBlock <|> emacsNoteBlock
256266 rest <- parseBlocks
257267 return $ first B.<> rest
268+ listStart = do
269+ st <- getState
270+ setState $ st{ museInPara = False }
271+ (first, rest) <- anyListUntil parseBlocks
272+ return $ first B.<> rest
258273 paraStart = do
259274 indent <- length <$> many spaceChar
260− (first, rest) <- paraUntil ((mempty <$ eof) <|> blockStart)
275+ (first, rest) <- paraUntil parseBlocks
261276 let first' = if indent >= 2 && indent < 6 then B.blockQuote <$> first else first
262277 return $ first' B.<> rest
263278
279+parseBlocksTill :: PandocMonad m
280+ => MuseParser m a
281+ -> MuseParser m (F Blocks)
282+parseBlocksTill end =
283+ try parseEnd <|>
284+ try blockStart <|>
285+ try listStart <|>
286+ try paraStart
287+ where
288+ parseEnd = mempty <$ end
289+ blockStart = do first <- blockElements
290+ rest <- continuation
291+ return $ first B.<> rest
292+ listStart = do
293+ st <- getState
294+ setState $ st{ museInPara = False }
295+ (first, e) <- anyListUntil ((Left <$> end) <|> (Right <$> continuation))
296+ case e of
297+ Left _ -> return first
298+ Right rest -> return $ first B.<> rest
299+ paraStart = do (first, e) <- paraUntil ((Left <$> end) <|> (Right <$> continuation))
300+ case e of
301+ Left _ -> return $ first
302+ Right rest -> return $ first B.<> rest
303+ continuation = parseBlocksTill end
304+
305+listItemContentsUntil :: PandocMonad m
306+ => Int
307+ -> MuseParser m a
308+ -> MuseParser m (F Blocks, a)
309+listItemContentsUntil col end =
310+ try blockStart <|>
311+ try listStart <|>
312+ try paraStart
313+ where
314+ parseEnd = do e <- end
315+ return (mempty, e)
316+ paraStart = do
317+ (first, e) <- paraUntil ((Right <$> continuation) <|> (Left <$> end))
318+ case e of
319+ Left ee -> return (first, ee)
320+ Right (rest, ee) -> return (first B.<> rest, ee)
321+ blockStart = do first <- blockElements
322+ (rest, e) <- continuation <|> parseEnd
323+ return (first B.<> rest, e)
324+ listStart = do
325+ st <- getState
326+ setState $ st{ museInPara = False }
327+ (first, e) <- anyListUntil ((Right <$> continuation) <|> (Left <$> end))
328+ case e of
329+ Left ee -> return (first, ee)
330+ Right (rest, ee) -> return $ (first B.<> rest, ee)
331+ continuation = try $ do blank <- optionMaybe blankline
332+ skipMany blankline
333+ indentWith col
334+ st <- getState
335+ setState $ st{ museInPara = museInPara st && isNothing blank }
336+ listItemContentsUntil col end
337+
264338parseBlock :: PandocMonad m => MuseParser m (F Blocks)
265339parseBlock = do
266340 res <- blockElements <|> para
@@ -269,24 +343,24 @@ parseBlock = do
269343 where para = fst <$> paraUntil (try (eof <|> void (lookAhead blockElements)))
270344
271345blockElements :: PandocMonad m => MuseParser m (F Blocks)
272−blockElements = choice [ mempty <$ blankline
273− , comment
274− , separator
275− , example
276− , exampleTag
277− , literalTag
278− , centerTag
279− , rightTag
280− , quoteTag
281− , divTag
282− , verseTag
283− , lineBlock
284− , bulletList
285− , orderedList
286− , definitionList
287− , table
288− , commentTag
289− ]
346+blockElements = do
347+ st <- getState
348+ setState $ st{ museInPara = False }
349+ choice [ mempty <$ blankline
350+ , comment
351+ , separator
352+ , example
353+ , exampleTag
354+ , literalTag
355+ , centerTag
356+ , rightTag
357+ , quoteTag
358+ , divTag
359+ , verseTag
360+ , lineBlock
361+ , table
362+ , commentTag
363+ ]
290364
291365comment :: PandocMonad m => MuseParser m (F Blocks)
292366comment = try $ do
@@ -343,13 +417,13 @@ dropSpacePrefix lns =
343417exampleTag :: PandocMonad m => MuseParser m (F Blocks)
344418exampleTag = try $ do
345419 many spaceChar
346− (attr, contents) <- htmlElement "example"
420+ (attr, contents) <- htmlBlock "example"
347421 return $ return $ B.codeBlockWith attr $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop contents
348422
349423literalTag :: PandocMonad m => MuseParser m (F Blocks)
350424literalTag = do
351425 guardDisabled Ext_amuse -- Text::Amuse does not support <literal>
352− (return . rawBlock) <$> htmlElement "literal"
426+ (return . rawBlock) <$> htmlBlock "literal"
353427 where
354428 -- FIXME: Emacs Muse inserts <literal> without style into all output formats, but we assume HTML
355429 format (_, _, kvs) = fromMaybe "html" $ lookup "style" kvs
@@ -385,18 +459,22 @@ verseLines = do
385459
386460verseTag :: PandocMonad m => MuseParser m (F Blocks)
387461verseTag = do
388− (_, content) <- htmlElement "verse"
462+ (_, content) <- htmlBlock "verse"
389463 parseFromString verseLines (intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content)
390464
391465commentTag :: PandocMonad m => MuseParser m (F Blocks)
392−commentTag = htmlElement "comment" >> return mempty
466+commentTag = htmlBlock "comment" >> return mempty
393467
394468-- Indented paragraph is either center, right or quote
395469paraUntil :: PandocMonad m
396470 => MuseParser m a
397471 -> MuseParser m (F Blocks, a)
398472paraUntil end = do
473+ state <- getState
474+ guard $ not $ museInPara state
475+ setState $ state{ museInPara = True }
399476 (l, e) <- someUntil inline $ try (manyTill spaceChar eol >> end)
477+ updateState (\st -> st { museInPara = False })
400478 return (fmap (B.para) $ trimInlinesF $ mconcat l, e)
401479
402480noteMarker :: PandocMonad m => MuseParser m String
@@ -413,6 +491,8 @@ amuseNoteBlock = try $ do
413491 guardEnabled Ext_amuse
414492 pos <- getPosition
415493 ref <- noteMarker <* spaceChar
494+ st <- getState
495+ setState $ st{ museInPara = False }
416496 content <- listItemContents
417497 oldnotes <- museNotes <$> getState
418498 case M.lookup ref oldnotes of
@@ -465,35 +545,36 @@ lineBlock = try $ do
465545-- lists
466546--
467547
468−listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks)
469−listItemContents' col =
470− mconcat <$> parseBlock `sepBy1` try (skipMany blankline >> indentWith col)
548+bulletListItemsUntil :: PandocMonad m
549+ => Int
550+ -> MuseParser m a
551+ -> MuseParser m ([F Blocks], a)
552+bulletListItemsUntil indent end = try $ do
553+ char '-'
554+ void spaceChar <|> lookAhead eol
555+ st <- getState
556+ setState $ st{ museInPara = False }
557+ (x, e) <- listItemContentsUntil (indent + 2) ((Right <$> try (optional blankline >> indentWith indent >> bulletListItemsUntil indent end)) <|> (Left <$> end))
558+ case e of
559+ Left ee -> return ([x], ee)
560+ Right (xs, ee) -> return (x:xs, ee)
561+
562+bulletListUntil :: PandocMonad m
563+ => MuseParser m a
564+ -> MuseParser m (F Blocks, a)
565+bulletListUntil end = try $ do
566+ many spaceChar
567+ pos <- getPosition
568+ let indent = sourceColumn pos - 1
569+ guard $ indent /= 0
570+ (items, e) <- bulletListItemsUntil indent end
571+ return $ (B.bulletList <$> sequence items, e)
471572
472573listItemContents :: PandocMonad m => MuseParser m (F Blocks)
473574listItemContents = do
474575 pos <- getPosition
475576 let col = sourceColumn pos - 1
476− listItemContents' col
477−
478−listItem :: PandocMonad m => Int -> MuseParser m a -> MuseParser m (F Blocks)
479−listItem n p = try $ do
480− optional blankline
481− count n spaceChar
482− p
483− void spaceChar <|> lookAhead eol
484− listItemContents
485−
486−bulletList :: PandocMonad m => MuseParser m (F Blocks)
487−bulletList = try $ do
488− many spaceChar
489− pos <- getPosition
490− let col = sourceColumn pos
491− guard $ col /= 1
492− char '-'
493− void spaceChar <|> lookAhead eol
494− first <- listItemContents
495− rest <- many $ listItem (col - 1) (char '-')
496− return $ B.bulletList <$> sequence (first : rest)
577+ mconcat <$> parseBlock `sepBy1` try (skipMany blankline >> indentWith col)
497578
498579-- | Parses an ordered list marker and returns list attributes.
499580anyMuseOrderedListMarker :: PandocMonad m => MuseParser m ListAttributes
@@ -516,38 +597,74 @@ museOrderedListMarker style = do
516597 char '.'
517598 return start
518599
519−orderedList :: PandocMonad m => MuseParser m (F Blocks)
520−orderedList = try $ do
600+orderedListItemsUntil :: PandocMonad m
601+ => Int
602+ -> ListNumberStyle
603+ -> MuseParser m a
604+ -> MuseParser m ([F Blocks], a)
605+orderedListItemsUntil indent style end =
606+ continuation
607+ where
608+ continuation = try $ do
609+ pos <- getPosition
610+ void spaceChar <|> lookAhead eol
611+ st <- getState
612+ setState $ st{ museInPara = False }
613+ (x, e) <- listItemContentsUntil (sourceColumn pos) ((Right <$> try (optionMaybe blankline >> indentWith indent >> museOrderedListMarker style >> continuation)) <|> (Left <$> end))
614+ case e of
615+ Left ee -> return ([x], ee)
616+ Right (xs, ee) -> return (x:xs, ee)
617+
618+orderedListUntil :: PandocMonad m
619+ => MuseParser m a
620+ -> MuseParser m (F Blocks, a)
621+orderedListUntil end = try $ do
521622 many spaceChar
522623 pos <- getPosition
523− let col = sourceColumn pos
524− guard $ col /= 1
624+ let indent = sourceColumn pos - 1
625+ guard $ indent /= 0
525626 p@(_, style, _) <- anyMuseOrderedListMarker
526627 guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]
527− void spaceChar <|> lookAhead eol
528− first <- listItemContents
529− rest <- many $ listItem (col - 1) (museOrderedListMarker style)
530− return $ B.orderedListWith p <$> sequence (first : rest)
531−
532−definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks]))
533−definitionListItem = try $ do
534− pos <- getPosition
535− term <- trimInlinesF . mconcat <$> manyTill (choice inlineList) (string "::")
536− void spaceChar <|> lookAhead eol
537− contents <- listItemContents' $ sourceColumn pos
538− pure $ do lineContent' <- contents
539− term' <- term
540− pure (term', [lineContent'])
541−
542−definitionList :: PandocMonad m => MuseParser m (F Blocks)
543−definitionList = try $ do
628+ (items, e) <- orderedListItemsUntil indent style end
629+ return $ (B.orderedListWith p <$> sequence items, e)
630+
631+definitionListItemsUntil :: PandocMonad m
632+ => Int
633+ -> MuseParser m a
634+ -> MuseParser m ([F (Inlines, [Blocks])], a)
635+definitionListItemsUntil indent end =
636+ continuation
637+ where continuation = try $ do
638+ pos <- getPosition
639+ term <- trimInlinesF . mconcat <$> manyTill (choice inlineList) (string "::")
640+ void spaceChar <|> lookAhead eol
641+ st <- getState
642+ setState $ st{ museInPara = False }
643+ (x, e) <- listItemContentsUntil (sourceColumn pos) ((Right <$> try (optional blankline >> count indent spaceChar >> continuation)) <|> (Left <$> end))
644+ let xx = do
645+ term' <- term
646+ x' <- x
647+ (return (term', [x']))::(F (Inlines, [Blocks]))
648+ case e of
649+ Left ee -> return $ ([xx], ee)
650+ Right (xs, ee) -> return $ (xx : xs, ee)
651+
652+definitionListUntil :: PandocMonad m
653+ => MuseParser m a
654+ -> MuseParser m (F Blocks, a)
655+definitionListUntil end = try $ do
544656 many spaceChar
545657 pos <- getPosition
546658 let indent = sourceColumn pos - 1
547659 guardDisabled Ext_amuse <|> guard (indent /= 0) -- Initial space is required by Amusewiki, but not Emacs Muse
548− first <- definitionListItem
549− rest <- many $ try (optional blankline >> count indent spaceChar >> definitionListItem)
550− return $ B.definitionList <$> sequence (first : rest)
660+ (items, e) <- definitionListItemsUntil indent end
661+ return (B.definitionList <$> sequence items, e)
662+
663+anyListUntil :: PandocMonad m
664+ => MuseParser m a
665+ -> MuseParser m (F Blocks, a)
666+anyListUntil end =
667+ bulletListUntil end <|> orderedListUntil end <|> definitionListUntil end
551668
552669--
553670-- tables