@@ -0,0 +1,529 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE NoImplicitPrelude #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TupleSections #-}
5+
6+{-
7+ Copyright (C) 2018-2019 Alexander Krotov <ilabdsf@gmail.com>
8+
9+This program is free software; you can redistribute it and/or modify
10+it under the terms of the GNU General Public License as published by
11+the Free Software Foundation; either version 2 of the License, or
12+(at your option) any later version.
13+
14+This program is distributed in the hope that it will be useful,
15+but WITHOUT ANY WARRANTY; without even the implied warranty of
16+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17+GNU General Public License for more details.
18+
19+You should have received a copy of the GNU General Public License
20+along with this program; if not, write to the Free Software
21+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22+-}
23+
24+{- |
25+ Module : Text.Pandoc.Readers.DokuWiki
26+ Copyright : Copyright (C) 2018 Alexander Krotov
27+ License : GNU GPL, version 2 or above
28+
29+ Maintainer : Alexander Krotov <ilabdsf@gmail.com>
30+ Stability : alpha
31+ Portability : portable
32+
33+Conversion of DokuWiki text to 'Pandoc' document.
34+-}
35+module Text.Pandoc.Readers.DokuWiki (readDokuWiki) where
36+
37+import Prelude
38+import Control.Monad
39+import Control.Monad.Except (throwError)
40+import Data.Char (isAlphaNum, isDigit)
41+import qualified Data.Foldable as F
42+import Data.List (intercalate, transpose, isPrefixOf, isSuffixOf)
43+import Data.List.Split (splitOn)
44+import Data.Maybe (fromMaybe, catMaybes)
45+import Data.Text (Text)
46+import qualified Data.Text as T
47+import qualified Text.Pandoc.Builder as B
48+import Text.Pandoc.Class (PandocMonad (..))
49+import Text.Pandoc.Definition
50+import Text.Pandoc.Error (PandocError (PandocParsecError))
51+import Text.Pandoc.Options
52+import Text.Pandoc.Parsing hiding (enclosed, nested)
53+import Text.Pandoc.Shared (crFilter, trim, underlineSpan)
54+
55+-- | Read DokuWiki from an input string and return a Pandoc document.
56+readDokuWiki :: PandocMonad m
57+ => ReaderOptions
58+ -> Text
59+ -> m Pandoc
60+readDokuWiki opts s = do
61+ let input = crFilter s
62+ res <- runParserT parseDokuWiki def {stateOptions = opts } "source" input
63+ case res of
64+ Left e -> throwError $ PandocParsecError (T.unpack input) e
65+ Right d -> return d
66+
67+type DWParser = ParserT Text ParserState
68+
69+-- * Utility functions
70+
71+-- | Parse end-of-line, which can be either a newline or end-of-file.
72+eol :: Stream s m Char => ParserT s st m ()
73+eol = void newline <|> eof
74+
75+nested :: PandocMonad m => DWParser m a -> DWParser m a
76+nested p = do
77+ nestlevel <- stateMaxNestingLevel <$> getState
78+ guard $ nestlevel > 0
79+ updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 }
80+ res <- p
81+ updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
82+ return res
83+
84+guardColumnOne :: PandocMonad m => DWParser m ()
85+guardColumnOne = getPosition >>= \pos -> guard (sourceColumn pos == 1)
86+
87+-- | Parse DokuWiki document.
88+parseDokuWiki :: PandocMonad m => DWParser m Pandoc
89+parseDokuWiki =
90+ B.doc . mconcat <$> many block <* spaces <* eof
91+
92+-- | Parse <code> and <file> attributes
93+codeLanguage :: PandocMonad m => DWParser m (String, [String], [(String, String)])
94+codeLanguage = try $ do
95+ rawLang <- option "-" (spaceChar *> manyTill anyChar (lookAhead (spaceChar <|> char '>')))
96+ let attr = case rawLang of
97+ "-" -> []
98+ l -> [l]
99+ return ("", attr, [])
100+
101+-- | Generic parser for <code> and <file> tags
102+codeTag :: PandocMonad m
103+ => ((String, [String], [(String, String)]) -> String -> a)
104+ -> String
105+ -> DWParser m a
106+codeTag f tag = try $ f
107+ <$ char '<'
108+ <* string tag
109+ <*> codeLanguage
110+ <* manyTill anyChar (char '>')
111+ <* optional (manyTill spaceChar eol)
112+ <*> manyTill anyChar (try $ string "</" <* string tag <* char '>')
113+
114+-- * Inline parsers
115+
116+-- | Parse any inline element but softbreak.
117+inline' :: PandocMonad m => DWParser m B.Inlines
118+inline' = whitespace
119+ <|> br
120+ <|> bold
121+ <|> italic
122+ <|> underlined
123+ <|> nowiki
124+ <|> percent
125+ <|> link
126+ <|> image
127+ <|> monospaced
128+ <|> subscript
129+ <|> superscript
130+ <|> deleted
131+ <|> footnote
132+ <|> inlineCode
133+ <|> inlineFile
134+ <|> inlineHtml
135+ <|> inlinePhp
136+ <|> autoLink
137+ <|> autoEmail
138+ <|> notoc
139+ <|> nocache
140+ <|> str
141+ <|> symbol
142+ <?> "inline"
143+
144+-- | Parse any inline element, including soft break.
145+inline :: PandocMonad m => DWParser m B.Inlines
146+inline = endline <|> inline'
147+
148+endline :: PandocMonad m => DWParser m B.Inlines
149+endline = try $ B.softbreak <$ skipMany spaceChar <* linebreak
150+
151+whitespace :: PandocMonad m => DWParser m B.Inlines
152+whitespace = try $ B.space <$ skipMany1 spaceChar
153+
154+br :: PandocMonad m => DWParser m B.Inlines
155+br = try $ B.linebreak <$ string "\\\\" <* space
156+
157+linebreak :: PandocMonad m => DWParser m B.Inlines
158+linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
159+ where lastNewline = mempty <$ eof
160+ innerNewline = pure B.space
161+
162+between :: (Monoid c, PandocMonad m, Show b)
163+ => DWParser m a -> DWParser m b -> (DWParser m b -> DWParser m c)
164+ -> DWParser m c
165+between start end p =
166+ mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end)
167+
168+enclosed :: (Monoid b, PandocMonad m, Show a)
169+ => DWParser m a -> (DWParser m a -> DWParser m b) -> DWParser m b
170+enclosed sep p = between sep (try sep) p
171+
172+nestedInlines :: (Show a, PandocMonad m)
173+ => DWParser m a -> DWParser m B.Inlines
174+nestedInlines end = innerSpace <|> nestedInline
175+ where
176+ innerSpace = try $ whitespace <* notFollowedBy end
177+ nestedInline = notFollowedBy whitespace >> nested inline
178+
179+bold :: PandocMonad m => DWParser m B.Inlines
180+bold = try $ B.strong <$> enclosed (string "**") nestedInlines
181+
182+italic :: PandocMonad m => DWParser m B.Inlines
183+italic = try $ B.emph <$> enclosed (string "//") nestedInlines
184+
185+underlined :: PandocMonad m => DWParser m B.Inlines
186+underlined = try $ underlineSpan <$> enclosed (string "__") nestedInlines
187+
188+nowiki :: PandocMonad m => DWParser m B.Inlines
189+nowiki = try $ B.text <$ string "<nowiki>" <*> manyTill anyChar (try $ string "</nowiki>")
190+
191+percent :: PandocMonad m => DWParser m B.Inlines
192+percent = try $ B.text <$> enclosed (string "%%") nestedString
193+
194+nestedString :: (Show a, PandocMonad m)
195+ => DWParser m a -> DWParser m String
196+nestedString end = innerSpace <|> count 1 nonspaceChar
197+ where
198+ innerSpace = try $ many1 spaceChar <* notFollowedBy end
199+
200+monospaced :: PandocMonad m => DWParser m B.Inlines
201+monospaced = try $ B.code <$> enclosed (string "''") nestedString
202+
203+subscript :: PandocMonad m => DWParser m B.Inlines
204+subscript = try $ B.subscript <$> between (string "<sub>") (try $ string "</sub>") nestedInlines
205+
206+superscript :: PandocMonad m => DWParser m B.Inlines
207+superscript = try $ B.superscript <$> between (string "<sup>") (try $ string "</sup>") nestedInlines
208+
209+deleted :: PandocMonad m => DWParser m B.Inlines
210+deleted = try $ B.strikeout <$> between (string "<del>") (try $ string "</del>") nestedInlines
211+
212+-- | Parse a footnote.
213+footnote :: PandocMonad m => DWParser m B.Inlines
214+footnote = try $ B.note . B.para <$> between (string "((") (try $ string "))") nestedInlines
215+
216+inlineCode :: PandocMonad m => DWParser m B.Inlines
217+inlineCode = codeTag B.codeWith "code"
218+
219+inlineFile :: PandocMonad m => DWParser m B.Inlines
220+inlineFile = codeTag B.codeWith "file"
221+
222+inlineHtml :: PandocMonad m => DWParser m B.Inlines
223+inlineHtml = try $ B.rawInline "html" <$ string "<html>" <*> manyTill anyChar (try $ string "</html>")
224+
225+inlinePhp :: PandocMonad m => DWParser m B.Inlines
226+inlinePhp = try $ B.codeWith ("", ["php"], []) <$ string "<php>" <*> manyTill anyChar (try $ string "</php>")
227+
228+makeLink :: (String, String) -> B.Inlines
229+makeLink (text, url) = B.link url "" $ B.str text
230+
231+autoEmail :: PandocMonad m => DWParser m B.Inlines
232+autoEmail = try $ do
233+ state <- getState
234+ guard $ stateAllowLinks state
235+ makeLink <$ char '<' <*> emailAddress <* char '>'
236+
237+autoLink :: PandocMonad m => DWParser m B.Inlines
238+autoLink = try $ do
239+ state <- getState
240+ guard $ stateAllowLinks state
241+ (text, url) <- uri
242+ guard $ checkLink (last url)
243+ return $ makeLink (text, url)
244+ where
245+ checkLink c
246+ | c == '/' = True
247+ | otherwise = isAlphaNum c
248+
249+notoc :: PandocMonad m => DWParser m B.Inlines
250+notoc = try $ mempty <$ string "~~NOTOC~~"
251+
252+nocache :: PandocMonad m => DWParser m B.Inlines
253+nocache = try $ mempty <$ string "~~NOCACHE~~"
254+
255+str :: PandocMonad m => DWParser m B.Inlines
256+str = B.str <$> (many1 alphaNum <|> count 1 characterReference)
257+
258+symbol :: PandocMonad m => DWParser m B.Inlines
259+symbol = B.str <$> count 1 nonspaceChar
260+
261+link :: PandocMonad m => DWParser m B.Inlines
262+link = try $ do
263+ st <- getState
264+ guard $ stateAllowLinks st
265+ setState $ st{ stateAllowLinks = False }
266+ l <- linkText
267+ setState $ st{ stateAllowLinks = True }
268+ return l
269+
270+isExternalLink :: String -> Bool
271+isExternalLink s =
272+ case dropWhile (\c -> isAlphaNum c || (c `elem` ['-', '.', '+'])) s of
273+ (':':'/':'/':_) -> True
274+ _ -> False
275+
276+isAbsolutePath :: String -> Bool
277+isAbsolutePath ('.':_) = False
278+isAbsolutePath s = ':' `elem` s
279+
280+normalizeDots :: String -> String
281+normalizeDots path@('.':_) =
282+ case dropWhile (== '.') path of
283+ ':':_ -> path
284+ _ -> takeWhile (== '.') path ++ ':':dropWhile (== '.') path
285+normalizeDots path = path
286+
287+normalizeInternalPath :: String -> String
288+normalizeInternalPath path =
289+ if isAbsolutePath path
290+ then ensureAbsolute normalizedPath
291+ else normalizedPath
292+ where
293+ normalizedPath = intercalate "/" $ dropWhile (== ".") $ splitOn ":" $ normalizeDots path
294+ ensureAbsolute s@('/':_) = s
295+ ensureAbsolute s = '/':s
296+
297+normalizePath :: String -> String
298+normalizePath path =
299+ if isExternalLink path
300+ then path
301+ else normalizeInternalPath path
302+
303+urlToText :: String -> String
304+urlToText url =
305+ if isExternalLink url
306+ then url
307+ else reverse $ takeWhile (/= ':') $ reverse url
308+
309+-- Parse link or image
310+parseLink :: PandocMonad m
311+ => (String -> Maybe B.Inlines -> B.Inlines)
312+ -> String
313+ -> String
314+ -> DWParser m B.Inlines
315+parseLink f l r = f
316+ <$ string l
317+ <*> many1Till anyChar (lookAhead (void (char '|') <|> try (void $ string r)))
318+ <*> optionMaybe (B.trimInlines . mconcat <$> (char '|' *> manyTill inline (try $ lookAhead $ string r)))
319+ <* string r
320+
321+-- | Split Interwiki link into left and right part
322+-- | Return Nothing if it is not Interwiki link
323+splitInterwiki :: String -> Maybe (String, String)
324+splitInterwiki path =
325+ case span (\c -> isAlphaNum c || c == '.') path of
326+ (l, '>':r) -> Just (l, r)
327+ _ -> Nothing
328+
329+interwikiToUrl :: String -> String -> String
330+interwikiToUrl "callto" page = "callto://" ++ page
331+interwikiToUrl "doku" page = "https://www.dokuwiki.org/" ++ page
332+interwikiToUrl "phpfn" page = "https://secure.php.net/" ++ page
333+interwikiToUrl "tel" page = "tel:" ++ page
334+interwikiToUrl "wp" page = "https://en.wikipedia.org/wiki/" ++ page
335+interwikiToUrl "wpde" page = "https://de.wikipedia.org/wiki/" ++ page
336+interwikiToUrl "wpes" page = "https://es.wikipedia.org/wiki/" ++ page
337+interwikiToUrl "wpfr" page = "https://fr.wikipedia.org/wiki/" ++ page
338+interwikiToUrl "wpjp" page = "https://jp.wikipedia.org/wiki/" ++ page
339+interwikiToUrl "wppl" page = "https://pl.wikipedia.org/wiki/" ++ page
340+interwikiToUrl _ page = "https://www.google.com/search?q=" ++ page ++ "&btnI=lucky"
341+
342+linkText :: PandocMonad m => DWParser m B.Inlines
343+linkText = parseLink fromRaw "[[" "]]"
344+ where
345+ fromRaw path description =
346+ B.link normalizedPath "" (fromMaybe (B.str defaultDescription) description)
347+ where
348+ path' = trim path
349+ interwiki = splitInterwiki path'
350+ normalizedPath =
351+ case interwiki of
352+ Nothing -> normalizePath path'
353+ Just (l, r) -> interwikiToUrl l r
354+ defaultDescription =
355+ case interwiki of
356+ Nothing -> urlToText path'
357+ Just (_, r) -> r
358+
359+-- Matches strings like "100x100" (width x height) and "50" (width)
360+isWidthHeightParameter :: String -> Bool
361+isWidthHeightParameter s =
362+ case s of
363+ (x:xs) ->
364+ isDigit x && case dropWhile isDigit xs of
365+ ('x':ys@(_:_)) -> all isDigit ys
366+ "" -> True
367+ _ -> False
368+ _ -> False
369+
370+parseWidthHeight :: String -> (Maybe String, Maybe String)
371+parseWidthHeight s = (width, height)
372+ where
373+ width = Just $ takeWhile isDigit s
374+ height =
375+ case dropWhile isDigit s of
376+ ('x':xs) -> Just xs
377+ _ -> Nothing
378+
379+image :: PandocMonad m => DWParser m B.Inlines
380+image = parseLink fromRaw "{{" "}}"
381+ where
382+ fromRaw path description =
383+ if linkOnly
384+ then B.link normalizedPath "" (fromMaybe defaultDescription description)
385+ else B.imageWith ("", classes, attributes) normalizedPath "" (fromMaybe defaultDescription description)
386+ where
387+ (path', parameters) = span (/= '?') $ trim path
388+ normalizedPath = normalizePath path'
389+ leftPadding = " " `isPrefixOf` path
390+ rightPadding = " " `isSuffixOf` path
391+ classes =
392+ case (leftPadding, rightPadding) of
393+ (False, False) -> []
394+ (False, True) -> ["align-left"]
395+ (True, False) -> ["align-right"]
396+ (True, True) -> ["align-center"]
397+ parameterList = splitOn "&" $ drop 1 parameters
398+ linkOnly = "linkonly" `elem` parameterList
399+ (width, height) = maybe (Nothing, Nothing) parseWidthHeight (F.find isWidthHeightParameter parameterList)
400+ attributes = catMaybes [fmap ("width",) width, fmap ("height",) height]
401+ defaultDescription = B.str $ urlToText path'
402+
403+-- * Block parsers
404+
405+block :: PandocMonad m => DWParser m B.Blocks
406+block = do
407+ res <- mempty <$ skipMany1 blankline
408+ <|> blockElements
409+ <|> para
410+ skipMany blankline
411+ trace (take 60 $ show $ B.toList res)
412+ return res
413+
414+blockElements :: PandocMonad m => DWParser m B.Blocks
415+blockElements = horizontalLine
416+ <|> header
417+ <|> list " "
418+ <|> indentedCode
419+ <|> quote
420+ <|> blockCode
421+ <|> blockFile
422+ <|> blockHtml
423+ <|> blockPhp
424+ <|> table
425+
426+horizontalLine :: PandocMonad m => DWParser m B.Blocks
427+horizontalLine = try $ B.horizontalRule <$ string "---" <* many1 (char '-') <* eol
428+
429+header :: PandocMonad m => DWParser m B.Blocks
430+header = try $ do
431+ guardColumnOne
432+ eqs <- many1 (char '=')
433+ let lev = length eqs
434+ guard $ lev < 7
435+ contents <- B.trimInlines . mconcat <$> manyTill inline (try $ char '=' *> many1 (char '='))
436+ attr <- registerHeader nullAttr contents
437+ return $ B.headerWith attr (7 - lev) contents
438+
439+list :: PandocMonad m => String -> DWParser m B.Blocks
440+list prefix = bulletList prefix <|> orderedList prefix
441+
442+bulletList :: PandocMonad m => String -> DWParser m B.Blocks
443+bulletList prefix = try $ B.bulletList <$> parseList prefix '*'
444+
445+orderedList :: PandocMonad m => String -> DWParser m B.Blocks
446+orderedList prefix = try $ B.orderedList <$> parseList prefix '-'
447+
448+parseList :: PandocMonad m
449+ => String
450+ -> Char
451+ -> DWParser m [B.Blocks]
452+parseList prefix marker =
453+ many1 ((<>) <$> item <*> fmap mconcat (many continuation))
454+ where
455+ continuation = try $ list (" " ++ prefix)
456+ item = try $ string prefix *> char marker *> char ' ' *> itemContents
457+ itemContents = B.plain . mconcat <$> many1Till inline' eol
458+
459+indentedCode :: PandocMonad m => DWParser m B.Blocks
460+indentedCode = try $ B.codeBlock . unlines <$> many1 indentedLine
461+ where
462+ indentedLine = try $ string " " *> manyTill anyChar eol
463+
464+quote :: PandocMonad m => DWParser m B.Blocks
465+quote = try $ nestedQuote 0
466+ where
467+ prefix level = count level (char '>')
468+ contents level = nestedQuote level <|> quoteLine
469+ quoteLine = try $ B.plain . B.trimInlines . mconcat <$> many1Till inline' eol
470+ quoteContents level = (<>) <$> contents level <*> quoteContinuation level
471+ quoteContinuation level = mconcat <$> many (try $ prefix level *> contents level)
472+ nestedQuote level = B.blockQuote <$ char '>' <*> quoteContents (level + 1 :: Int)
473+
474+blockHtml :: PandocMonad m => DWParser m B.Blocks
475+blockHtml = try $ B.rawBlock "html"
476+ <$ string "<HTML>"
477+ <* optional (manyTill spaceChar eol)
478+ <*> manyTill anyChar (try $ string "</HTML>")
479+
480+blockPhp :: PandocMonad m => DWParser m B.Blocks
481+blockPhp = try $ B.codeBlockWith ("", ["php"], [])
482+ <$ string "<PHP>"
483+ <* optional (manyTill spaceChar eol)
484+ <*> manyTill anyChar (try $ string "</PHP>")
485+
486+table :: PandocMonad m => DWParser m B.Blocks
487+table = do
488+ firstSeparator <- lookAhead tableCellSeparator
489+ rows <- tableRows
490+ let (headerRow, body) = if firstSeparator == '^'
491+ then (head rows, tail rows)
492+ else ([], rows)
493+ let attrs = const (AlignDefault, 0.0) <$> transpose rows
494+ pure $ B.table mempty attrs headerRow body
495+
496+tableRows :: PandocMonad m => DWParser m [[B.Blocks]]
497+tableRows = many1 tableRow
498+
499+tableRow :: PandocMonad m => DWParser m [B.Blocks]
500+tableRow = many1Till tableCell tableRowEnd
501+
502+tableRowEnd :: PandocMonad m => DWParser m Char
503+tableRowEnd = try $ tableCellSeparator <* manyTill spaceChar eol
504+
505+tableCellSeparator :: PandocMonad m => DWParser m Char
506+tableCellSeparator = char '|' <|> char '^'
507+
508+tableCell :: PandocMonad m => DWParser m B.Blocks
509+tableCell = try $ B.plain . B.trimInlines . mconcat <$> (normalCell <|> headerCell)
510+ where
511+ normalCell = char '|' *> manyTill inline' (lookAhead tableCellSeparator)
512+ headerCell = char '^' *> manyTill inline' (lookAhead tableCellSeparator)
513+
514+blockCode :: PandocMonad m => DWParser m B.Blocks
515+blockCode = codeTag B.codeBlockWith "code"
516+
517+blockFile :: PandocMonad m => DWParser m B.Blocks
518+blockFile = codeTag B.codeBlockWith "file"
519+
520+para :: PandocMonad m => DWParser m B.Blocks
521+para = result . mconcat <$> many1Till inline endOfParaElement
522+ where
523+ endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
524+ endOfInput = try $ skipMany blankline >> skipSpaces >> eof
525+ endOfPara = try $ blankline >> skipMany1 blankline
526+ newBlockElement = try $ blankline >> void blockElements
527+ result content = if F.all (==Space) content
528+ then mempty
529+ else B.para $ B.trimInlines content