path: root/src/Text/Pandoc/Readers/DokuWiki.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Readers.DokuWiki
   Copyright   : Copyright (C) 2018-2020 Alexander Krotov
   License     : GNU GPL, version 2 or above

   Maintainer  : Alexander Krotov <[email protected]>
   Stability   : alpha
   Portability : portable

Conversion of DokuWiki text to 'Pandoc' document.
-}
module Text.Pandoc.Readers.DokuWiki (readDokuWiki) where

import Control.Monad
import Control.Monad.Except (throwError)
import Data.Char (isAlphaNum, isDigit)
import qualified Data.Foldable as F
import Data.Maybe (fromMaybe, catMaybes)
import Data.Bifunctor (second)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Parsing hiding (enclosed)
import Text.Pandoc.Shared (trim, stringify, tshow)
import Data.List (isPrefixOf, isSuffixOf, groupBy)
import qualified Safe

-- | Read DokuWiki from an input string and return a Pandoc document.
readDokuWiki :: (PandocMonad m, ToSources a)
             => ReaderOptions
             -> a
             -> m Pandoc
readDokuWiki opts s = do
  let sources = toSources s
  res <- runParserT parseDokuWiki def {stateOptions = opts }
           (initialSourceName sources) sources
  case res of
       Left e  -> throwError $ fromParsecError sources e
       Right d -> return d

type DWParser = ParsecT Sources ParserState

-- * Utility functions

-- | Parse end-of-line, which can be either a newline or end-of-file.
eol :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m ()
eol = void newline <|> eof

guardColumnOne :: PandocMonad m => DWParser m ()
guardColumnOne = getPosition >>= \pos -> guard (sourceColumn pos == 1)

-- | Parse DokuWiki document.
parseDokuWiki :: PandocMonad m => DWParser m Pandoc
parseDokuWiki =
  B.doc . mconcat <$> many block <* spaces <* eof

-- | Parse <code> and <file> attributes
codeLanguage :: PandocMonad m => DWParser m (Text, [Text], [(Text, Text)])
codeLanguage = try $ do
  rawLang <- option "-" (spaceChar *> manyTillChar anyChar (lookAhead (spaceChar <|> char '>')))
  let attr = case rawLang of
               "-" -> []
               l -> [l]
  return ("", attr, [])

-- | Generic parser for <code> and <file> tags
codeTag :: PandocMonad m
        => ((Text, [Text], [(Text, Text)]) -> Text -> a)
        -> Text
        -> DWParser m a
codeTag f tag = try $ f
  <$  char '<'
  <*  textStr tag
  <*> codeLanguage
  <*  manyTill anyChar (char '>')
  <*  optional (manyTill spaceChar eol)
  <*> manyTillChar anyChar (try $ string "</" <* textStr tag <* char '>')

-- * Inline parsers

-- | Parse any inline element but softbreak.
inline' :: PandocMonad m => DWParser m B.Inlines
inline' = whitespace
      <|> inline''

-- | Parse any inline element but whitespace.
inline'' :: PandocMonad m => DWParser m B.Inlines
inline'' = br
      <|> bold
      <|> italic
      <|> underlined
      <|> nowiki
      <|> percent
      <|> link
      <|> image
      <|> monospaced
      <|> subscript
      <|> superscript
      <|> deleted
      <|> footnote
      <|> inlineRaw
      <|> math
      <|> autoLink
      <|> autoEmail
      <|> notoc
      <|> nocache
      <|> smartPunctuation inline
      <|> str
      <|> symbol
      <?> "inline"

-- | Parse any inline element but soft breaks and do not consolidate spaces.
inlineUnconsolidatedWhitespace :: PandocMonad m => DWParser m B.Inlines
inlineUnconsolidatedWhitespace = (B.space <$ spaceChar) <|> inline'

-- | Parse any inline element, including soft break.
inline :: PandocMonad m => DWParser m B.Inlines
inline = endline <|> inline'

endline :: PandocMonad m => DWParser m B.Inlines
endline = try $ B.softbreak <$ skipMany spaceChar <* linebreak

whitespace :: PandocMonad m => DWParser m B.Inlines
whitespace = try $ B.space <$ skipMany1 spaceChar

br :: PandocMonad m => DWParser m B.Inlines
br = try $ B.linebreak <$ string "\\\\" <* space

linebreak :: PandocMonad m => DWParser m B.Inlines
linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)
  where lastNewline  = mempty <$ eof
        innerNewline = pure B.space

between :: (Monoid c, PandocMonad m, Show b)
        => DWParser m a -> DWParser m b -> (DWParser m b -> DWParser m c)
        -> DWParser m c
between start end p =
  mconcat <$> try (start >> notFollowedBy whitespace >> many1Till (p end) end)

enclosed :: (Monoid b, PandocMonad m, Show a)
         => DWParser m a -> (DWParser m a -> DWParser m b) -> DWParser m b
enclosed sep p = between sep (try sep) p

nestedInlines :: (Show a, PandocMonad m)
              => DWParser m a -> DWParser m B.Inlines
nestedInlines end = innerSpace <|> nestedInline
  where
    innerSpace   = try $ whitespace <* notFollowedBy end
    nestedInline = notFollowedBy whitespace >> inline

bold :: PandocMonad m => DWParser m B.Inlines
bold = try $ B.strong <$> enclosed (string "**") nestedInlines

italic :: PandocMonad m => DWParser m B.Inlines
italic = try $ B.emph <$> enclosed (string "//") nestedInlines

underlined :: PandocMonad m => DWParser m B.Inlines
underlined = try $ B.underline <$> enclosed (string "__") nestedInlines

nowiki :: PandocMonad m => DWParser m B.Inlines
nowiki = try $ B.text <$ string "<nowiki>" <*> manyTillChar anyChar (try $ string "</nowiki>")

percent :: PandocMonad m => DWParser m B.Inlines
percent = try $ B.text <$> enclosed (string "%%") nestedText

nestedText :: (Show a, PandocMonad m)
             => DWParser m a -> DWParser m Text
nestedText end = innerSpace <|> countChar 1 nonspaceChar
  where
    innerSpace = try $ many1Char spaceChar <* notFollowedBy end

monospaced :: PandocMonad m => DWParser m B.Inlines
monospaced = try $ B.code . (T.concat . map stringify . B.toList) <$> enclosed (string "''") nestedInlines

subscript :: PandocMonad m => DWParser m B.Inlines
subscript = try $ B.subscript <$> between (string "<sub>") (try $ string "</sub>") nestedInlines

superscript :: PandocMonad m => DWParser m B.Inlines
superscript = try $ B.superscript <$> between (string "<sup>") (try $ string "</sup>") nestedInlines

deleted :: PandocMonad m => DWParser m B.Inlines
deleted = try $ B.strikeout <$> between (string "<del>") (try $ string "</del>") nestedInlines

-- | Parse a footnote.
footnote :: PandocMonad m => DWParser m B.Inlines
footnote = try $ B.note . B.para <$> between (string "((") (try $ string "))") nestedInlines

inlineRaw :: PandocMonad m => DWParser m B.Inlines
inlineRaw = try $ do
  char '<'
  fmt <- oneOfStrings ["html", "php", "latex"]
  -- LaTeX via https://www.dokuwiki.org/plugin:latex
  char '>'
  contents <- manyTillChar anyChar
                (try $ string "</" *> string (T.unpack fmt) *> char '>')
  return $
    case T.toLower fmt of
         "php" -> B.rawInline "html" $ "<?php " <> contents <> " ?>"
         f -> B.rawInline f contents

-- see https://www.dokuwiki.org/plugin:latex
math :: PandocMonad m => DWParser m B.Inlines
math = (B.displayMath <$> mathDisplay) <|> (B.math <$> mathInline)

makeLink :: (Text, Text) -> B.Inlines
makeLink (text, url) = B.link url "" $ B.str text

autoEmail :: PandocMonad m => DWParser m B.Inlines
autoEmail = try $ do
  state <- getState
  guard $ stateAllowLinks state
  makeLink <$ char '<' <*> emailAddress <* char '>'

autoLink :: PandocMonad m => DWParser m B.Inlines
autoLink = try $ do
  state <- getState
  guard $ stateAllowLinks state
  (text, url) <- uri
  guard $ not $ T.isInfixOf "%%//%%" text  -- see #9153
  guard $ checkLink (T.last url)
  return $ makeLink (text, url)
  where
    checkLink c
      | c == '/' = True
      | otherwise = isAlphaNum c

notoc :: PandocMonad m => DWParser m B.Inlines
notoc = try $ mempty <$ string "~~NOTOC~~"

nocache :: PandocMonad m => DWParser m B.Inlines
nocache = try $ mempty <$ string "~~NOCACHE~~"

str :: PandocMonad m => DWParser m B.Inlines
str = B.str <$> (many1Char alphaNum <|> characterReference)

symbol :: PandocMonad m => DWParser m B.Inlines
symbol = B.str <$> (notFollowedBy' blockCode *> countChar 1 nonspaceChar)

link :: PandocMonad m => DWParser m B.Inlines
link = try $ do
  st <- getState
  guard $ stateAllowLinks st
  setState $ st{ stateAllowLinks = False }
  l <- linkText
  setState $ st{ stateAllowLinks = True }
  return l

isExternalLink :: Text -> Bool
isExternalLink s = "://" `T.isPrefixOf` sSuff
  where
    sSuff = T.dropWhile (\c -> isAlphaNum c || (c `elem` ['-', '.', '+'])) s

isAbsolutePath :: Text -> Bool
isAbsolutePath (T.uncons -> Just ('.', _)) = False
isAbsolutePath s = T.any (== ':') s

normalizeDots :: Text -> Text
normalizeDots path
  | not (T.null pref) = case T.uncons suff of
      Just (':', _) -> path
      _             -> pref <> ":" <> suff
  | otherwise = path
  where
    (pref, suff) = T.span (== '.') path

normalizeInternalPath :: Text -> Text
normalizeInternalPath path =
  if isAbsolutePath path
    then ensureAbsolute normalizedPath
    else normalizedPath
  where
    normalizedPath = T.intercalate "/" $ dropWhile (== ".") $ T.splitOn ":" $ normalizeDots path
    ensureAbsolute s@(T.uncons -> Just ('/', _)) = s
    ensureAbsolute s = "/" <> s

normalizePath :: Text -> Text
normalizePath path =
  if isExternalLink path
    then path
    else normalizeInternalPath path

urlToText :: Text -> Text
urlToText url =
  if isExternalLink url
    then url
    else T.takeWhileEnd (/= ':') url

-- Parse link or image
parseLink :: PandocMonad m
          => (Text -> Maybe B.Inlines -> B.Inlines)
          -> Text
          -> Text
          -> DWParser m B.Inlines
parseLink f l r = f
  <$  textStr l
  <*> many1TillChar anyChar (lookAhead (void (char '|') <|> try (void $ textStr r)))
  <*> ( (char '|' *> optionMaybe (B.trimInlines . B.text . T.pack <$>
                       many1Till anyChar (lookAhead (try (textStr r)))))
       <|> pure Nothing
      )
  <* textStr r

-- | Split Interwiki link into left and right part
-- | Return Nothing if it is not Interwiki link
splitInterwiki :: Text -> Maybe (Text, Text)
splitInterwiki path =
  case T.span (\c -> isAlphaNum c || c == '.') path of
    (l, T.uncons -> Just ('>', r)) -> Just (l, r)
    _ -> Nothing

interwikiToUrl :: Text -> Text -> Text
interwikiToUrl "callto" page = "callto://" <> page
interwikiToUrl "doku" page = "https://www.dokuwiki.org/" <> page
interwikiToUrl "phpfn" page = "https://secure.php.net/" <> page
interwikiToUrl "tel" page = "tel:" <> page
interwikiToUrl "wp" page = "https://en.wikipedia.org/wiki/" <> page
interwikiToUrl "wpde" page = "https://de.wikipedia.org/wiki/" <> page
interwikiToUrl "wpes" page = "https://es.wikipedia.org/wiki/" <> page
interwikiToUrl "wpfr" page = "https://fr.wikipedia.org/wiki/" <> page
interwikiToUrl "wpjp" page = "https://jp.wikipedia.org/wiki/" <> page
interwikiToUrl "wppl" page = "https://pl.wikipedia.org/wiki/" <> page
interwikiToUrl unknown page = unknown <> ">" <> page

linkText :: PandocMonad m => DWParser m B.Inlines
linkText = parseLink fromRaw "[[" "]]"
  where
    fromRaw path description =
      B.link normalizedPath "" (fromMaybe (B.str defaultDescription) description)
      where
        path' = trim path
        interwiki = splitInterwiki path'
        normalizedPath =
          case interwiki of
            Nothing -> normalizePath path'
            Just (l, r) -> interwikiToUrl l r
        defaultDescription =
          case interwiki of
            Nothing -> urlToText path'
            Just (_, r) -> r

-- Matches strings like "100x100" (width x height) and "50" (width)
isWidthHeightParameter :: Text -> Bool
isWidthHeightParameter s =
  case T.uncons s of
    Just (x, xs) ->
      isDigit x && case T.uncons $ T.dropWhile isDigit xs of
                     Just ('x', ys) | not (T.null ys) -> T.all isDigit ys
                     Nothing -> True
                     _ -> False
    _ -> False

parseWidthHeight :: Text -> (Maybe Text, Maybe Text)
parseWidthHeight s = (width, height)
  where
    width = Just $ T.takeWhile isDigit s
    height =
      case T.uncons $ T.dropWhile isDigit s of
        Just ('x', xs) -> Just xs
        _ -> Nothing

image :: PandocMonad m => DWParser m B.Inlines
image = try $ parseLink fromRaw "{{" "}}"
  where
    fromRaw path description =
      if linkOnly
        then B.link normalizedPath "" (fromMaybe defaultDescription description)
        else B.imageWith ("", classes, attributes) normalizedPath "" (fromMaybe defaultDescription description)
      where
        (path', parameters) = T.span (/= '?') $ trim path
        normalizedPath = normalizePath path'
        leftPadding = " " `T.isPrefixOf` path
        rightPadding = " " `T.isSuffixOf` path
        classes =
          case (leftPadding, rightPadding) of
            (False, False) -> []
            (False, True) -> ["align-left"]
            (True, False) -> ["align-right"]
            (True, True) -> ["align-center"]
        parameterList = T.splitOn "&" $ T.drop 1 parameters
        linkOnly = "linkonly" `elem` parameterList
        (width, height) = maybe (Nothing, Nothing) parseWidthHeight (F.find isWidthHeightParameter parameterList)
        attributes = catMaybes [
                fmap ("width",) width,
                fmap ("height",) height,
                fmap ("query",) (if T.null parameters then Nothing else Just parameters)
            ]
        defaultDescription = B.str $ urlToText path'

-- * Block parsers

block :: PandocMonad m => DWParser m B.Blocks
block = do
  res <- mempty <$ skipMany1 blankline
         <|> blockElements
         <|> para
  skipMany blankline
  trace (T.take 60 $ tshow $ B.toList res)
  return res

blockElements :: PandocMonad m => DWParser m B.Blocks
blockElements = horizontalLine
            <|> header
            <|> list "  "
            <|> indentedCode
            <|> quote
            <|> blockCode
            <|> blockRaw
            <|> table

horizontalLine :: PandocMonad m => DWParser m B.Blocks
horizontalLine = try $ B.horizontalRule <$ string "---" <* many1 (char '-') <* eol

header :: PandocMonad m => DWParser m B.Blocks
header = try $ do
  guardColumnOne
  eqs <- many1 (char '=')
  let lev = length eqs
  guard $ lev < 7
  contents <- B.trimInlines . mconcat <$> manyTill inline (try $ char '=' *> many1 (char '='))
  attr <- registerHeader nullAttr contents
  return $ B.headerWith attr (7 - lev) contents

list :: PandocMonad m => Text -> DWParser m B.Blocks
list prefix = bulletList prefix <|> orderedList prefix

bulletList :: PandocMonad m => Text -> DWParser m B.Blocks
bulletList prefix = try $ B.bulletList <$> parseList prefix '*'

orderedList :: PandocMonad m => Text -> DWParser m B.Blocks
orderedList prefix = try $ B.orderedList <$> parseList prefix '-'

parseList :: PandocMonad m
          => Text
          -> Char
          -> DWParser m [B.Blocks]
parseList prefix marker =
  many1 ((<>) <$> item <*> fmap mconcat (many continuation))
  where
    continuation = try $ list ("  " <> prefix)
    item = try $ textStr prefix *>
                   optional (char ' ') *>  -- see #8863
                   char marker *> char ' ' *>
                   (mconcat <$> many1 itemContents <* eol)
    itemContents = (B.plain . mconcat <$> many1 inline') <|>
                   blockCode

indentedCode :: PandocMonad m => DWParser m B.Blocks
indentedCode = try $ B.codeBlock . T.unlines <$> many1 indentedLine
 where
   indentedLine = try $ string "  " *> manyTillChar anyChar eol

-- Note that block quotes in dokuwiki parse as lists of hard-break
-- separated lines; see #6461.
quote :: PandocMonad m => DWParser m B.Blocks
quote = go <$> many1 blockQuoteLine
 where
   blockQuoteLine = try $ do
     lev <- length <$> many1 (char '>')
     skipMany spaceChar
     contents <- (blockCode <* skipMany spaceChar <* optional eol) <|>
       (B.plain . B.trimInlines . mconcat <$> many1Till inline' eol)
     pure (lev, contents)
   go [] = mempty
   go xs = mconcat $ map go' (groupBy (\(x,_) (y,_) -> (x == 0 && y == 0) ||
                                                        (x > 0 && y > 0)) xs)
   go' [] = mempty
   go' xs@((0,_):_) =
        let (lns, bls) = F.foldl' consolidatePlains (mempty,mempty) (map snd xs)
         in bls <> if lns == mempty
                      then mempty
                      else B.plain lns
   go' xs = B.blockQuote (go $ map (\(x,y) -> (x - 1, y)) xs)
   consolidatePlains (lns, bls) b =
     case B.toList b of
       [Plain ils] -> ((if lns == mempty
                           then B.fromList ils
                           else lns <> B.linebreak <> B.fromList ils), bls)
       _ -> (mempty, bls <>
                     (if lns == lns
                         then mempty
                         else B.plain lns)
                      <> b)

blockRaw :: PandocMonad m => DWParser m B.Blocks
blockRaw = try $ do
  char '<'
  fmt <- oneOfStrings ["HTML", "PHP", "LATEX"]
  -- LaTeX via https://www.dokuwiki.org/plugin:latex
  char '>'
  optional (manyTill spaceChar eol)
  contents <- manyTillChar anyChar
               (try $ string "</" *> string (T.unpack fmt) *> char '>')
  return $
    case T.toLower fmt of
         "php" -> B.rawBlock "html" $ "<?php " <> contents <> " ?>"
         f -> B.rawBlock f contents

table :: PandocMonad m => DWParser m B.Blocks
table = do
  firstSeparator <- lookAhead tableCellSeparator
  rows <- tableRows
  let firstRow = fromMaybe [] . Safe.headMay $ rows
  let (headerRow, body) = if firstSeparator == '^'
                            then (firstRow, drop 1 rows)
                            else ([], rows)
  -- Since Pandoc only has column level alignment, we have to make an arbitrary
  -- choice of how to reconcile potentially different alignments in the row.
  -- Here we end up assuming that the alignment of the header / first row is
  -- what the user wants to apply to the whole thing.
  let attrs =  map (\(a, _) -> (a, ColWidthDefault)) firstRow
  let toRow = Row nullAttr . map B.simpleCell
      toHeaderRow l = [toRow l | not (null l)]
  pure $ B.table B.emptyCaption
                 attrs
                 (TableHead nullAttr $ toHeaderRow (map snd headerRow))
                 [TableBody nullAttr 0 [] $ map (toRow . (map snd)) body]
                 (TableFoot nullAttr [])


tableRows :: PandocMonad m => DWParser m [[(Alignment, B.Blocks)]]
tableRows = many1 tableRow

tableRow :: PandocMonad m => DWParser m [(Alignment, B.Blocks)]
tableRow = many1Till tableCell tableRowEnd

tableRowEnd :: PandocMonad m => DWParser m Char
tableRowEnd = try $ tableCellSeparator <* manyTill spaceChar eol

tableCellSeparator :: PandocMonad m => DWParser m Char
tableCellSeparator = char '|' <|> char '^'

tableCell :: PandocMonad m => DWParser m (Alignment, B.Blocks)
tableCell = try $ (second (B.plain . B.trimInlines . mconcat)) <$> cellContent
  where
    cellContent = do
      -- https://www.dokuwiki.org/wiki:syntax#tables
      -- DokuWiki represents the alignment of cells with two spaces padding.
      tableCellSeparator
      cellInline <- manyTill inlineUnconsolidatedWhitespace (lookAhead tableCellSeparator)
      let left  = [B.space, B.space] `isPrefixOf` cellInline
      let right = [B.space, B.space] `isSuffixOf` cellInline
      let alignment = case (left, right) of
                           (True, True)   -> AlignCenter
                           (True, False)  -> AlignRight
                           (False, True)  -> AlignLeft
                           (False, False) -> AlignDefault
      return (alignment, cellInline)


blockCode :: PandocMonad m => DWParser m B.Blocks
blockCode = codeTag B.codeBlockWith "code" <|>
            codeTag B.codeBlockWith "file"

para :: PandocMonad m => DWParser m B.Blocks
para = result . mconcat <$> many1Till inline endOfParaElement
 where
   endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
   endOfInput       = try $ skipMany blankline >> skipSpaces >> eof
   endOfPara        = try $ blankline >> skipMany1 blankline
   newBlockElement  = try (blankline >> void blockElements)
                       <|> lookAhead (void blockCode)
   result content   = if F.all (==Space) content
                      then mempty
                      else B.para $ B.trimInlines content