@@ -39,39 +39,38 @@ import Text.Pandoc.Parsing hiding (enclosed, macro, nested)
3939import Text.Pandoc.Readers.HTML (htmlTag, isCommentTag)
4040import Control.Monad
4141import Text.Printf (printf)
42−import Debug.Trace (trace)
4342import Text.Pandoc.XML (fromEntities)
4443import Data.Maybe (fromMaybe)
4544import Text.HTML.TagSoup
4645import Data.Char (isAlphaNum)
4746import qualified Data.Foldable as F
4847import Control.Monad.Except (throwError)
49−import Text.Pandoc.Class (PandocMonad)
48+import Text.Pandoc.Class (PandocMonad, report)
5049
5150-- | Read twiki from an input string and return a Pandoc document.
5251readTWiki :: PandocMonad m
5352 => ReaderOptions
5453 -> String
5554 -> m Pandoc
56−readTWiki opts s =
57− case (readWith parseTWiki) def{ stateOptions = opts } (s ++ "\n\n") of
55+readTWiki opts s = do
56+ res <- readWithM parseTWiki def{ stateOptions = opts } (s ++ "\n\n")
57+ case res of
5858 Left e -> throwError e
5959 Right d -> return d
6060
61−
62−type TWParser = Parser [Char] ParserState
61+type TWParser = ParserT [Char] ParserState
6362
6463--
6564-- utility functions
6665--
6766
68−tryMsg :: String -> TWParser a -> TWParser a
67+tryMsg :: String -> TWParser m a -> TWParser m a
6968tryMsg msg p = try p <?> msg
7069
71−skip :: TWParser a -> TWParser ()
70+skip :: TWParser m a -> TWParser m ()
7271skip parser = parser >> return ()
7372
74−nested :: TWParser a -> TWParser a
73+nested :: PandocMonad m => TWParser m a -> TWParser m a
7574nested p = do
7675 nestlevel <- stateMaxNestingLevel <$> getState
7776 guard $ nestlevel > 0
@@ -80,7 +79,7 @@ nested p = do
8079 updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
8180 return res
8281
83−htmlElement :: String -> TWParser (Attr, String)
82+htmlElement :: PandocMonad m => String -> TWParser m (Attr, String)
8483htmlElement tag = tryMsg tag $ do
8584 (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag [])
8685 content <- manyTill anyChar (endtag <|> endofinput)
@@ -97,7 +96,8 @@ htmlAttrToPandoc attrs = (ident, classes, keyvals)
9796 classes = maybe [] words $ lookup "class" attrs
9897 keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
9998
100−parseHtmlContentWithAttrs :: String -> TWParser a -> TWParser (Attr, [a])
99+parseHtmlContentWithAttrs :: PandocMonad m
100+ => String -> TWParser m a -> TWParser m (Attr, [a])
101101parseHtmlContentWithAttrs tag parser = do
102102 (attr, content) <- htmlElement tag
103103 parsedContent <- try $ parseContent content
@@ -106,14 +106,14 @@ parseHtmlContentWithAttrs tag parser = do
106106 parseContent = parseFromString $ nested $ manyTill parser endOfContent
107107 endOfContent = try $ skipMany blankline >> skipSpaces >> eof
108108
109−parseHtmlContent :: String -> TWParser a -> TWParser [a]
109+parseHtmlContent :: PandocMonad m => String -> TWParser m a -> TWParser m [a]
110110parseHtmlContent tag p = parseHtmlContentWithAttrs tag p >>= return . snd
111111
112112--
113113-- main parser
114114--
115115
116−parseTWiki :: TWParser Pandoc
116+parseTWiki :: PandocMonad m => TWParser m Pandoc
117117parseTWiki = do
118118 bs <- mconcat <$> many block
119119 spaces
@@ -125,20 +125,18 @@ parseTWiki = do
125125-- block parsers
126126--
127127
128−block :: TWParser B.Blocks
128+block :: PandocMonad m => TWParser m B.Blocks
129129block = do
130− tr <- (== DEBUG) <$> getOption readerVerbosity
131130 pos <- getPosition
132131 res <- mempty <$ skipMany1 blankline
133132 <|> blockElements
134133 <|> para
135134 skipMany blankline
136− when tr $
137− trace (printf "line %d: %s" (sourceLine pos)
138− (take 60 $ show $ B.toList res)) (return ())
135+ report DEBUG $ printf "line %d: %s" (sourceLine pos)
136+ (take 60 $ show $ B.toList res)
139137 return res
140138
141−blockElements :: TWParser B.Blocks
139+blockElements :: PandocMonad m => TWParser m B.Blocks
142140blockElements = choice [ separator
143141 , header
144142 , verbatim
@@ -149,10 +147,10 @@ blockElements = choice [ separator
149147 , noautolink
150148 ]
151149
152−separator :: TWParser B.Blocks
150+separator :: PandocMonad m => TWParser m B.Blocks
153151separator = tryMsg "separator" $ string "---" >> newline >> return B.horizontalRule
154152
155−header :: TWParser B.Blocks
153+header :: PandocMonad m => TWParser m B.Blocks
156154header = tryMsg "header" $ do
157155 string "---"
158156 level <- many1 (char '+') >>= return . length
@@ -163,43 +161,45 @@ header = tryMsg "header" $ do
163161 attr <- registerHeader ("", classes, []) content
164162 return $ B.headerWith attr level $ content
165163
166−verbatim :: TWParser B.Blocks
164+verbatim :: PandocMonad m => TWParser m B.Blocks
167165verbatim = (htmlElement "verbatim" <|> htmlElement "pre")
168166 >>= return . (uncurry B.codeBlockWith)
169167
170−literal :: TWParser B.Blocks
168+literal :: PandocMonad m => TWParser m B.Blocks
171169literal = htmlElement "literal" >>= return . rawBlock
172170 where
173171 format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs
174172 rawBlock (attrs, content) = B.rawBlock (format attrs) content
175173
176−list :: String -> TWParser B.Blocks
174+list :: PandocMonad m => String -> TWParser m B.Blocks
177175list prefix = choice [ bulletList prefix
178176 , orderedList prefix
179177 , definitionList prefix]
180178
181−definitionList :: String -> TWParser B.Blocks
179+definitionList :: PandocMonad m => String -> TWParser m B.Blocks
182180definitionList prefix = tryMsg "definitionList" $ do
183181 indent <- lookAhead $ string prefix *> (many1 $ string " ") <* string "$ "
184182 elements <- many $ parseDefinitionListItem (prefix ++ concat indent)
185183 return $ B.definitionList elements
186184 where
187− parseDefinitionListItem :: String -> TWParser (B.Inlines, [B.Blocks])
185+ parseDefinitionListItem :: PandocMonad m
186+ => String -> TWParser m (B.Inlines, [B.Blocks])
188187 parseDefinitionListItem indent = do
189188 string (indent ++ "$ ") >> skipSpaces
190189 term <- many1Till inline $ string ": "
191190 line <- listItemLine indent $ string "$ "
192191 return $ (mconcat term, [line])
193192
194−bulletList :: String -> TWParser B.Blocks
193+bulletList :: PandocMonad m => String -> TWParser m B.Blocks
195194bulletList prefix = tryMsg "bulletList" $
196195 parseList prefix (char '*') (char ' ')
197196
198−orderedList :: String -> TWParser B.Blocks
197+orderedList :: PandocMonad m => String -> TWParser m B.Blocks
199198orderedList prefix = tryMsg "orderedList" $
200199 parseList prefix (oneOf "1iIaA") (string ". ")
201200
202−parseList :: String -> TWParser Char -> TWParser a -> TWParser B.Blocks
201+parseList :: PandocMonad m
202+ => String -> TWParser m Char -> TWParser m a -> TWParser m B.Blocks
203203parseList prefix marker delim = do
204204 (indent, style) <- lookAhead $ string prefix *> listStyle <* delim
205205 blocks <- many $ parseListItem (prefix ++ indent) (char style <* delim)
@@ -216,10 +216,12 @@ parseList prefix marker delim = do
216216 style <- marker
217217 return (concat indent, style)
218218
219−parseListItem :: Show a => String -> TWParser a -> TWParser B.Blocks
219+parseListItem :: (PandocMonad m, Show a)
220+ => String -> TWParser m a -> TWParser m B.Blocks
220221parseListItem prefix marker = string prefix >> marker >> listItemLine prefix marker
221222
222−listItemLine :: Show a => String -> TWParser a -> TWParser B.Blocks
223+listItemLine :: (PandocMonad m, Show a)
224+ => String -> TWParser m a -> TWParser m B.Blocks
223225listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat
224226 where
225227 lineContent = do
@@ -236,7 +238,7 @@ listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat
236238 lastNewline = try $ char '\n' <* eof
237239 newlineBeforeNestedList = try $ char '\n' <* lookAhead nestedList
238240
239−table :: TWParser B.Blocks
241+table :: PandocMonad m => TWParser m B.Blocks
240242table = try $ do
241243 tableHead <- optionMaybe $ many1Till tableParseHeader newline >>= return . unzip
242244 rows <- many1 tableParseRow
@@ -248,7 +250,7 @@ table = try $ do
248250 columns rows = replicate (columCount rows) mempty
249251 columCount rows = length $ head rows
250252
251−tableParseHeader :: TWParser ((Alignment, Double), B.Blocks)
253+tableParseHeader :: PandocMonad m => TWParser m ((Alignment, Double), B.Blocks)
252254tableParseHeader = try $ do
253255 char '|'
254256 leftSpaces <- many spaceChar >>= return . length
@@ -264,27 +266,27 @@ tableParseHeader = try $ do
264266 | left > right = (AlignRight, 0)
265267 | otherwise = (AlignLeft, 0)
266268
267−tableParseRow :: TWParser [B.Blocks]
269+tableParseRow :: PandocMonad m => TWParser m [B.Blocks]
268270tableParseRow = many1Till tableParseColumn newline
269271
270−tableParseColumn :: TWParser B.Blocks
272+tableParseColumn :: PandocMonad m => TWParser m B.Blocks
271273tableParseColumn = char '|' *> skipSpaces *>
272274 tableColumnContent (skipSpaces >> char '|')
273275 <* skipSpaces <* optional tableEndOfRow
274276
275−tableEndOfRow :: TWParser Char
277+tableEndOfRow :: PandocMonad m => TWParser m Char
276278tableEndOfRow = lookAhead (try $ char '|' >> char '\n') >> char '|'
277279
278−tableColumnContent :: TWParser a -> TWParser B.Blocks
280+tableColumnContent :: PandocMonad m => TWParser m a -> TWParser m B.Blocks
279281tableColumnContent end = manyTill content (lookAhead $ try end) >>= return . B.plain . mconcat
280282 where
281283 content = continuation <|> inline
282284 continuation = try $ char '\\' >> newline >> return mempty
283285
284−blockQuote :: TWParser B.Blocks
286+blockQuote :: PandocMonad m => TWParser m B.Blocks
285287blockQuote = parseHtmlContent "blockquote" block >>= return . B.blockQuote . mconcat
286288
287−noautolink :: TWParser B.Blocks
289+noautolink :: PandocMonad m => TWParser m B.Blocks
288290noautolink = do
289291 (_, content) <- htmlElement "noautolink"
290292 st <- getState
@@ -295,7 +297,7 @@ noautolink = do
295297 where
296298 parseContent = parseFromString $ many $ block
297299
298−para :: TWParser B.Blocks
300+para :: PandocMonad m => TWParser m B.Blocks
299301para = many1Till inline endOfParaElement >>= return . result . mconcat
300302 where
301303 endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
@@ -311,7 +313,7 @@ para = many1Till inline endOfParaElement >>= return . result . mconcat
311313-- inline parsers
312314--
313315
314−inline :: TWParser B.Inlines
316+inline :: PandocMonad m => TWParser m B.Inlines
315317inline = choice [ whitespace
316318 , br
317319 , macro
@@ -332,36 +334,39 @@ inline = choice [ whitespace
332334 , symbol
333335 ] <?> "inline"
334336
335−whitespace :: TWParser B.Inlines
337+whitespace :: PandocMonad m => TWParser m B.Inlines
336338whitespace = (lb <|> regsp) >>= return
337339 where lb = try $ skipMany spaceChar >> linebreak >> return B.space
338340 regsp = try $ skipMany1 spaceChar >> return B.space
339341
340−br :: TWParser B.Inlines
342+br :: PandocMonad m => TWParser m B.Inlines
341343br = try $ string "%BR%" >> return B.linebreak
342344
343−linebreak :: TWParser B.Inlines
345+linebreak :: PandocMonad m => TWParser m B.Inlines
344346linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
345347 where lastNewline = eof >> return mempty
346348 innerNewline = return B.space
347349
348−between :: (Monoid c) => TWParser a -> TWParser b -> (TWParser b -> TWParser c) -> TWParser c
350+between :: (Monoid c, PandocMonad m)
351+ => TWParser m a -> TWParser m b -> (TWParser m b -> TWParser m c)
352+ -> TWParser m c
349353between start end p =
350354 mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end)
351355
352−enclosed :: (Monoid b) => TWParser a -> (TWParser a -> TWParser b) -> TWParser b
356+enclosed :: (Monoid b, PandocMonad m)
357+ => TWParser m a -> (TWParser m a -> TWParser m b) -> TWParser m b
353358enclosed sep p = between sep (try $ sep <* endMarker) p
354359 where
355360 endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|") <|> eof
356361 endSpace = (spaceChar <|> newline) >> return B.space
357362
358−macro :: TWParser B.Inlines
363+macro :: PandocMonad m => TWParser m B.Inlines
359364macro = macroWithParameters <|> withoutParameters
360365 where
361366 withoutParameters = enclosed (char '%') (\_ -> macroName) >>= return . emptySpan
362367 emptySpan name = buildSpan name [] mempty
363368
364−macroWithParameters :: TWParser B.Inlines
369+macroWithParameters :: PandocMonad m => TWParser m B.Inlines
365370macroWithParameters = try $ do
366371 char '%'
367372 name <- macroName
@@ -376,13 +381,13 @@ buildSpan className kvs = B.spanWith attrs
376381 additionalClasses = maybe [] words $ lookup "class" kvs
377382 kvsWithoutClasses = [(k,v) | (k,v) <- kvs, k /= "class"]
378383
379−macroName :: TWParser String
384+macroName :: PandocMonad m => TWParser m String
380385macroName = do
381386 first <- letter
382387 rest <- many $ alphaNum <|> char '_'
383388 return (first:rest)
384389
385−attributes :: TWParser (String, [(String, String)])
390+attributes :: PandocMonad m => TWParser m (String, [(String, String)])
386391attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>=
387392 return . foldr (either mkContent mkKvs) ([], [])
388393 where
@@ -391,7 +396,7 @@ attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>=
391396 mkContent c (rest, kvs) = (c ++ " " ++ rest, kvs)
392397 mkKvs kv (cont, rest) = (cont, (kv : rest))
393398
394−attribute :: TWParser (Either String (String, String))
399+attribute :: PandocMonad m => TWParser m (Either String (String, String))
395400attribute = withKey <|> withoutKey
396401 where
397402 withKey = try $ do
@@ -405,49 +410,51 @@ attribute = withKey <|> withoutKey
405410 | allowSpaces == True = many1 $ noneOf "}"
406411 | otherwise = many1 $ noneOf " }"
407412
408−nestedInlines :: Show a => TWParser a -> TWParser B.Inlines
413+nestedInlines :: (Show a, PandocMonad m)
414+ => TWParser m a -> TWParser m B.Inlines
409415nestedInlines end = innerSpace <|> nestedInline
410416 where
411417 innerSpace = try $ whitespace <* (notFollowedBy end)
412418 nestedInline = notFollowedBy whitespace >> nested inline
413419
414−strong :: TWParser B.Inlines
420+strong :: PandocMonad m => TWParser m B.Inlines
415421strong = try $ enclosed (char '*') nestedInlines >>= return . B.strong
416422
417−strongHtml :: TWParser B.Inlines
423+strongHtml :: PandocMonad m => TWParser m B.Inlines
418424strongHtml = (parseHtmlContent "strong" inline <|> parseHtmlContent "b" inline)
419425 >>= return . B.strong . mconcat
420426
421−strongAndEmph :: TWParser B.Inlines
427+strongAndEmph :: PandocMonad m => TWParser m B.Inlines
422428strongAndEmph = try $ enclosed (string "__") nestedInlines >>= return . B.emph . B.strong
423429
424−emph :: TWParser B.Inlines
430+emph :: PandocMonad m => TWParser m B.Inlines
425431emph = try $ enclosed (char '_') nestedInlines >>= return . B.emph
426432
427−emphHtml :: TWParser B.Inlines
433+emphHtml :: PandocMonad m => TWParser m B.Inlines
428434emphHtml = (parseHtmlContent "em" inline <|> parseHtmlContent "i" inline)
429435 >>= return . B.emph . mconcat
430436
431−nestedString :: Show a => TWParser a -> TWParser String
437+nestedString :: (Show a, PandocMonad m)
438+ => TWParser m a -> TWParser m String
432439nestedString end = innerSpace <|> (count 1 nonspaceChar)
433440 where
434441 innerSpace = try $ many1 spaceChar <* notFollowedBy end
435442
436−boldCode :: TWParser B.Inlines
443+boldCode :: PandocMonad m => TWParser m B.Inlines
437444boldCode = try $ enclosed (string "==") nestedString >>= return . B.strong . B.code . fromEntities
438445
439−htmlComment :: TWParser B.Inlines
446+htmlComment :: PandocMonad m => TWParser m B.Inlines
440447htmlComment = htmlTag isCommentTag >> return mempty
441448
442−code :: TWParser B.Inlines
449+code :: PandocMonad m => TWParser m B.Inlines
443450code = try $ enclosed (char '=') nestedString >>= return . B.code . fromEntities
444451
445−codeHtml :: TWParser B.Inlines
452+codeHtml :: PandocMonad m => TWParser m B.Inlines
446453codeHtml = do
447454 (attrs, content) <- parseHtmlContentWithAttrs "code" anyChar
448455 return $ B.codeWith attrs $ fromEntities content
449456
450−autoLink :: TWParser B.Inlines
457+autoLink :: PandocMonad m => TWParser m B.Inlines
451458autoLink = try $ do
452459 state <- getState
453460 guard $ stateAllowLinks state
@@ -461,20 +468,20 @@ autoLink = try $ do
461468 | c == '/' = True
462469 | otherwise = isAlphaNum c
463470
464−str :: TWParser B.Inlines
471+str :: PandocMonad m => TWParser m B.Inlines
465472str = (many1 alphaNum <|> count 1 characterReference) >>= return . B.str
466473
467−nop :: TWParser B.Inlines
474+nop :: PandocMonad m => TWParser m B.Inlines
468475nop = try $ (skip exclamation <|> skip nopTag) >> followContent
469476 where
470477 exclamation = char '!'
471478 nopTag = stringAnyCase "<nop>"
472479 followContent = many1 nonspaceChar >>= return . B.str . fromEntities
473480
474−symbol :: TWParser B.Inlines
481+symbol :: PandocMonad m => TWParser m B.Inlines
475482symbol = count 1 nonspaceChar >>= return . B.str
476483
477−smart :: TWParser B.Inlines
484+smart :: PandocMonad m => TWParser m B.Inlines
478485smart = do
479486 guardEnabled Ext_smart
480487 doubleQuoted <|> singleQuoted <|>
@@ -483,14 +490,14 @@ smart = do
483490 , ellipses
484491 ]
485492
486−singleQuoted :: TWParser B.Inlines
493+singleQuoted :: PandocMonad m => TWParser m B.Inlines
487494singleQuoted = try $ do
488495 singleQuoteStart
489496 withQuoteContext InSingleQuote $
490497 many1Till inline singleQuoteEnd >>=
491498 (return . B.singleQuoted . B.trimInlines . mconcat)
492499
493−doubleQuoted :: TWParser B.Inlines
500+doubleQuoted :: PandocMonad m => TWParser m B.Inlines
494501doubleQuoted = try $ do
495502 doubleQuoteStart
496503 contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
@@ -498,7 +505,7 @@ doubleQuoted = try $ do
498505 return (B.doubleQuoted $ B.trimInlines contents))
499506 <|> (return $ (B.str "\8220") B.<> contents)
500507
501−link :: TWParser B.Inlines
508+link :: PandocMonad m => TWParser m B.Inlines
502509link = try $ do
503510 st <- getState
504511 guard $ stateAllowLinks st
@@ -507,7 +514,7 @@ link = try $ do
507514 setState $ st{ stateAllowLinks = True }
508515 return $ B.link url title content
509516
510−linkText :: TWParser (String, String, B.Inlines)
517+linkText :: PandocMonad m => TWParser m (String, String, B.Inlines)
511518linkText = do
512519 string "[["
513520 url <- many1Till anyChar (char ']')