@@ -0,0 +1,526 @@
1+{-# LANGUAGE RelaxedPolyRec, FlexibleInstances, TypeSynonymInstances #-}
2+-- RelaxedPolyRec needed for inlinesBetween on GHC < 7
3+{-
4+ Copyright (C) 2014 Alexander Sulfrian <alexander.sulfrian@fu-berlin.de>
5+
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.
10+
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.
15+
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
19+-}
20+
21+{- |
22+ Module : Text.Pandoc.Readers.TWiki
23+ Copyright : Copyright (C) 2014 Alexander Sulfrian
24+ License : GNU GPL, version 2 or above
25+
26+ Maintainer : Alexander Sulfrian <alexander.sulfrian@fu-berlin.de>
27+ Stability : alpha
28+ Portability : portable
29+
30+Conversion of twiki text to 'Pandoc' document.
31+-}
32+module Text.Pandoc.Readers.TWiki ( readTWiki
33+ , readTWikiWithWarnings
34+ ) where
35+
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 ((<$>), (<*), (*>), (<$))
43+import Control.Monad
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
51+
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)
55+ -> Pandoc
56+readTWiki opts s =
57+ (readWith parseTWiki) def{ stateOptions = opts } (s ++ "\n\n")
58+
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
65+ doc <- parseTWiki
66+ warnings <- stateWarnings <$> getState
67+ return (doc, warnings)
68+
69+type TWParser = Parser [Char] ParserState
70+
71+--
72+-- utility functions
73+--
74+
75+tryMsg :: String -> TWParser a -> TWParser a
76+tryMsg msg p = try p <?> msg
77+
78+skip :: TWParser a -> TWParser ()
79+skip parser = parser >> return ()
80+
81+nested :: TWParser a -> TWParser a
82+nested p = do
83+ nestlevel <- stateMaxNestingLevel <$> getState
84+ guard $ nestlevel > 0
85+ updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 }
86+ res <- p
87+ updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
88+ return res
89+
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)
95+ where
96+ endtag = skip $ htmlTag (~== TagClose tag)
97+ endofinput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof
98+ trim = dropWhile (=='\n') . reverse . dropWhile (=='\n') . reverse
99+
100+htmlAttrToPandoc :: [Attribute String] -> Attr
101+htmlAttrToPandoc attrs = (ident, classes, keyvals)
102+ where
103+ ident = fromMaybe "" $ lookup "id" attrs
104+ classes = maybe [] words $ lookup "class" attrs
105+ keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
106+
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)
112+ where
113+ parseContent = parseFromString $ nested $ manyTill parser endOfContent
114+ endOfContent = try $ skipMany blankline >> skipSpaces >> eof
115+
116+parseHtmlContent :: String -> TWParser a -> TWParser [a]
117+parseHtmlContent tag p = parseHtmlContentWithAttrs tag p >>= return . snd
118+
119+--
120+-- main parser
121+--
122+
123+parseTWiki :: TWParser Pandoc
124+parseTWiki = do
125+ bs <- mconcat <$> many block
126+ spaces
127+ eof
128+ return $ B.doc bs
129+
130+
131+--
132+-- block parsers
133+--
134+
135+block :: TWParser B.Blocks
136+block = do
137+ tr <- getOption readerTrace
138+ pos <- getPosition
139+ res <- mempty <$ skipMany1 blankline
140+ <|> blockElements
141+ <|> para
142+ skipMany blankline
143+ when tr $
144+ trace (printf "line %d: %s" (sourceLine pos)
145+ (take 60 $ show $ B.toList res)) (return ())
146+ return res
147+
148+blockElements :: TWParser B.Blocks
149+blockElements = choice [ separator
150+ , header
151+ , verbatim
152+ , literal
153+ , list ""
154+ , table
155+ , blockQuote
156+ , noautolink
157+ ]
158+
159+separator :: TWParser B.Blocks
160+separator = tryMsg "separator" $ string "---" >> newline >> return B.horizontalRule
161+
162+header :: TWParser B.Blocks
163+header = tryMsg "header" $ do
164+ string "---"
165+ level <- many1 (char '+') >>= return . length
166+ guard $ level <= 6
167+ classes <- option [] $ string "!!" >> return ["unnumbered"]
168+ skipSpaces
169+ content <- B.trimInlines . mconcat <$> manyTill inline newline
170+ attr <- registerHeader ("", classes, []) content
171+ return $ B.headerWith attr level $ content
172+
173+verbatim :: TWParser B.Blocks
174+verbatim = (htmlElement "verbatim" <|> htmlElement "pre")
175+ >>= return . (uncurry B.codeBlockWith)
176+
177+literal :: TWParser B.Blocks
178+literal = htmlElement "literal" >>= return . rawBlock
179+ where
180+ format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs
181+ rawBlock (attrs, content) = B.rawBlock (format attrs) content
182+
183+list :: String -> TWParser B.Blocks
184+list prefix = choice [ bulletList prefix
185+ , orderedList prefix
186+ , definitionList prefix]
187+
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
193+ where
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])
200+
201+bulletList :: String -> TWParser B.Blocks
202+bulletList prefix = tryMsg "bulletList" $
203+ parseList prefix (char '*') (char ' ')
204+
205+orderedList :: String -> TWParser B.Blocks
206+orderedList prefix = tryMsg "orderedList" $
207+ parseList prefix (oneOf "1iIaA") (string ". ")
208+
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
220+ where
221+ listStyle = do
222+ indent <- many1 $ string " "
223+ style <- marker
224+ return (concat indent, style)
225+
226+parseListItem :: Show a => String -> TWParser a -> TWParser B.Blocks
227+parseListItem prefix marker = string prefix >> marker >> listItemLine prefix marker
228+
229+listItemLine :: Show a => String -> TWParser a -> TWParser B.Blocks
230+listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat
231+ where
232+ lineContent = do
233+ content <- anyLine
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
245+
246+table :: TWParser B.Blocks
247+table = try $ do
248+ tableHead <- optionMaybe $ many1Till tableParseHeader newline >>= return . unzip
249+ rows <- many1 tableParseRow
250+ return $ buildTable mempty rows $ fromMaybe (align rows, columns rows) tableHead
251+ where
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
257+
258+tableParseHeader :: TWParser ((Alignment, Double), B.Blocks)
259+tableParseHeader = try $ do
260+ char '|'
261+ leftSpaces <- many spaceChar >>= return . length
262+ char '*'
263+ content <- tableColumnContent (char '*' >> skipSpaces >> char '|')
264+ char '*'
265+ rightSpaces <- many spaceChar >>= return . length
266+ optional tableEndOfRow
267+ return (tableAlign leftSpaces rightSpaces, content)
268+ where
269+ tableAlign left right
270+ | left >= 2 && left == right = (AlignCenter, 0)
271+ | left > right = (AlignRight, 0)
272+ | otherwise = (AlignLeft, 0)
273+
274+tableParseRow :: TWParser [B.Blocks]
275+tableParseRow = many1Till tableParseColumn newline
276+
277+tableParseColumn :: TWParser B.Blocks
278+tableParseColumn = char '|' *> skipSpaces *>
279+ tableColumnContent (skipSpaces >> char '|')
280+ <* skipSpaces <* optional tableEndOfRow
281+
282+tableEndOfRow :: TWParser Char
283+tableEndOfRow = lookAhead (try $ char '|' >> char '\n') >> char '|'
284+
285+tableColumnContent :: Show a => TWParser a -> TWParser B.Blocks
286+tableColumnContent end = manyTill content (lookAhead $ try end) >>= return . B.plain . mconcat
287+ where
288+ content = continuation <|> inline
289+ continuation = try $ char '\\' >> newline >> return mempty
290+
291+blockQuote :: TWParser B.Blocks
292+blockQuote = parseHtmlContent "blockquote" block >>= return . B.blockQuote . mconcat
293+
294+noautolink :: TWParser B.Blocks
295+noautolink = do
296+ (_, content) <- htmlElement "noautolink"
297+ st <- getState
298+ setState $ st{ stateAllowLinks = False }
299+ blocks <- try $ parseContent content
300+ setState $ st{ stateAllowLinks = True }
301+ return $ mconcat blocks
302+ where
303+ parseContent = parseFromString $ many $ block
304+
305+para :: TWParser B.Blocks
306+para = many1Till inline endOfParaElement >>= return . result . mconcat
307+ where
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
313+ then mempty
314+ else B.para $ B.trimInlines content
315+
316+
317+--
318+-- inline parsers
319+--
320+
321+inline :: TWParser B.Inlines
322+inline = choice [ whitespace
323+ , br
324+ , macro
325+ , strong
326+ , strongHtml
327+ , strongAndEmph
328+ , emph
329+ , emphHtml
330+ , boldCode
331+ , smart
332+ , link
333+ , htmlComment
334+ , code
335+ , codeHtml
336+ , nop
337+ , autoLink
338+ , str
339+ , symbol
340+ ] <?> "inline"
341+
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
346+
347+br :: TWParser B.Inlines
348+br = try $ string "%BR%" >> return B.linebreak
349+
350+linebreak :: TWParser B.Inlines
351+linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
352+ where lastNewline = eof >> return mempty
353+ innerNewline = return B.space
354+
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)
358+
359+enclosed :: (Show a, Monoid b) => TWParser a -> (TWParser a -> TWParser b) -> TWParser b
360+enclosed sep p = between sep (try $ sep <* endMarker) p
361+ where
362+ endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|") <|> eof
363+ endSpace = (spaceChar <|> newline) >> return B.space
364+
365+macro :: TWParser B.Inlines
366+macro = macroWithParameters <|> withoutParameters
367+ where
368+ withoutParameters = enclosed (char '%') (\_ -> macroName) >>= return . emptySpan
369+ emptySpan name = buildSpan name [] mempty
370+
371+macroWithParameters :: TWParser B.Inlines
372+macroWithParameters = try $ do
373+ char '%'
374+ name <- macroName
375+ (content, kvs) <- attributes
376+ char '%'
377+ return $ buildSpan name kvs $ B.str content
378+
379+buildSpan :: String -> [(String, String)] -> B.Inlines -> B.Inlines
380+buildSpan className kvs = B.spanWith attrs
381+ where
382+ attrs = ("", ["twiki-macro", className] ++ additionalClasses, kvsWithoutClasses)
383+ additionalClasses = maybe [] words $ lookup "class" kvs
384+ kvsWithoutClasses = [(k,v) | (k,v) <- kvs, k /= "class"]
385+
386+macroName :: TWParser String
387+macroName = do
388+ first <- letter
389+ rest <- many $ alphaNum <|> char '_'
390+ return (first:rest)
391+
392+attributes :: TWParser (String, [(String, String)])
393+attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>=
394+ return . foldr (either mkContent mkKvs) ([], [])
395+ where
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))
400+
401+attribute :: TWParser (Either String (String, String))
402+attribute = withKey <|> withoutKey
403+ where
404+ withKey = try $ do
405+ key <- macroName
406+ char '='
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 " }"
414+
415+nestedInlines :: Show a => TWParser a -> TWParser B.Inlines
416+nestedInlines end = innerSpace <|> nestedInline
417+ where
418+ innerSpace = try $ whitespace <* (notFollowedBy end)
419+ nestedInline = notFollowedBy whitespace >> nested inline
420+
421+strong :: TWParser B.Inlines
422+strong = try $ enclosed (char '*') nestedInlines >>= return . B.strong
423+
424+strongHtml :: TWParser B.Inlines
425+strongHtml = (parseHtmlContent "strong" inline <|> parseHtmlContent "b" inline)
426+ >>= return . B.strong . mconcat
427+
428+strongAndEmph :: TWParser B.Inlines
429+strongAndEmph = try $ enclosed (string "__") nestedInlines >>= return . B.emph . B.strong
430+
431+emph :: TWParser B.Inlines
432+emph = try $ enclosed (char '_') nestedInlines >>= return . B.emph
433+
434+emphHtml :: TWParser B.Inlines
435+emphHtml = (parseHtmlContent "em" inline <|> parseHtmlContent "i" inline)
436+ >>= return . B.emph . mconcat
437+
438+nestedString :: Show a => TWParser a -> TWParser String
439+nestedString end = innerSpace <|> (count 1 nonspaceChar)
440+ where
441+ innerSpace = try $ many1 spaceChar <* notFollowedBy end
442+
443+boldCode :: TWParser B.Inlines
444+boldCode = try $ enclosed (string "==") nestedString >>= return . B.strong . B.code . fromEntities
445+
446+htmlComment :: TWParser B.Inlines
447+htmlComment = htmlTag isCommentTag >> return mempty
448+
449+code :: TWParser B.Inlines
450+code = try $ enclosed (char '=') nestedString >>= return . B.code . fromEntities
451+
452+codeHtml :: TWParser B.Inlines
453+codeHtml = do
454+ (attrs, content) <- parseHtmlContentWithAttrs "code" anyChar
455+ return $ B.codeWith attrs $ fromEntities content
456+
457+autoLink :: TWParser B.Inlines
458+autoLink = try $ do
459+ state <- getState
460+ guard $ stateAllowLinks state
461+ (text, url) <- parseLink
462+ guard $ checkLink (head $ reverse url)
463+ return $ makeLink (text, url)
464+ where
465+ parseLink = notFollowedBy nop >> (uri <|> emailAddress)
466+ makeLink (text, url) = B.link url "" $ B.str text
467+ checkLink c
468+ | c == '/' = True
469+ | otherwise = isAlphaNum c
470+
471+str :: TWParser B.Inlines
472+str = (many1 alphaNum <|> count 1 characterReference) >>= return . B.str
473+
474+nop :: TWParser B.Inlines
475+nop = try $ (skip exclamation <|> skip nopTag) >> followContent
476+ where
477+ exclamation = char '!'
478+ nopTag = stringAnyCase "<nop>"
479+ followContent = many1 nonspaceChar >>= return . B.str . fromEntities
480+
481+symbol :: TWParser B.Inlines
482+symbol = count 1 nonspaceChar >>= return . B.str
483+
484+smart :: TWParser B.Inlines
485+smart = do
486+ getOption readerSmart >>= guard
487+ doubleQuoted <|> singleQuoted <|>
488+ choice [ apostrophe
489+ , dash
490+ , ellipses
491+ ]
492+
493+singleQuoted :: TWParser B.Inlines
494+singleQuoted = try $ do
495+ singleQuoteStart
496+ withQuoteContext InSingleQuote $
497+ many1Till inline singleQuoteEnd >>=
498+ (return . B.singleQuoted . B.trimInlines . mconcat)
499+
500+doubleQuoted :: TWParser B.Inlines
501+doubleQuoted = try $ do
502+ doubleQuoteStart
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)
507+
508+link :: TWParser B.Inlines
509+link = try $ do
510+ st <- getState
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
516+
517+linkText :: TWParser (String, String, B.Inlines)
518+linkText = do
519+ string "[["
520+ url <- many1Till anyChar (char ']')
521+ content <- option [B.str url] linkContent
522+ char ']'
523+ return (url, "", mconcat content)
524+ where
525+ linkContent = (char '[') >> many1Till anyChar (char ']') >>= parseLinkContent
526+ parseLinkContent = parseFromString $ many1 inline