{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
   Module      : Text.Pandoc.Writers.Haddock
   Copyright   : Copyright (C) 2014-2015,2017 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to haddock markup.

Haddock:  <http://www.haskell.org/haddock/doc/html/>
-}
module Text.Pandoc.Writers.Haddock (writeHaddock) where
import Control.Monad (zipWithM)
import Control.Monad.State.Strict
    ( StateT, MonadState(get), modify, evalStateT )
import Data.Char (isAlphaNum)
import Data.Default
import Data.Text (Text)
import qualified Data.Text as T
import Text.Pandoc.Class.PandocMonad (PandocMonad, report)
import Text.Pandoc.Definition
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.URI
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.Shared

type Notes = [[Block]]
newtype WriterState = WriterState { WriterState -> Notes
stNotes :: Notes }
instance Default WriterState
  where def :: WriterState
def = WriterState{ stNotes :: Notes
stNotes = [] }

-- | Convert Pandoc to Haddock.
writeHaddock :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHaddock WriterOptions
opts Pandoc
document =
  StateT WriterState m Text -> WriterState -> m Text
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterOptions -> Pandoc -> StateT WriterState m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> StateT WriterState m Text
pandocToHaddock WriterOptions
opts{
                  writerWrapText = writerWrapText opts } Pandoc
document) WriterState
forall a. Default a => a
def

-- | Return haddock representation of document.
pandocToHaddock :: PandocMonad m
                => WriterOptions -> Pandoc -> StateT WriterState m Text
pandocToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> StateT WriterState m Text
pandocToHaddock WriterOptions
opts (Pandoc Meta
meta [Block]
blocks) = do
  let colwidth :: Maybe Int
colwidth = if WriterOptions -> WrapOption
writerWrapText WriterOptions
opts WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapAuto
                    then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerColumns WriterOptions
opts
                    else Maybe Int
forall a. Maybe a
Nothing
  body <- WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
blocks
  st <- get
  notes' <- notesToHaddock opts (reverse $ stNotes st)
  let main = Doc Text
body Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> (if Doc Text -> Bool
forall a. Doc a -> Bool
isEmpty Doc Text
notes' then Doc Text
forall a. Doc a
empty else Doc Text
forall a. Doc a
blankline Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
notes')
  metadata <- metaToContext opts
               (blockListToHaddock opts)
               (fmap chomp . inlineListToHaddock opts)
               meta
  let context  = Text -> Doc Text -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"body" Doc Text
main Context Text
metadata
  return $ render colwidth $
    case writerTemplate opts of
          Maybe (Template Text)
Nothing  -> Doc Text
main
          Just Template Text
tpl -> Template Text -> Context Text -> Doc Text
forall a b.
(TemplateTarget a, ToContext a b) =>
Template a -> b -> Doc a
renderTemplate Template Text
tpl Context Text
context

-- | Return haddock representation of notes.
notesToHaddock :: PandocMonad m
               => WriterOptions -> [[Block]] -> StateT WriterState m (Doc Text)
notesToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Notes -> StateT WriterState m (Doc Text)
notesToHaddock WriterOptions
opts Notes
notes =
  if Notes -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Notes
notes
     then Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
     else do
       contents <- WriterOptions -> Block -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts (Block -> StateT WriterState m (Doc Text))
-> Block -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ ListAttributes -> Notes -> Block
OrderedList (Int
1,ListNumberStyle
DefaultStyle,ListNumberDelim
DefaultDelim) Notes
notes
       return $ text "#notes#" <> blankline <> contents

-- | Escape special characters for Haddock.
escapeString :: Text -> Text
escapeString :: Text -> Text
escapeString Text
t
  | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAlphaNum Text
t = Text
t
  | Bool
otherwise = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escChar Text
t
 where
  escChar :: Char -> Text
escChar Char
'\\' = Text
"\\\\"
  escChar Char
'/'  = Text
"\\/"
  escChar Char
'\'' = Text
"\\'"
  escChar Char
'`'  = Text
"\\`"
  escChar Char
'"'  = Text
"\\\""
  escChar Char
'@'  = Text
"\\@"
  escChar Char
'<'  = Text
"\\<"
  escChar Char
c    = Char -> Text
T.singleton Char
c

-- | Convert Pandoc block element to haddock.
blockToHaddock :: PandocMonad m
               => WriterOptions -- ^ Options
               -> Block         -- ^ Block element
               -> StateT WriterState m (Doc Text)
blockToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts (Div Attr
_ [Block]
ils) = do
  contents <- WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
ils
  return $ contents <> blankline
blockToHaddock WriterOptions
opts (Plain [Inline]
inlines) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
inlines
  return $ contents <> cr
blockToHaddock WriterOptions
opts (Para [Inline]
inlines) =
  -- TODO:  if it contains linebreaks, we need to use a @...@ block
  (Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
blankline) (Doc Text -> Doc Text)
-> StateT WriterState m (Doc Text)
-> StateT WriterState m (Doc Text)
forall a b.
(a -> b) -> StateT WriterState m a -> StateT WriterState m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` WriterOptions -> Block -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts ([Inline] -> Block
Plain [Inline]
inlines)
blockToHaddock WriterOptions
opts (LineBlock [[Inline]]
lns) =
  WriterOptions -> Block -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts (Block -> StateT WriterState m (Doc Text))
-> Block -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ [[Inline]] -> Block
linesToPara [[Inline]]
lns
blockToHaddock WriterOptions
_ b :: Block
b@(RawBlock Format
f Text
str)
  | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
"haddock" =
      Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> String -> Doc Text
forall a. HasChars a => String -> Doc a
text String
"\n"
  | Bool
otherwise = do
    LogMessage -> StateT WriterState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT WriterState m ())
-> LogMessage -> StateT WriterState m ()
forall a b. (a -> b) -> a -> b
$ Block -> LogMessage
BlockNotRendered Block
b
    Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToHaddock WriterOptions
opts Block
HorizontalRule =
  Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
forall a. Doc a
blankline Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> String -> Doc Text
forall a. HasChars a => String -> Doc a
text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (WriterOptions -> Int
writerColumns WriterOptions
opts) Char
'_') Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
blankline
blockToHaddock WriterOptions
opts (Header Int
level (Text
ident,[Text]
_,[(Text, Text)]
_) [Inline]
inlines) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
inlines
  let attr' = if Text -> Bool
T.null Text
ident
                 then Doc Text
forall a. Doc a
empty
                 else Doc Text
forall a. Doc a
cr Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> String -> Doc Text
forall a. HasChars a => String -> Doc a
text String
"#" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
ident Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> String -> Doc Text
forall a. HasChars a => String -> Doc a
text String
"#"
  return $ nowrap (text (replicate level '=') <> space <> contents)
                 <> attr' <> blankline
blockToHaddock WriterOptions
_ (CodeBlock (Text
_,[Text]
_,[(Text, Text)]
_) Text
str) =
  Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ String -> Doc Text -> Doc Text
forall a. IsString a => String -> Doc a -> Doc a
prefixed String
"> " (Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str) Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
blankline
-- Nothing in haddock corresponds to block quotes:
blockToHaddock WriterOptions
opts (BlockQuote [Block]
blocks) =
  WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
blocks
blockToHaddock WriterOptions
opts (Table Attr
_ Caption
blkCapt [ColSpec]
specs TableHead
thead [TableBody]
tbody TableFoot
tfoot) = do
  let ([Inline]
caption, [Alignment]
aligns, [Double]
widths, Notes
headers, [Notes]
rows) = Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> ([Inline], [Alignment], [Double], Notes, [Notes])
toLegacyTable Caption
blkCapt [ColSpec]
specs TableHead
thead [TableBody]
tbody TableFoot
tfoot
  caption' <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
caption
  let caption'' = if [Inline] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
caption
                     then Doc Text
forall a. Doc a
empty
                     else Doc Text
forall a. Doc a
blankline Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
caption' Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
blankline
  tbl <- gridTable opts blockListToHaddock
              (all null headers) (map (const AlignDefault) aligns)
                widths headers rows
  return $ (tbl $$ blankline $$ caption'') $$ blankline
blockToHaddock WriterOptions
opts (BulletList Notes
items) = do
  contents <- ([Block] -> StateT WriterState m (Doc Text))
-> Notes -> StateT WriterState m [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
bulletListItemToHaddock WriterOptions
opts) Notes
items
  return $ (if isTightList items then vcat else vsep) contents <> blankline
blockToHaddock WriterOptions
opts (OrderedList (Int
start,ListNumberStyle
_,ListNumberDelim
delim) Notes
items) = do
  let attribs :: ListAttributes
attribs = (Int
start, ListNumberStyle
Decimal, ListNumberDelim
delim)
  let markers :: [Text]
markers  = ListAttributes -> [Text]
orderedListMarkers ListAttributes
attribs
  let markers' :: [Text]
markers' = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
m -> if Text -> Int
T.length Text
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
                               then Text
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
m) Text
" "
                               else Text
m) [Text]
markers
  contents <- (Text -> [Block] -> StateT WriterState m (Doc Text))
-> [Text] -> Notes -> StateT WriterState m [Doc Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (WriterOptions -> Text -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Text -> [Block] -> StateT WriterState m (Doc Text)
orderedListItemToHaddock WriterOptions
opts) [Text]
markers' Notes
items
  return $ (if isTightList items then vcat else vsep) contents <> blankline
blockToHaddock WriterOptions
opts (DefinitionList [([Inline], Notes)]
items) = do
  contents <- (([Inline], Notes) -> StateT WriterState m (Doc Text))
-> [([Inline], Notes)] -> StateT WriterState m [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (WriterOptions
-> ([Inline], Notes) -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> ([Inline], Notes) -> StateT WriterState m (Doc Text)
definitionListItemToHaddock WriterOptions
opts) [([Inline], Notes)]
items
  return $ vcat contents <> blankline
blockToHaddock WriterOptions
opts (Figure Attr
_ (Caption Maybe [Inline]
_ [Block]
longcapt) [Block]
body) =
  -- Haddock has no concept of figures, floats, or captions.
  (Doc Text -> Doc Text)
-> StateT WriterState m (Doc Text)
-> StateT WriterState m (Doc Text)
forall a b.
(a -> b) -> StateT WriterState m a -> StateT WriterState m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
blankline) (WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts ([Block]
body [Block] -> [Block] -> [Block]
forall a. [a] -> [a] -> [a]
++ [Block]
longcapt))

-- | Convert bullet list item (list of blocks) to haddock
bulletListItemToHaddock :: PandocMonad m
                        => WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
bulletListItemToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
bulletListItemToHaddock WriterOptions
opts [Block]
items = do
  contents <- WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
items
  let sps = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (WriterOptions -> Int
writerTabStop WriterOptions
opts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Char
' '
  let start = String -> Doc Text
forall a. HasChars a => String -> Doc a
text (Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
sps)
  return $ hang (writerTabStop opts) start contents $$
           if endsWithPlain items
              then cr
              else blankline

-- | Convert ordered list item (a list of blocks) to haddock
orderedListItemToHaddock :: PandocMonad m
                         => WriterOptions -- ^ options
                         -> Text        -- ^ list item marker
                         -> [Block]       -- ^ list item (list of blocks)
                         -> StateT WriterState m (Doc Text)
orderedListItemToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Text -> [Block] -> StateT WriterState m (Doc Text)
orderedListItemToHaddock WriterOptions
opts Text
marker [Block]
items = do
  contents <- WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
items
  let sps = case Text -> Int
T.length Text
marker Int -> Int -> Int
forall a. Num a => a -> a -> a
- WriterOptions -> Int
writerTabStop WriterOptions
opts of
                   Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' '
                   Int
_ -> String -> Doc Text
forall a. HasChars a => String -> Doc a
text String
" "
  let start = Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
marker Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
sps
  return $ hang (writerTabStop opts) start contents $$
           if endsWithPlain items
              then cr
              else blankline

-- | Convert definition list item (label, list of blocks) to haddock
definitionListItemToHaddock :: PandocMonad m
                            => WriterOptions
                            -> ([Inline],[[Block]])
                            -> StateT WriterState m (Doc Text)
definitionListItemToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> ([Inline], Notes) -> StateT WriterState m (Doc Text)
definitionListItemToHaddock WriterOptions
opts ([Inline]
label, Notes
defs) = do
  labelText <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
label
  defs' <- mapM (mapM (blockToHaddock opts)) defs
  let contents = (if Notes -> Bool
isTightList Notes
defs then [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat else [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vsep) ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$
                 ([Doc Text] -> Doc Text) -> [[Doc Text]] -> [Doc Text]
forall a b. (a -> b) -> [a] -> [b]
map (\[Doc Text]
d -> Int -> Doc Text -> Doc Text -> Doc Text
forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang Int
4 Doc Text
forall a. Doc a
empty (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat [Doc Text]
d Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
cr) [[Doc Text]]
defs'
  return $ nowrap (brackets labelText) $$ contents $$
           if isTightList defs
              then cr
              else blankline

-- | Convert list of Pandoc block elements to haddock
blockListToHaddock :: PandocMonad m
                   => WriterOptions -- ^ Options
                   -> [Block]       -- ^ List of block elements
                   -> StateT WriterState m (Doc Text)
blockListToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
blocks =
  [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat ([Doc Text] -> Doc Text)
-> StateT WriterState m [Doc Text]
-> StateT WriterState m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> StateT WriterState m (Doc Text))
-> [Block] -> StateT WriterState m [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (WriterOptions -> Block -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts) [Block]
blocks

-- | Convert list of Pandoc inline elements to haddock.
inlineListToHaddock :: PandocMonad m
                    => WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst =
  [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat ([Doc Text] -> Doc Text)
-> StateT WriterState m [Doc Text]
-> StateT WriterState m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> StateT WriterState m (Doc Text))
-> [Inline] -> StateT WriterState m [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (WriterOptions -> Inline -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> StateT WriterState m (Doc Text)
inlineToHaddock WriterOptions
opts) [Inline]
lst

-- | Convert Pandoc inline element to haddock.
inlineToHaddock :: PandocMonad m
                => WriterOptions -> Inline -> StateT WriterState m (Doc Text)
inlineToHaddock :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> StateT WriterState m (Doc Text)
inlineToHaddock WriterOptions
opts (Span (Text
ident,[Text]
_,[(Text, Text)]
_) [Inline]
ils) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
ils
  if not (T.null ident) && null ils
     then return $ "#" <> literal ident <> "#"
     else return contents
inlineToHaddock WriterOptions
opts (Emph [Inline]
lst) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  return $ "/" <> contents <> "/"
-- Underline is not supported, treat the same as Emph
inlineToHaddock WriterOptions
opts (Underline [Inline]
lst) =
  WriterOptions -> Inline -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> StateT WriterState m (Doc Text)
inlineToHaddock WriterOptions
opts ([Inline] -> Inline
Emph [Inline]
lst)
inlineToHaddock WriterOptions
opts (Strong [Inline]
lst) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  return $ "__" <> contents <> "__"
inlineToHaddock WriterOptions
opts (Strikeout [Inline]
lst) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  -- not supported in haddock, but we fake it:
  return $ "~~" <> contents <> "~~"
-- not supported in haddock:
inlineToHaddock WriterOptions
opts (Superscript [Inline]
lst) = WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
-- not supported in haddock:
inlineToHaddock WriterOptions
opts (Subscript [Inline]
lst) = WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
-- not supported in haddock:
inlineToHaddock WriterOptions
opts (SmallCaps [Inline]
lst) = WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
inlineToHaddock WriterOptions
opts (Quoted QuoteType
SingleQuote [Inline]
lst) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  return $ "‘" <> contents <> "’"
inlineToHaddock WriterOptions
opts (Quoted QuoteType
DoubleQuote [Inline]
lst) = do
  contents <- WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  return $ "“" <> contents <> "”"
inlineToHaddock WriterOptions
_ (Code Attr
_ Text
str) =
  Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text
"@" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Text
escapeString Text
str) Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"@"
inlineToHaddock WriterOptions
_ (Str Text
str) =
  Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeString Text
str
inlineToHaddock WriterOptions
_ (Math MathType
mt Text
str) =
  Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ case MathType
mt of
    MathType
DisplayMath -> Doc Text
forall a. Doc a
cr Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"\\[" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"\\]" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
cr
    MathType
InlineMath  -> Doc Text
"\\(" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
"\\)"
inlineToHaddock WriterOptions
_ il :: Inline
il@(RawInline Format
f Text
str)
  | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
"haddock" = Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str
  | Bool
otherwise = do
    LogMessage -> StateT WriterState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT WriterState m ())
-> LogMessage -> StateT WriterState m ()
forall a b. (a -> b) -> a -> b
$ Inline -> LogMessage
InlineNotRendered Inline
il
    Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
-- no line break in haddock (see above on CodeBlock)
inlineToHaddock WriterOptions
_ Inline
LineBreak = Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
cr
inlineToHaddock WriterOptions
opts Inline
SoftBreak =
  case WriterOptions -> WrapOption
writerWrapText WriterOptions
opts of
       WrapOption
WrapAuto     -> Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
       WrapOption
WrapNone     -> Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
       WrapOption
WrapPreserve -> Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
cr
inlineToHaddock WriterOptions
_ Inline
Space = Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
inlineToHaddock WriterOptions
opts (Cite [Citation]
_ [Inline]
lst) = WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
inlineToHaddock WriterOptions
_ (Link Attr
_ [Inline]
txt (Text
src, Text
_)) = do
  let linktext :: Doc Text
linktext = Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeString (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
txt
  let useAuto :: Bool
useAuto = Text -> Bool
isURI Text
src Bool -> Bool -> Bool
&&
                case [Inline]
txt of
                      [Str Text
s] | Text -> Text
escapeURI Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
src -> Bool
True
                      [Inline]
_       -> Bool
False
  Doc Text -> StateT WriterState m (Doc Text)
forall a. a -> StateT WriterState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT WriterState m (Doc Text))
-> Doc Text -> StateT WriterState m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Doc Text -> Doc Text
forall a. IsString a => Doc a -> Doc a
nowrap (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
"<" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
src Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>
           (if Bool
useAuto then Doc Text
forall a. Doc a
empty else Doc Text
forall a. Doc a
space Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
linktext) Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
">"
inlineToHaddock WriterOptions
opts (Image Attr
attr [Inline]
alternate (Text
source, Text
tit)) = do
  linkhaddock <- WriterOptions -> Inline -> StateT WriterState m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> StateT WriterState m (Doc Text)
inlineToHaddock WriterOptions
opts (Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
alternate (Text
source, Text
tit))
  return $ "<" <> linkhaddock <> ">"
-- haddock doesn't have notes, but we can fake it:
inlineToHaddock WriterOptions
opts (Note [Block]
contents) = do
  (WriterState -> WriterState) -> StateT WriterState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WriterState
st -> WriterState
st{ stNotes = contents : stNotes st })
  st <- StateT WriterState m WriterState
forall s (m :: * -> *). MonadState s m => m s
get
  let ref = Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Text
writerIdentifierPrefix WriterOptions
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Notes -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Notes -> Int) -> Notes -> Int
forall a b. (a -> b) -> a -> b
$ WriterState -> Notes
stNotes WriterState
st)
  return $ "<#notes [" <> ref <> "]>"