{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.Haddock
   Copyright   : Copyright (C) 2013 David Lazar
   License     : GNU GPL, version 2 or above

   Maintainer  : David Lazar <lazar6@illinois.edu>,
                 John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha

Conversion of Haddock markup to 'Pandoc' document.
-}
module Text.Pandoc.Readers.Haddock
    ( readHaddock
    ) where

import Control.Monad.Except (throwError)
import Data.List (intersperse)
import Data.List.NonEmpty (nonEmpty)
import Data.Maybe (fromMaybe)
import Data.Text (unpack)
import qualified Data.Text as T
import Documentation.Haddock.Parser
import Documentation.Haddock.Types as H
import Text.Pandoc.Builder (Blocks, Inlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.Options
import Text.Pandoc.Sources (ToSources(..), sourcesToText)
import Text.Pandoc.Shared (splitTextBy, trim)


-- | Parse Haddock markup and return a 'Pandoc' document.
readHaddock :: (PandocMonad m, ToSources a)
            => ReaderOptions
            -> a
            -> m Pandoc
readHaddock :: forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readHaddock ReaderOptions
opts a
s = case ReaderOptions -> String -> Either PandocError Pandoc
readHaddockEither ReaderOptions
opts
                           (Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sources -> Text
sourcesToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToSources a => a -> Sources
toSources forall a b. (a -> b) -> a -> b
$ a
s) of
  Right Pandoc
result -> forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
result
  Left PandocError
e       -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PandocError
e

readHaddockEither :: ReaderOptions -- ^ Reader options
                  -> String        -- ^ String to parse
                  -> Either PandocError Pandoc
readHaddockEither :: ReaderOptions -> String -> Either PandocError Pandoc
readHaddockEither ReaderOptions
_opts =
  forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> Pandoc
B.doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH String Identifier -> Blocks
docHToBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod id. MetaDoc mod id -> DocH mod id
_doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. Maybe String -> String -> MetaDoc mod Identifier
parseParas forall a. Maybe a
Nothing

docHToBlocks :: DocH String Identifier -> Blocks
docHToBlocks :: DocH String Identifier -> Blocks
docHToBlocks DocH String Identifier
d' =
  case DocH String Identifier
d' of
    DocH String Identifier
DocEmpty -> forall a. Monoid a => a
mempty
    DocAppend (DocParagraph (DocHeader Header (DocH String Identifier)
h)) (DocParagraph (DocAName String
ident)) ->
         Attr -> Int -> Inlines -> Blocks
B.headerWith (String -> Text
T.pack String
ident,[],[]) (forall id. Header id -> Int
headerLevel Header (DocH String Identifier)
h)
            (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False forall a b. (a -> b) -> a -> b
$ forall id. Header id -> id
headerTitle Header (DocH String Identifier)
h)
    DocAppend DocH String Identifier
d1 DocH String Identifier
d2 -> forall a. Monoid a => a -> a -> a
mappend (DocH String Identifier -> Blocks
docHToBlocks DocH String Identifier
d1) (DocH String Identifier -> Blocks
docHToBlocks DocH String Identifier
d2)
    DocString String
_ -> Blocks
inlineFallback
    DocParagraph (DocAName String
h) -> Inlines -> Blocks
B.plain forall a b. (a -> b) -> a -> b
$ Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False forall a b. (a -> b) -> a -> b
$ forall mod id. String -> DocH mod id
DocAName String
h
    DocParagraph DocH String Identifier
x -> Inlines -> Blocks
B.para forall a b. (a -> b) -> a -> b
$ Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False DocH String Identifier
x
    DocIdentifier Identifier
_ -> Blocks
inlineFallback
    DocIdentifierUnchecked String
_ -> Blocks
inlineFallback
    DocModule ModLink (DocH String Identifier)
s -> Inlines -> Blocks
B.plain forall a b. (a -> b) -> a -> b
$ Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False forall a b. (a -> b) -> a -> b
$ forall mod id. ModLink (DocH mod id) -> DocH mod id
DocModule ModLink (DocH String Identifier)
s
    DocWarning DocH String Identifier
_ -> forall a. Monoid a => a
mempty -- TODO
    DocEmphasis DocH String Identifier
_ -> Blocks
inlineFallback
    DocMonospaced DocH String Identifier
_ -> Blocks
inlineFallback
    DocBold DocH String Identifier
_ -> Blocks
inlineFallback
    DocMathInline String
_ -> Blocks
inlineFallback
    DocMathDisplay String
_ -> Blocks
inlineFallback
    DocHeader Header (DocH String Identifier)
h -> Int -> Inlines -> Blocks
B.header (forall id. Header id -> Int
headerLevel Header (DocH String Identifier)
h)
                           (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False forall a b. (a -> b) -> a -> b
$ forall id. Header id -> id
headerTitle Header (DocH String Identifier)
h)
    DocUnorderedList [DocH String Identifier]
items -> [Blocks] -> Blocks
B.bulletList (forall a b. (a -> b) -> [a] -> [b]
map DocH String Identifier -> Blocks
docHToBlocks [DocH String Identifier]
items)
#if MIN_VERSION_haddock_library(1,11,0)
    DocOrderedList [(Int, DocH String Identifier)]
items ->
      ListAttributes -> [Blocks] -> Blocks
B.orderedListWith ListAttributes
attr (forall a b. (a -> b) -> [a] -> [b]
map (DocH String Identifier -> Blocks
docHToBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, DocH String Identifier)]
items)
     where
      attr :: ListAttributes
attr = (Int
start, ListNumberStyle
DefaultStyle, ListNumberDelim
DefaultDelim)
      start :: Int
start = case [(Int, DocH String Identifier)]
items of
                [] -> Int
1
                ((Int
n,DocH String Identifier
_):[(Int, DocH String Identifier)]
_) -> Int
n
#else
    DocOrderedList items -> B.orderedList (map docHToBlocks items)
#endif
    DocDefList [(DocH String Identifier, DocH String Identifier)]
items -> [(Inlines, [Blocks])] -> Blocks
B.definitionList (forall a b. (a -> b) -> [a] -> [b]
map (\(DocH String Identifier
d,DocH String Identifier
t) ->
                               (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False DocH String Identifier
d,
                                [Blocks -> Blocks
consolidatePlains forall a b. (a -> b) -> a -> b
$ DocH String Identifier -> Blocks
docHToBlocks DocH String Identifier
t])) [(DocH String Identifier, DocH String Identifier)]
items)
    DocCodeBlock (DocString String
s) -> Attr -> Text -> Blocks
B.codeBlockWith (Text
"",[],[]) forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    DocCodeBlock DocH String Identifier
d -> Inlines -> Blocks
B.para forall a b. (a -> b) -> a -> b
$ Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
True DocH String Identifier
d
    DocHyperlink Hyperlink (DocH String Identifier)
_ -> Blocks
inlineFallback
    DocPic Picture
_ -> Blocks
inlineFallback
    DocAName String
_ -> Blocks
inlineFallback
    DocProperty String
s -> Attr -> Text -> Blocks
B.codeBlockWith (Text
"",[Text
"property",Text
"haskell"],[]) (Text -> Text
trim forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s)
    DocExamples [Example]
es -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Example
e ->
       Text -> String -> [String] -> Blocks
makeExample Text
">>>" (Example -> String
exampleExpression Example
e) (Example -> [String]
exampleResult Example
e)) [Example]
es
    DocTable H.Table{ tableHeaderRows :: forall id. Table id -> [TableRow id]
tableHeaderRows = [TableRow (DocH String Identifier)]
headerRows
                    , tableBodyRows :: forall id. Table id -> [TableRow id]
tableBodyRows = [TableRow (DocH String Identifier)]
bodyRows
                    }
      -> let toCells :: TableRow (DocH String Identifier) -> [Blocks]
toCells = forall a b. (a -> b) -> [a] -> [b]
map (DocH String Identifier -> Blocks
docHToBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. TableCell id -> id
tableCellContents) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. TableRow id -> [TableCell id]
tableRowCells
             toRow :: [Blocks] -> Row
toRow = Attr -> [Cell] -> Row
Row Attr
nullAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Blocks -> Cell
B.simpleCell
             toHeaderRow :: [Blocks] -> [Row]
toHeaderRow [Blocks]
l = [[Blocks] -> Row
toRow [Blocks]
l | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Blocks]
l)]
             ([Blocks]
header, [[Blocks]]
body) =
               if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TableRow (DocH String Identifier)]
headerRows
                  then ([], forall a b. (a -> b) -> [a] -> [b]
map TableRow (DocH String Identifier) -> [Blocks]
toCells [TableRow (DocH String Identifier)]
bodyRows)
                  else (TableRow (DocH String Identifier) -> [Blocks]
toCells (forall a. [a] -> a
head [TableRow (DocH String Identifier)]
headerRows),
                        forall a b. (a -> b) -> [a] -> [b]
map TableRow (DocH String Identifier) -> [Blocks]
toCells (forall a. [a] -> [a]
tail [TableRow (DocH String Identifier)]
headerRows forall a. [a] -> [a] -> [a]
++ [TableRow (DocH String Identifier)]
bodyRows))
             colspecs :: [(Alignment, ColWidth)]
colspecs = forall a. Int -> a -> [a]
replicate (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Blocks]]
body)))
                             (Alignment
AlignDefault, ColWidth
ColWidthDefault)
         in  Caption
-> [(Alignment, ColWidth)]
-> TableHead
-> [TableBody]
-> TableFoot
-> Blocks
B.table Caption
B.emptyCaption
                     [(Alignment, ColWidth)]
colspecs
                     (Attr -> [Row] -> TableHead
TableHead Attr
nullAttr forall a b. (a -> b) -> a -> b
$ [Blocks] -> [Row]
toHeaderRow [Blocks]
header)
                     [Attr -> RowHeadColumns -> [Row] -> [Row] -> TableBody
TableBody Attr
nullAttr RowHeadColumns
0 [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Blocks] -> Row
toRow [[Blocks]]
body]
                     (Attr -> [Row] -> TableFoot
TableFoot Attr
nullAttr [])

  where inlineFallback :: Blocks
inlineFallback = Inlines -> Blocks
B.plain forall a b. (a -> b) -> a -> b
$ Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
False DocH String Identifier
d'
        consolidatePlains :: Blocks -> Blocks
consolidatePlains = forall a. [a] -> Many a
B.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> [Block]
consolidatePlains' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Many a -> [a]
B.toList
        consolidatePlains' :: [Block] -> [Block]
consolidatePlains' zs :: [Block]
zs@(Plain [Inline]
_ : [Block]
_) =
          let ([Block]
xs, [Block]
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Block -> Bool
isPlain [Block]
zs in
          [Inline] -> Block
Para (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Inline]
extractContents [Block]
xs) forall a. a -> [a] -> [a]
: [Block] -> [Block]
consolidatePlains' [Block]
ys
        consolidatePlains' (Block
x : [Block]
xs) = Block
x forall a. a -> [a] -> [a]
: [Block] -> [Block]
consolidatePlains' [Block]
xs
        consolidatePlains' [] = []
        isPlain :: Block -> Bool
isPlain (Plain [Inline]
_) = Bool
True
        isPlain Block
_         = Bool
False
        extractContents :: Block -> [Inline]
extractContents (Plain [Inline]
xs) = [Inline]
xs
        extractContents Block
_          = []

docHToInlines :: Bool -> DocH String Identifier -> Inlines
docHToInlines :: Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
isCode DocH String Identifier
d' =
  case DocH String Identifier
d' of
    DocH String Identifier
DocEmpty -> forall a. Monoid a => a
mempty
    DocAppend DocH String Identifier
d1 DocH String Identifier
d2 -> forall a. Monoid a => a -> a -> a
mappend (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
isCode DocH String Identifier
d1)
                               (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
isCode DocH String Identifier
d2)
    DocString String
s
      | Bool
isCode -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Inlines
B.linebreak
                              forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Inlines
B.code forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
splitTextBy (forall a. Eq a => a -> a -> Bool
==Char
'\n') forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
      | Bool
otherwise  -> Text -> Inlines
B.text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    DocParagraph DocH String Identifier
_ -> forall a. Monoid a => a
mempty
    DocIdentifier Identifier
ident ->
        case forall mod. DocH mod Identifier -> DocH mod String
toRegular (forall mod id. id -> DocH mod id
DocIdentifier Identifier
ident) of
          DocIdentifier String
s -> Attr -> Text -> Inlines
B.codeWith (Text
"",[Text
"haskell",Text
"identifier"],[]) forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
          DocH Any String
_               -> forall a. Monoid a => a
mempty
    DocIdentifierUnchecked String
s -> Attr -> Text -> Inlines
B.codeWith (Text
"",[Text
"haskell",Text
"identifier"],[]) forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    DocModule ModLink (DocH String Identifier)
s -> Attr -> Text -> Inlines
B.codeWith (Text
"",[Text
"haskell",Text
"module"],[]) forall a b. (a -> b) -> a -> b
$
                   String -> Text
T.pack (forall id. ModLink id -> String
modLinkName ModLink (DocH String Identifier)
s)
    DocWarning DocH String Identifier
_ -> forall a. Monoid a => a
mempty -- TODO
    DocEmphasis DocH String Identifier
d -> Inlines -> Inlines
B.emph (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
isCode DocH String Identifier
d)
    DocMonospaced (DocString String
s) -> Text -> Inlines
B.code forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    DocMonospaced DocH String Identifier
d -> Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
True DocH String Identifier
d
    DocBold DocH String Identifier
d -> Inlines -> Inlines
B.strong (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
isCode DocH String Identifier
d)
    DocMathInline String
s -> Text -> Inlines
B.math forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    DocMathDisplay String
s -> Text -> Inlines
B.displayMath forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    DocHeader Header (DocH String Identifier)
_ -> forall a. Monoid a => a
mempty
    DocUnorderedList [DocH String Identifier]
_ -> forall a. Monoid a => a
mempty
    DocOrderedList [(Int, DocH String Identifier)]
_ -> forall a. Monoid a => a
mempty
    DocDefList [(DocH String Identifier, DocH String Identifier)]
_ -> forall a. Monoid a => a
mempty
    DocCodeBlock DocH String Identifier
_ -> forall a. Monoid a => a
mempty
    DocHyperlink Hyperlink (DocH String Identifier)
h -> Text -> Text -> Inlines -> Inlines
B.link (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall id. Hyperlink id -> String
hyperlinkUrl Hyperlink (DocH String Identifier)
h) (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall id. Hyperlink id -> String
hyperlinkUrl Hyperlink (DocH String Identifier)
h)
             (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Inlines
B.text forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall id. Hyperlink id -> String
hyperlinkUrl Hyperlink (DocH String Identifier)
h) (Bool -> DocH String Identifier -> Inlines
docHToInlines Bool
isCode)
               (forall id. Hyperlink id -> Maybe id
hyperlinkLabel Hyperlink (DocH String Identifier)
h))
    DocPic Picture
p -> Text -> Text -> Inlines -> Inlines
B.image (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Picture -> String
pictureUri Picture
p) (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Picture -> String
pictureUri Picture
p) forall a b. (a -> b) -> a -> b
$ Picture -> Maybe String
pictureTitle Picture
p)
                        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Text -> Inlines
B.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) forall a b. (a -> b) -> a -> b
$ Picture -> Maybe String
pictureTitle Picture
p)
    DocAName String
s -> Attr -> Inlines -> Inlines
B.spanWith (String -> Text
T.pack String
s,[Text
"anchor"],[]) forall a. Monoid a => a
mempty
    DocProperty String
_ -> forall a. Monoid a => a
mempty
    DocExamples [Example]
_ -> forall a. Monoid a => a
mempty
    DocTable Table (DocH String Identifier)
_ -> forall a. Monoid a => a
mempty

-- | Create an 'Example', stripping superfluous characters as appropriate
makeExample :: T.Text -> String -> [String] -> Blocks
makeExample :: Text -> String -> [String] -> Blocks
makeExample Text
prompt String
expression [String]
result =
    Inlines -> Blocks
B.para forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Inlines
B.codeWith (Text
"",[Text
"prompt"],[]) Text
prompt
        forall a. Semigroup a => a -> a -> a
<> Inlines
B.space
        forall a. Semigroup a => a -> a -> a
<> Attr -> Text -> Inlines
B.codeWith (Text
"", [Text
"haskell",Text
"expr"], []) (Text -> Text
trim forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
expression)
        forall a. Semigroup a => a -> a -> a
<> Inlines
B.linebreak
        forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Inlines
B.linebreak forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Inlines
coder [Text]
result')
  where
    -- 1. drop trailing whitespace from the prompt, remember the prefix
    prefix :: Text
prefix = (Char -> Bool) -> Text -> Text
T.takeWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
" \t" :: String)) Text
prompt

    -- 2. drop, if possible, the exact same sequence of whitespace
    -- characters from each result line
    --
    -- 3. interpret lines that only contain the string "<BLANKLINE>" as an
    -- empty line
    result' :: [Text]
result' = forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. (Eq a, IsString a) => a -> a
substituteBlankLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
tryStripPrefix Text
prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
result
      where
        tryStripPrefix :: Text -> Text -> Text
tryStripPrefix Text
xs Text
ys = forall a. a -> Maybe a -> a
fromMaybe Text
ys forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
xs Text
ys

        substituteBlankLine :: a -> a
substituteBlankLine a
"<BLANKLINE>" = a
""
        substituteBlankLine a
line          = a
line
    coder :: Text -> Inlines
coder = Attr -> Text -> Inlines
B.codeWith (Text
"", [Text
"result"], [])