@@ -0,0 +1,526 @@
1+{-# LANGUAGE RelaxedPolyRec, FlexibleInstances, TypeSynonymInstances #-}
2+-- RelaxedPolyRec needed for inlinesBetween on GHC < 7
4+ Copyright (C) 2014 Alexander Sulfrian <alexander.sulfrian@fu-berlin.de>
6+This program is free software; you can redistribute it and/or modify
7+it under the terms of the GNU General Public License as published by
8+the Free Software Foundation; either version 2 of the License, or
9+(at your option) any later version.
11+This program is distributed in the hope that it will be useful,
12+but WITHOUT ANY WARRANTY; without even the implied warranty of
13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14+GNU General Public License for more details.
16+You should have received a copy of the GNU General Public License
17+along with this program; if not, write to the Free Software
18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22+ Module : Text.Pandoc.Readers.TWiki
23+ Copyright : Copyright (C) 2014 Alexander Sulfrian
24+ License : GNU GPL, version 2 or above
26+ Maintainer : Alexander Sulfrian <alexander.sulfrian@fu-berlin.de>
28+ Portability : portable
30+Conversion of twiki text to 'Pandoc' document.
32+module Text.Pandoc.Readers.TWiki ( readTWiki
33+ , readTWikiWithWarnings
36+import Text.Pandoc.Definition
37+import qualified Text.Pandoc.Builder as B
38+import Text.Pandoc.Options
39+import Text.Pandoc.Parsing hiding (enclosed, macro, nested)
40+import Text.Pandoc.Readers.HTML (htmlTag, isCommentTag)
41+import Data.Monoid (Monoid, mconcat, mempty)
42+import Control.Applicative ((<$>), (<*), (*>), (<$))
44+import Text.Printf (printf)
45+import Debug.Trace (trace)
46+import Text.Pandoc.XML (fromEntities)
47+import Data.Maybe (fromMaybe)
48+import Text.HTML.TagSoup
49+import Data.Char (isAlphaNum)
50+import qualified Data.Foldable as F
52+-- | Read twiki from an input string and return a Pandoc document.
53+readTWiki :: ReaderOptions -- ^ Reader options
54+ -> String -- ^ String to parse (assuming @'\n'@ line endings)
57+ (readWith parseTWiki) def{ stateOptions = opts } (s ++ "\n\n")
59+readTWikiWithWarnings :: ReaderOptions -- ^ Reader options
60+ -> String -- ^ String to parse (assuming @'\n'@ line endings)
61+ -> (Pandoc, [String])
62+readTWikiWithWarnings opts s =
63+ (readWith parseTWikiWithWarnings) def{ stateOptions = opts } (s ++ "\n\n")
64+ where parseTWikiWithWarnings = do
66+ warnings <- stateWarnings <$> getState
67+ return (doc, warnings)
69+type TWParser = Parser [Char] ParserState
75+tryMsg :: String -> TWParser a -> TWParser a
76+tryMsg msg p = try p <?> msg
78+skip :: TWParser a -> TWParser ()
79+skip parser = parser >> return ()
81+nested :: TWParser a -> TWParser a
83+ nestlevel <- stateMaxNestingLevel <$> getState
84+ guard $ nestlevel > 0
85+ updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 }
87+ updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
90+htmlElement :: String -> TWParser (Attr, String)
91+htmlElement tag = tryMsg tag $ do
92+ (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag [])
93+ content <- manyTill anyChar (endtag <|> endofinput)
94+ return (htmlAttrToPandoc attr, trim content)
96+ endtag = skip $ htmlTag (~== TagClose tag)
97+ endofinput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof
98+ trim = dropWhile (=='\n') . reverse . dropWhile (=='\n') . reverse
100+htmlAttrToPandoc :: [Attribute String] -> Attr
101+htmlAttrToPandoc attrs = (ident, classes, keyvals)
103+ ident = fromMaybe "" $ lookup "id" attrs
104+ classes = maybe [] words $ lookup "class" attrs
105+ keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
107+parseHtmlContentWithAttrs :: String -> TWParser a -> TWParser (Attr, [a])
108+parseHtmlContentWithAttrs tag parser = do
109+ (attr, content) <- htmlElement tag
110+ parsedContent <- try $ parseContent content
111+ return (attr, parsedContent)
113+ parseContent = parseFromString $ nested $ manyTill parser endOfContent
114+ endOfContent = try $ skipMany blankline >> skipSpaces >> eof
116+parseHtmlContent :: String -> TWParser a -> TWParser [a]
117+parseHtmlContent tag p = parseHtmlContentWithAttrs tag p >>= return . snd
123+parseTWiki :: TWParser Pandoc
125+ bs <- mconcat <$> many block
135+block :: TWParser B.Blocks
137+ tr <- getOption readerTrace
139+ res <- mempty <$ skipMany1 blankline
144+ trace (printf "line %d: %s" (sourceLine pos)
145+ (take 60 $ show $ B.toList res)) (return ())
148+blockElements :: TWParser B.Blocks
149+blockElements = choice [ separator
159+separator :: TWParser B.Blocks
160+separator = tryMsg "separator" $ string "---" >> newline >> return B.horizontalRule
162+header :: TWParser B.Blocks
163+header = tryMsg "header" $ do
165+ level <- many1 (char '+') >>= return . length
167+ classes <- option [] $ string "!!" >> return ["unnumbered"]
169+ content <- B.trimInlines . mconcat <$> manyTill inline newline
170+ attr <- registerHeader ("", classes, []) content
171+ return $ B.headerWith attr level $ content
173+verbatim :: TWParser B.Blocks
174+verbatim = (htmlElement "verbatim" <|> htmlElement "pre")
175+ >>= return . (uncurry B.codeBlockWith)
177+literal :: TWParser B.Blocks
178+literal = htmlElement "literal" >>= return . rawBlock
180+ format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs
181+ rawBlock (attrs, content) = B.rawBlock (format attrs) content
183+list :: String -> TWParser B.Blocks
184+list prefix = choice [ bulletList prefix
185+ , orderedList prefix
186+ , definitionList prefix]
188+definitionList :: String -> TWParser B.Blocks
189+definitionList prefix = tryMsg "definitionList" $ do
190+ indent <- lookAhead $ string prefix *> (many1 $ string " ") <* string "$ "
191+ elements <- many $ parseDefinitionListItem (prefix ++ concat indent)
192+ return $ B.definitionList elements
194+ parseDefinitionListItem :: String -> TWParser (B.Inlines, [B.Blocks])
195+ parseDefinitionListItem indent = do
196+ string (indent ++ "$ ") >> skipSpaces
197+ term <- many1Till inline $ string ": "
198+ line <- listItemLine indent $ string "$ "
199+ return $ (mconcat term, [line])
201+bulletList :: String -> TWParser B.Blocks
202+bulletList prefix = tryMsg "bulletList" $
203+ parseList prefix (char '*') (char ' ')
205+orderedList :: String -> TWParser B.Blocks
206+orderedList prefix = tryMsg "orderedList" $
207+ parseList prefix (oneOf "1iIaA") (string ". ")
209+parseList :: Show a => String -> TWParser Char -> TWParser a -> TWParser B.Blocks
210+parseList prefix marker delim = do
211+ (indent, style) <- lookAhead $ string prefix *> listStyle <* delim
212+ blocks <- many $ parseListItem (prefix ++ indent) (char style <* delim)
213+ return $ case style of
214+ '1' -> B.orderedListWith (1, DefaultStyle, DefaultDelim) blocks
215+ 'i' -> B.orderedListWith (1, LowerRoman, DefaultDelim) blocks
216+ 'I' -> B.orderedListWith (1, UpperRoman, DefaultDelim) blocks
217+ 'a' -> B.orderedListWith (1, LowerAlpha, DefaultDelim) blocks
218+ 'A' -> B.orderedListWith (1, UpperAlpha, DefaultDelim) blocks
219+ _ -> B.bulletList blocks
222+ indent <- many1 $ string " "
224+ return (concat indent, style)
226+parseListItem :: Show a => String -> TWParser a -> TWParser B.Blocks
227+parseListItem prefix marker = string prefix >> marker >> listItemLine prefix marker
229+listItemLine :: Show a => String -> TWParser a -> TWParser B.Blocks
230+listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat
234+ continuation <- optionMaybe listContinuation
235+ return $ filterSpaces content ++ "\n" ++ (maybe "" (" " ++) continuation)
236+ filterSpaces = reverse . dropWhile (== ' ') . reverse
237+ listContinuation = notFollowedBy (string prefix >> marker) >>
238+ string " " >> lineContent
239+ parseContent = parseFromString $ many1 $ nestedList <|> parseInline
240+ parseInline = many1Till inline (lastNewline <|> newlineBeforeNestedList) >>=
241+ return . B.plain . mconcat
242+ nestedList = list prefix
243+ lastNewline = try $ char '\n' <* eof
244+ newlineBeforeNestedList = try $ char '\n' <* lookAhead nestedList
246+table :: TWParser B.Blocks
248+ tableHead <- optionMaybe $ many1Till tableParseHeader newline >>= return . unzip
249+ rows <- many1 tableParseRow
250+ return $ buildTable mempty rows $ fromMaybe (align rows, columns rows) tableHead
252+ buildTable caption rows (aligns, heads)
253+ = B.table caption aligns heads rows
254+ align rows = replicate (columCount rows) (AlignDefault, 0)
255+ columns rows = replicate (columCount rows) mempty
256+ columCount rows = length $ head rows
258+tableParseHeader :: TWParser ((Alignment, Double), B.Blocks)
259+tableParseHeader = try $ do
261+ leftSpaces <- many spaceChar >>= return . length
263+ content <- tableColumnContent (char '*' >> skipSpaces >> char '|')
265+ rightSpaces <- many spaceChar >>= return . length
266+ optional tableEndOfRow
267+ return (tableAlign leftSpaces rightSpaces, content)
269+ tableAlign left right
270+ | left >= 2 && left == right = (AlignCenter, 0)
271+ | left > right = (AlignRight, 0)
272+ | otherwise = (AlignLeft, 0)
274+tableParseRow :: TWParser [B.Blocks]
275+tableParseRow = many1Till tableParseColumn newline
277+tableParseColumn :: TWParser B.Blocks
278+tableParseColumn = char '|' *> skipSpaces *>
279+ tableColumnContent (skipSpaces >> char '|')
280+ <* skipSpaces <* optional tableEndOfRow
282+tableEndOfRow :: TWParser Char
283+tableEndOfRow = lookAhead (try $ char '|' >> char '\n') >> char '|'
285+tableColumnContent :: Show a => TWParser a -> TWParser B.Blocks
286+tableColumnContent end = manyTill content (lookAhead $ try end) >>= return . B.plain . mconcat
288+ content = continuation <|> inline
289+ continuation = try $ char '\\' >> newline >> return mempty
291+blockQuote :: TWParser B.Blocks
292+blockQuote = parseHtmlContent "blockquote" block >>= return . B.blockQuote . mconcat
294+noautolink :: TWParser B.Blocks
296+ (_, content) <- htmlElement "noautolink"
298+ setState $ st{ stateAllowLinks = False }
299+ blocks <- try $ parseContent content
300+ setState $ st{ stateAllowLinks = True }
301+ return $ mconcat blocks
303+ parseContent = parseFromString $ many $ block
305+para :: TWParser B.Blocks
306+para = many1Till inline endOfParaElement >>= return . result . mconcat
308+ endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
309+ endOfInput = try $ skipMany blankline >> skipSpaces >> eof
310+ endOfPara = try $ blankline >> skipMany1 blankline
311+ newBlockElement = try $ blankline >> skip blockElements
312+ result content = if F.all (==Space) content
314+ else B.para $ B.trimInlines content
321+inline :: TWParser B.Inlines
322+inline = choice [ whitespace
342+whitespace :: TWParser B.Inlines
343+whitespace = (lb <|> regsp) >>= return
344+ where lb = try $ skipMany spaceChar >> linebreak >> return B.space
345+ regsp = try $ skipMany1 spaceChar >> return B.space
347+br :: TWParser B.Inlines
348+br = try $ string "%BR%" >> return B.linebreak
350+linebreak :: TWParser B.Inlines
351+linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
352+ where lastNewline = eof >> return mempty
353+ innerNewline = return B.space
355+between :: (Show b, Monoid c) => TWParser a -> TWParser b -> (TWParser b -> TWParser c) -> TWParser c
356+between start end p =
357+ mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end)
359+enclosed :: (Show a, Monoid b) => TWParser a -> (TWParser a -> TWParser b) -> TWParser b
360+enclosed sep p = between sep (try $ sep <* endMarker) p
362+ endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|") <|> eof
363+ endSpace = (spaceChar <|> newline) >> return B.space
365+macro :: TWParser B.Inlines
366+macro = macroWithParameters <|> withoutParameters
368+ withoutParameters = enclosed (char '%') (\_ -> macroName) >>= return . emptySpan
369+ emptySpan name = buildSpan name [] mempty
371+macroWithParameters :: TWParser B.Inlines
372+macroWithParameters = try $ do
375+ (content, kvs) <- attributes
377+ return $ buildSpan name kvs $ B.str content
379+buildSpan :: String -> [(String, String)] -> B.Inlines -> B.Inlines
380+buildSpan className kvs = B.spanWith attrs
382+ attrs = ("", ["twiki-macro", className] ++ additionalClasses, kvsWithoutClasses)
383+ additionalClasses = maybe [] words $ lookup "class" kvs
384+ kvsWithoutClasses = [(k,v) | (k,v) <- kvs, k /= "class"]
386+macroName :: TWParser String
389+ rest <- many $ alphaNum <|> char '_'
392+attributes :: TWParser (String, [(String, String)])
393+attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>=
394+ return . foldr (either mkContent mkKvs) ([], [])
396+ spnl = skipMany (spaceChar <|> newline)
397+ mkContent c ([], kvs) = (c, kvs)
398+ mkContent c (rest, kvs) = (c ++ " " ++ rest, kvs)
399+ mkKvs kv (cont, rest) = (cont, (kv : rest))
401+attribute :: TWParser (Either String (String, String))
402+attribute = withKey <|> withoutKey
407+ parseValue False >>= return . (curry Right key)
408+ withoutKey = try $ parseValue True >>= return . Left
409+ parseValue allowSpaces = (withQuotes <|> withoutQuotes allowSpaces) >>= return . fromEntities
410+ withQuotes = between (char '"') (char '"') (\_ -> count 1 $ noneOf ['"'])
411+ withoutQuotes allowSpaces
412+ | allowSpaces == True = many1 $ noneOf "}"
413+ | otherwise = many1 $ noneOf " }"
415+nestedInlines :: Show a => TWParser a -> TWParser B.Inlines
416+nestedInlines end = innerSpace <|> nestedInline
418+ innerSpace = try $ whitespace <* (notFollowedBy end)
419+ nestedInline = notFollowedBy whitespace >> nested inline
421+strong :: TWParser B.Inlines
422+strong = try $ enclosed (char '*') nestedInlines >>= return . B.strong
424+strongHtml :: TWParser B.Inlines
425+strongHtml = (parseHtmlContent "strong" inline <|> parseHtmlContent "b" inline)
426+ >>= return . B.strong . mconcat
428+strongAndEmph :: TWParser B.Inlines
429+strongAndEmph = try $ enclosed (string "__") nestedInlines >>= return . B.emph . B.strong
431+emph :: TWParser B.Inlines
432+emph = try $ enclosed (char '_') nestedInlines >>= return . B.emph
434+emphHtml :: TWParser B.Inlines
435+emphHtml = (parseHtmlContent "em" inline <|> parseHtmlContent "i" inline)
436+ >>= return . B.emph . mconcat
438+nestedString :: Show a => TWParser a -> TWParser String
439+nestedString end = innerSpace <|> (count 1 nonspaceChar)
441+ innerSpace = try $ many1 spaceChar <* notFollowedBy end
443+boldCode :: TWParser B.Inlines
444+boldCode = try $ enclosed (string "==") nestedString >>= return . B.strong . B.code . fromEntities
446+htmlComment :: TWParser B.Inlines
447+htmlComment = htmlTag isCommentTag >> return mempty
449+code :: TWParser B.Inlines
450+code = try $ enclosed (char '=') nestedString >>= return . B.code . fromEntities
452+codeHtml :: TWParser B.Inlines
454+ (attrs, content) <- parseHtmlContentWithAttrs "code" anyChar
455+ return $ B.codeWith attrs $ fromEntities content
457+autoLink :: TWParser B.Inlines
460+ guard $ stateAllowLinks state
461+ (text, url) <- parseLink
462+ guard $ checkLink (head $ reverse url)
463+ return $ makeLink (text, url)
465+ parseLink = notFollowedBy nop >> (uri <|> emailAddress)
466+ makeLink (text, url) = B.link url "" $ B.str text
469+ | otherwise = isAlphaNum c
471+str :: TWParser B.Inlines
472+str = (many1 alphaNum <|> count 1 characterReference) >>= return . B.str
474+nop :: TWParser B.Inlines
475+nop = try $ (skip exclamation <|> skip nopTag) >> followContent
477+ exclamation = char '!'
478+ nopTag = stringAnyCase "<nop>"
479+ followContent = many1 nonspaceChar >>= return . B.str . fromEntities
481+symbol :: TWParser B.Inlines
482+symbol = count 1 nonspaceChar >>= return . B.str
484+smart :: TWParser B.Inlines
486+ getOption readerSmart >>= guard
487+ doubleQuoted <|> singleQuoted <|>
493+singleQuoted :: TWParser B.Inlines
494+singleQuoted = try $ do
496+ withQuoteContext InSingleQuote $
497+ many1Till inline singleQuoteEnd >>=
498+ (return . B.singleQuoted . B.trimInlines . mconcat)
500+doubleQuoted :: TWParser B.Inlines
501+doubleQuoted = try $ do
503+ contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
504+ (withQuoteContext InDoubleQuote $ doubleQuoteEnd >>
505+ return (B.doubleQuoted $ B.trimInlines contents))
506+ <|> (return $ (B.str "\8220") B.<> contents)
508+link :: TWParser B.Inlines
511+ guard $ stateAllowLinks st
512+ setState $ st{ stateAllowLinks = False }
513+ (url, title, content) <- linkText
514+ setState $ st{ stateAllowLinks = True }
515+ return $ B.link url title content
517+linkText :: TWParser (String, String, B.Inlines)
520+ url <- many1Till anyChar (char ']')
521+ content <- option [B.str url] linkContent
523+ return (url, "", mconcat content)
525+ linkContent = (char '[') >> many1Till anyChar (char ']') >>= parseLinkContent
526+ parseLinkContent = parseFromString $ many1 inline