@@ -84,24 +84,21 @@ data MuseState = MuseState { museMeta :: F Meta -- ^ Document metadata
8484 , museLastStrPos :: Maybe SourcePos -- ^ Position after last str parsed
8585 , museLogMessages :: [LogMessage]
8686 , museNotes :: M.Map String (SourcePos, F Blocks)
87− , museInLink :: Bool
88− , museInPara :: Bool
87+ , museInLink :: Bool -- ^ True when parsing a link description to avoid nested links
88+ , museInPara :: Bool -- ^ True when looking for a paragraph terminator
8989 }
9090
9191instance Default MuseState where
92− def = defaultMuseState
93−
94−defaultMuseState :: MuseState
95−defaultMuseState = MuseState { museMeta = return nullMeta
96− , museOptions = def
97− , museHeaders = M.empty
98− , museIdentifierList = Set.empty
99− , museLastStrPos = Nothing
100− , museLogMessages = []
101− , museNotes = M.empty
102− , museInLink = False
103− , museInPara = False
104− }
92+ def = MuseState { museMeta = return nullMeta
93+ , museOptions = def
94+ , museHeaders = M.empty
95+ , museIdentifierList = Set.empty
96+ , museLastStrPos = Nothing
97+ , museLogMessages = []
98+ , museNotes = M.empty
99+ , museInLink = False
100+ , museInPara = False
101+ }
105102
106103type MuseParser = ParserT String MuseState
107104
@@ -124,10 +121,7 @@ instance HasLogMessages MuseState where
124121 addLogMessage m s = s{ museLogMessages = m : museLogMessages s }
125122 getLogMessages = reverse . museLogMessages
126123
127−--
128−-- main parser
129−--
130−
124+-- | Parse Muse document
131125parseMuse :: PandocMonad m => MuseParser m Pandoc
132126parseMuse = do
133127 many directive
@@ -139,14 +133,56 @@ parseMuse = do
139133 reportLogMessages
140134 return doc
141135
142−--
143−-- utility functions
144−--
136+-- * Utility functions
137+
138+commonPrefix :: String -> String -> String
139+commonPrefix _ [] = []
140+commonPrefix [] _ = []
141+commonPrefix (x:xs) (y:ys)
142+ | x == y = x : commonPrefix xs ys
143+ | otherwise = []
144+
145+-- | Trim up to one newline from the beginning of the string.
146+lchop :: String -> String
147+lchop s = case s of
148+ '\n':ss -> ss
149+ _ -> s
150+
151+-- | Trim up to one newline from the end of the string.
152+rchop :: String -> String
153+rchop = reverse . lchop . reverse
154+
155+dropSpacePrefix :: [String] -> [String]
156+dropSpacePrefix lns =
157+ map (drop maxIndent) lns
158+ where flns = filter (not . all (== ' ')) lns
159+ maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns
160+
161+atStart :: PandocMonad m => MuseParser m a -> MuseParser m a
162+atStart p = do
163+ pos <- getPosition
164+ st <- getState
165+ guard $ museLastStrPos st /= Just pos
166+ p
167+
168+-- * Parsers
145169
170+-- | Parse end-of-line, which can be either a newline or end-of-file.
146171eol :: Stream s m Char => ParserT s st m ()
147172eol = void newline <|> eof
148173
149−htmlElement :: PandocMonad m => String -> MuseParser m (Attr, String)
174+someUntil :: (Stream s m t)
175+ => ParserT s u m a
176+ -> ParserT s u m b
177+ -> ParserT s u m ([a], b)
178+someUntil p end = first <$> ((:) <$> p) <*> manyUntil p end
179+
180+-- ** HTML parsers
181+
182+-- | Parse HTML tag, returning its attributes and literal contents.
183+htmlElement :: PandocMonad m
184+ => String -- ^ Tag name
185+ -> MuseParser m (Attr, String)
150186htmlElement tag = try $ do
151187 (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag [])
152188 content <- manyTill anyChar endtag
@@ -154,13 +190,16 @@ htmlElement tag = try $ do
154190 where
155191 endtag = void $ htmlTag (~== TagClose tag)
156192
157−htmlBlock :: PandocMonad m => String -> MuseParser m (Attr, String)
193+htmlBlock :: PandocMonad m
194+ => String -- ^ Tag name
195+ -> MuseParser m (Attr, String)
158196htmlBlock tag = try $ do
159197 many spaceChar
160198 res <- htmlElement tag
161199 manyTill spaceChar eol
162200 return res
163201
202+-- | Convert HTML attributes to Pandoc 'Attr'
164203htmlAttrToPandoc :: [Attribute String] -> Attr
165204htmlAttrToPandoc attrs = (ident, classes, keyvals)
166205 where
@@ -169,7 +208,8 @@ htmlAttrToPandoc attrs = (ident, classes, keyvals)
169208 keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
170209
171210parseHtmlContent :: PandocMonad m
172− => String -> MuseParser m (Attr, F Blocks)
211+ => String -- ^ Tag name
212+ -> MuseParser m (Attr, F Blocks)
173213parseHtmlContent tag = try $ do
174214 many spaceChar
175215 pos <- getPosition
@@ -181,29 +221,7 @@ parseHtmlContent tag = try $ do
181221 where
182222 endtag = void $ htmlTag (~== TagClose tag)
183223
184−commonPrefix :: String -> String -> String
185−commonPrefix _ [] = []
186−commonPrefix [] _ = []
187−commonPrefix (x:xs) (y:ys)
188− | x == y = x : commonPrefix xs ys
189− | otherwise = []
190−
191−atStart :: PandocMonad m => MuseParser m a -> MuseParser m a
192−atStart p = do
193− pos <- getPosition
194− st <- getState
195− guard $ museLastStrPos st /= Just pos
196− p
197−
198−someUntil :: (Stream s m t)
199− => ParserT s u m a
200− -> ParserT s u m b
201− -> ParserT s u m ([a], b)
202−someUntil p end = first <$> ((:) <$> p) <*> manyUntil p end
203−
204−--
205−-- directive parsers
206−--
224+-- ** Directive parsers
207225
208226-- While not documented, Emacs Muse allows "-" in directive name
209227parseDirectiveKey :: PandocMonad m => MuseParser m String
@@ -234,9 +252,7 @@ directive = do
234252 where translateKey "cover" = "cover-image"
235253 translateKey x = x
236254
237−--
238−-- block parsers
239−--
255+-- ** Block parsers
240256
241257parseBlocks :: PandocMonad m
242258 => MuseParser m (F Blocks)
@@ -329,6 +345,7 @@ blockElements = do
329345 , commentTag
330346 ]
331347
348+-- | Parse a line comment, starting with @;@ in the first column.
332349comment :: PandocMonad m => MuseParser m (F Blocks)
333350comment = try $ do
334351 char ';'
@@ -336,6 +353,7 @@ comment = try $ do
336353 eol
337354 return mempty
338355
356+-- | Parse a horizontal rule, consisting of 4 or more @\'-\'@ characters.
339357separator :: PandocMonad m => MuseParser m (F Blocks)
340358separator = try $ do
341359 string "----"
@@ -344,6 +362,7 @@ separator = try $ do
344362 eol
345363 return $ return B.horizontalRule
346364
365+-- | Parse a heading.
347366header :: PandocMonad m => MuseParser m (F Blocks)
348367header = try $ do
349368 anchorId <- option "" $ try (parseAnchor <* manyTill spaceChar eol)
@@ -355,6 +374,8 @@ header = try $ do
355374 attr <- registerHeader (anchorId, [], []) (runF content def)
356375 return $ B.headerWith attr level <$> content
357376
377+-- | Parse an example between @{{{@ and @}}}@.
378+-- It is an Amusewiki extension influenced by Creole wiki, as described in @Text::Amuse@ documentation.
358379example :: PandocMonad m => MuseParser m (F Blocks)
359380example = try $ do
360381 string "{{{"
@@ -362,27 +383,14 @@ example = try $ do
362383 contents <- manyTill anyChar $ try (optional blankline >> string "}}}")
363384 return $ return $ B.codeBlock contents
364385
365−-- Trim up to one newline from the beginning of the string.
366−lchop :: String -> String
367−lchop s = case s of
368− '\n':ss -> ss
369− _ -> s
370−
371−-- Trim up to one newline from the end of the string.
372−rchop :: String -> String
373−rchop = reverse . lchop . reverse
374−
375−dropSpacePrefix :: [String] -> [String]
376−dropSpacePrefix lns =
377− map (drop maxIndent) lns
378− where flns = filter (not . all (== ' ')) lns
379− maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns
380−
386+-- | Parse an @\<example>@ tag.
381387exampleTag :: PandocMonad m => MuseParser m (F Blocks)
382388exampleTag = try $ do
383389 (attr, contents) <- htmlBlock "example"
384390 return $ return $ B.codeBlockWith attr $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop contents
385391
392+-- | Parse a @\<literal>@ tag as a raw block.
393+-- For 'RawInline' @\<literal>@ parser, see 'inlineLiteralTag'.
386394literalTag :: PandocMonad m => MuseParser m (F Blocks)
387395literalTag = try $ do
388396 many spaceChar
@@ -397,30 +405,36 @@ literalTag = try $ do
397405 format (_, _, kvs) = fromMaybe "html" $ lookup "style" kvs
398406 rawBlock (attrs, content) = B.rawBlock (format attrs) $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content
399407
400−-- <center> tag is ignored
408+-- | Parse @\<center>@ tag.
409+-- Currently it is ignored as Pandoc cannot represent centered blocks.
401410centerTag :: PandocMonad m => MuseParser m (F Blocks)
402411centerTag = snd <$> parseHtmlContent "center"
403412
404−-- <right> tag is ignored
413+-- | Parse @\<right>@ tag.
414+-- Currently it is ignored as Pandoc cannot represent centered blocks.
405415rightTag :: PandocMonad m => MuseParser m (F Blocks)
406416rightTag = snd <$> parseHtmlContent "right"
407417
418+-- | Parse @\<quote>@ tag.
408419quoteTag :: PandocMonad m => MuseParser m (F Blocks)
409420quoteTag = fmap B.blockQuote . snd <$> parseHtmlContent "quote"
410421
411−-- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025
422+-- | Parse @\<div>@ tag.
423+-- @\<div>@ tag is supported by Emacs Muse, but not Amusewiki 2.025.
412424divTag :: PandocMonad m => MuseParser m (F Blocks)
413425divTag = do
414426 (attrs, content) <- parseHtmlContent "div"
415427 return $ B.divWith attrs <$> content
416428
417−-- <biblio> tag is supported by Amusewiki only
429+-- | Parse @\<biblio>@ tag, the result is the same as @\<div class="biblio">@.
430+-- @\<biblio>@ tag is supported only in Text::Amuse mode.
418431biblioTag :: PandocMonad m => MuseParser m (F Blocks)
419432biblioTag = do
420433 guardEnabled Ext_amuse
421434 fmap (B.divWith ("", ["biblio"], [])) . snd <$> parseHtmlContent "biblio"
422435
423−-- <play> tag is supported by Amusewiki only
436+-- | Parse @\<play>@ tag, the result is the same as @\<div class="play">@.
437+-- @\<play>@ tag is supported only in Text::Amuse mode.
424438playTag :: PandocMonad m => MuseParser m (F Blocks)
425439playTag = do
426440 guardEnabled Ext_amuse
@@ -437,17 +451,19 @@ verseLines = do
437451 lns <- many verseLine
438452 return $ B.lineBlock <$> sequence lns
439453
454+-- | Parse @\<verse>@ tag.
440455verseTag :: PandocMonad m => MuseParser m (F Blocks)
441456verseTag = do
442457 (_, content) <- htmlBlock "verse"
443458 parseFromString verseLines (intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content)
444459
460+-- | Parse @\<comment>@ tag.
445461commentTag :: PandocMonad m => MuseParser m (F Blocks)
446462commentTag = htmlBlock "comment" >> return mempty
447463
448−-- Indented paragraph is either center, right or quote
464+-- | Parse a paragraph.
449465paraUntil :: PandocMonad m
450− => MuseParser m a
466+ => MuseParser m a -- ^ Terminator parser
451467 -> MuseParser m (F Blocks, a)
452468paraUntil end = do
453469 state <- getState
@@ -514,19 +530,18 @@ blanklineVerseLine = try $ do
514530 blankline
515531 pure mempty
516532
533+-- | Parse a line block indicated by @\'>\'@ characters.
517534lineBlock :: PandocMonad m => MuseParser m (F Blocks)
518535lineBlock = try $ do
519536 col <- sourceColumn <$> getPosition
520537 lns <- (blanklineVerseLine <|> lineVerseLine) `sepBy1'` try (indentWith (col - 1))
521538 return $ B.lineBlock <$> sequence lns
522539
523−--
524−-- lists
525−--
540+-- *** List parsers
526541
527542bulletListItemsUntil :: PandocMonad m
528− => Int
529− -> MuseParser m a
543+ => Int -- ^ Indentation
544+ -> MuseParser m a -- ^ Terminator parser
530545 -> MuseParser m ([F Blocks], a)
531546bulletListItemsUntil indent end = try $ do
532547 char '-'
@@ -537,6 +552,7 @@ bulletListItemsUntil indent end = try $ do
537552 Left ee -> return ([x], ee)
538553 Right (xs, ee) -> return (x:xs, ee)
539554
555+-- | Parse a bullet list.
540556bulletListUntil :: PandocMonad m
541557 => MuseParser m a
542558 -> MuseParser m (F Blocks, a)
@@ -585,6 +601,7 @@ orderedListItemsUntil indent style end =
585601 Left ee -> return ([x], ee)
586602 Right (xs, ee) -> return (x:xs, ee)
587603
604+-- | Parse an ordered list.
588605orderedListUntil :: PandocMonad m
589606 => MuseParser m a
590607 -> MuseParser m (F Blocks, a)
@@ -629,8 +646,9 @@ definitionListItemsUntil indent end =
629646 Left ee -> return ([xx], ee)
630647 Right (xs, ee) -> return (xx:xs, ee)
631648
649+-- | Parse a definition list.
632650definitionListUntil :: PandocMonad m
633− => MuseParser m a
651+ => MuseParser m a -- ^ Terminator parser
634652 -> MuseParser m (F Blocks, a)
635653definitionListUntil end = try $ do
636654 many spaceChar
@@ -640,15 +658,14 @@ definitionListUntil end = try $ do
640658 first (fmap B.definitionList . sequence) <$> definitionListItemsUntil indent end
641659
642660anyListUntil :: PandocMonad m
643− => MuseParser m a
661+ => MuseParser m a -- ^ Terminator parser
644662 -> MuseParser m (F Blocks, a)
645663anyListUntil end =
646664 bulletListUntil end <|> orderedListUntil end <|> definitionListUntil end
647665
648−--
649−-- tables
650−--
666+-- *** Table parsers
651667
668+-- | Internal Muse table representation.
652669data MuseTable = MuseTable
653670 { museTableCaption :: Inlines
654671 , museTableHeaders :: [[Blocks]]
@@ -698,6 +715,7 @@ elementsToTable :: [MuseTableElement] -> F MuseTable
698715elementsToTable = foldM museAppendElement emptyTable
699716 where emptyTable = MuseTable mempty mempty mempty mempty
700717
718+-- | Parse a table.
701719table :: PandocMonad m => MuseParser m (F Blocks)
702720table = try $ fmap museToPandocTable <$> (elementsToTable <$> tableElements)
703721
@@ -707,31 +725,35 @@ tableParseElement = tableParseHeader
707725 <|> tableParseFooter
708726 <|> tableParseCaption
709727
710−tableParseRow :: PandocMonad m => Int -> MuseParser m (F [Blocks])
728+tableParseRow :: PandocMonad m
729+ => Int -- ^ Number of separator characters
730+ -> MuseParser m (F [Blocks])
711731tableParseRow n = try $ do
712732 fields <- tableCell `sepBy2` fieldSep
713733 return $ sequence fields
714734 where p `sepBy2` sep = (:) <$> p <*> many1 (sep >> p)
715735 fieldSep = many1 spaceChar >> count n (char '|') >> (void (many1 spaceChar) <|> void (lookAhead newline))
716736
737+-- | Parse a table header row.
717738tableParseHeader :: PandocMonad m => MuseParser m MuseTableElement
718739tableParseHeader = MuseHeaderRow <$> tableParseRow 2
719740
741+-- | Parse a table body row.
720742tableParseBody :: PandocMonad m => MuseParser m MuseTableElement
721743tableParseBody = MuseBodyRow <$> tableParseRow 1
722744
745+-- | Parse a table footer row.
723746tableParseFooter :: PandocMonad m => MuseParser m MuseTableElement
724747tableParseFooter = MuseFooterRow <$> tableParseRow 3
725748
749+-- | Parse table caption.
726750tableParseCaption :: PandocMonad m => MuseParser m MuseTableElement
727751tableParseCaption = try $ do
728752 many spaceChar
729753 string "|+"
730754 MuseCaption <$> (trimInlinesF . mconcat <$> many1Till inline (string "+|"))
731755
732−--
733−-- inline parsers
734−--
756+-- ** Inline parsers
735757
736758inlineList :: PandocMonad m => [MuseParser m (F Inlines)]
737759inlineList = [ whitespace
@@ -761,6 +783,7 @@ inlineList = [ whitespace
761783inline :: PandocMonad m => MuseParser m (F Inlines)
762784inline = endline <|> choice inlineList <?> "inline"
763785
786+-- | Parse a soft break.
764787endline :: PandocMonad m => MuseParser m (F Inlines)
765788endline = try $ do
766789 newline
@@ -779,6 +802,7 @@ anchor = try $ do
779802 skipMany spaceChar <|> void newline
780803 return $ return $ B.spanWith (anchorId, [], []) mempty
781804
805+-- | Parse a footnote reference.
782806footnote :: PandocMonad m => MuseParser m (F Inlines)
783807footnote = try $ do
784808 ref <- noteMarker
@@ -796,6 +820,7 @@ whitespace = try $ do
796820 skipMany1 spaceChar
797821 return $ return B.space
798822
823+-- | Parse @\<br>@ tag.
799824br :: PandocMonad m => MuseParser m (F Inlines)
800825br = try $ do
801826 string "<br>"
@@ -811,42 +836,54 @@ enclosedInlines :: (PandocMonad m, Show a, Show b)
811836enclosedInlines start end = try $
812837 trimInlinesF . mconcat <$> (enclosed (atStart start) end inline <* notFollowedBy (satisfy isLetter))
813838
839+-- | Parse an inline tag, such as @\<em>@ and @\<strong>@.
814840inlineTag :: PandocMonad m
815− => String
841+ => String -- ^ Tag name
816842 -> MuseParser m (F Inlines)
817843inlineTag tag = try $ do
818844 htmlTag (~== TagOpen tag [])
819845 mconcat <$> manyTill inline (void $ htmlTag (~== TagClose tag))
820846
821−strongTag :: PandocMonad m => MuseParser m (F Inlines)
822−strongTag = fmap B.strong <$> inlineTag "strong"
823−
847+-- | Parse strong inline markup, indicated by @**@.
824848strong :: PandocMonad m => MuseParser m (F Inlines)
825849strong = fmap B.strong <$> emphasisBetween (string "**")
826850
851+-- | Parse emphasis inline markup, indicated by @*@.
827852emph :: PandocMonad m => MuseParser m (F Inlines)
828853emph = fmap B.emph <$> emphasisBetween (char '*')
829854
855+-- | Parse underline inline markup, indicated by @_@.
856+-- Supported only in Emacs Muse mode, not Text::Amuse.
830857underlined :: PandocMonad m => MuseParser m (F Inlines)
831858underlined = do
832859 guardDisabled Ext_amuse -- Supported only by Emacs Muse
833860 fmap underlineSpan <$> emphasisBetween (char '_')
834861
862+-- | Parse @\<strong>@ tag.
863+strongTag :: PandocMonad m => MuseParser m (F Inlines)
864+strongTag = fmap B.strong <$> inlineTag "strong"
865+
866+-- | Parse @\<em>@ tag.
835867emphTag :: PandocMonad m => MuseParser m (F Inlines)
836868emphTag = fmap B.emph <$> inlineTag "em"
837869
870+-- | Parse @\<sup>@ tag.
838871superscriptTag :: PandocMonad m => MuseParser m (F Inlines)
839872superscriptTag = fmap B.superscript <$> inlineTag "sup"
840873
874+-- | Parse @\<sub>@ tag.
841875subscriptTag :: PandocMonad m => MuseParser m (F Inlines)
842876subscriptTag = fmap B.subscript <$> inlineTag "sub"
843877
878+-- | Parse @\<del>@ tag.
844879strikeoutTag :: PandocMonad m => MuseParser m (F Inlines)
845880strikeoutTag = fmap B.strikeout <$> inlineTag "del"
846881
882+-- | Parse @\<verbatim>@ tag.
847883verbatimTag :: PandocMonad m => MuseParser m (F Inlines)
848884verbatimTag = return . B.text . snd <$> htmlElement "verbatim"
849885
886+-- | Parse @\<class>@ tag.
850887classTag :: PandocMonad m => MuseParser m (F Inlines)
851888classTag = do
852889 (TagOpen _ attrs, _) <- htmlTag (~== TagOpen "class" [])
@@ -854,11 +891,13 @@ classTag = do
854891 let classes = maybe [] words $ lookup "name" attrs
855892 return $ B.spanWith ("", classes, []) <$> mconcat res
856893
894+-- | Parse "~~" as nonbreaking space.
857895nbsp :: PandocMonad m => MuseParser m (F Inlines)
858896nbsp = try $ do
859897 string "~~"
860898 return $ return $ B.str "\160"
861899
900+-- | Parse code markup, indicated by @\'=\'@ characters.
862901code :: PandocMonad m => MuseParser m (F Inlines)
863902code = try $ do
864903 atStart $ char '='
@@ -869,13 +908,16 @@ code = try $ do
869908 notFollowedBy $ satisfy isLetter
870909 return $ return $ B.code contents
871910
911+-- | Parse @\<code>@ tag.
872912codeTag :: PandocMonad m => MuseParser m (F Inlines)
873913codeTag = return . uncurry B.codeWith <$> htmlElement "code"
874914
875−-- <math> tag is an Emacs Muse extension enabled by (require 'muse-latex2png)
915+-- | Parse @\<math>@ tag.
916+-- @\<math>@ tag is an Emacs Muse extension enabled by @(require 'muse-latex2png)@
876917mathTag :: PandocMonad m => MuseParser m (F Inlines)
877918mathTag = return . B.math . snd <$> htmlElement "math"
878919
920+-- | Parse inline @\<literal>@ tag as a raw inline.
879921inlineLiteralTag :: PandocMonad m => MuseParser m (F Inlines)
880922inlineLiteralTag =
881923 (return . rawInline) <$> htmlElement "literal"
@@ -890,6 +932,7 @@ str = return . B.str <$> many1 alphaNum <* updateLastStrPos
890932symbol :: PandocMonad m => MuseParser m (F Inlines)
891933symbol = return . B.str <$> count 1 nonspaceChar
892934
935+-- | Parse a link or image.
893936link :: PandocMonad m => MuseParser m (F Inlines)
894937link = try $ do
895938 st <- getState