{-# 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 =
  forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> StateT WriterState m Text
pandocToHaddock WriterOptions
opts{
                  writerWrapText :: WrapOption
writerWrapText = WriterOptions -> WrapOption
writerWrapText WriterOptions
opts } Pandoc
document) 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 forall a. Eq a => a -> a -> Bool
== WrapOption
WrapAuto
                    then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerColumns WriterOptions
opts
                    else forall a. Maybe a
Nothing
  Doc Text
body <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
blocks
  WriterState
st <- forall s (m :: * -> *). MonadState s m => m s
get
  Doc Text
notes' <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Notes -> StateT WriterState m (Doc Text)
notesToHaddock WriterOptions
opts (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ WriterState -> Notes
stNotes WriterState
st)
  let main :: Doc Text
main = Doc Text
body forall a. Semigroup a => a -> a -> a
<> (if forall a. Doc a -> Bool
isEmpty Doc Text
notes' then forall a. Doc a
empty else forall a. Doc a
blankline forall a. Semigroup a => a -> a -> a
<> Doc Text
notes')
  Context Text
metadata <- forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
WriterOptions
-> ([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a))
-> Meta
-> m (Context a)
metaToContext WriterOptions
opts
               (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts)
               (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Doc a -> Doc a
chomp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts)
               Meta
meta
  let context :: Context Text
context  = forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"body" Doc Text
main Context Text
metadata
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
colwidth forall a b. (a -> b) -> a -> b
$
    case WriterOptions -> Maybe (Template Text)
writerTemplate WriterOptions
opts of
          Maybe (Template Text)
Nothing  -> Doc Text
main
          Just Template Text
tpl -> 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null Notes
notes
     then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
empty
     else do
       Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts forall a b. (a -> b) -> a -> b
$ ListAttributes -> Notes -> Block
OrderedList (Int
1,ListNumberStyle
DefaultStyle,ListNumberDelim
DefaultDelim) Notes
notes
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => String -> Doc a
text String
"#notes#" forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline forall a. Semigroup a => a -> a -> a
<> Doc Text
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
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
ils
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
contents forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
blockToHaddock WriterOptions
opts (Plain [Inline]
inlines) = do
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
inlines
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
contents forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
cr
blockToHaddock WriterOptions
opts (Para [Inline]
inlines) =
  -- TODO:  if it contains linebreaks, we need to use a @...@ block
  (forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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) =
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts forall a b. (a -> b) -> a -> b
$ [[Inline]] -> Block
linesToPara [[Inline]]
lns
blockToHaddock WriterOptions
_ b :: Block
b@(RawBlock Format
f Text
str)
  | Format
f forall a. Eq a => a -> a -> Bool
== Format
"haddock" =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal Text
str forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => String -> Doc a
text String
"\n"
  | Bool
otherwise = do
    forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Block -> LogMessage
BlockNotRendered Block
b
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
empty
blockToHaddock WriterOptions
opts Block
HorizontalRule =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Doc a
blankline forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => String -> Doc a
text (forall a. Int -> a -> [a]
replicate (WriterOptions -> Int
writerColumns WriterOptions
opts) Char
'_') forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
blockToHaddock WriterOptions
opts (Header Int
level (Text
ident,[Text]
_,[(Text, Text)]
_) [Inline]
inlines) = do
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
inlines
  let attr' :: Doc Text
attr' = if Text -> Bool
T.null Text
ident
                 then forall a. Doc a
empty
                 else forall a. Doc a
cr forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => String -> Doc a
text String
"#" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
ident forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => String -> Doc a
text String
"#"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Doc a -> Doc a
nowrap (forall a. HasChars a => String -> Doc a
text (forall a. Int -> a -> [a]
replicate Int
level Char
'=') forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
space forall a. Semigroup a => a -> a -> a
<> Doc Text
contents)
                 forall a. Semigroup a => a -> a -> a
<> Doc Text
attr' forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
blockToHaddock WriterOptions
_ (CodeBlock (Text
_,[Text]
_,[(Text, Text)]
_) Text
str) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> Doc a -> Doc a
prefixed String
"> " (forall a. HasChars a => a -> Doc a
literal Text
str) forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
-- Nothing in haddock corresponds to block quotes:
blockToHaddock WriterOptions
opts (BlockQuote [Block]
blocks) =
  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
  Doc Text
caption' <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
caption
  let caption'' :: Doc Text
caption'' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
caption
                     then forall a. Doc a
empty
                     else forall a. Doc a
blankline forall a. Semigroup a => a -> a -> a
<> Doc Text
caption' forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
  Doc Text
tbl <- forall (m :: * -> *) a.
(Monad m, HasChars a) =>
WriterOptions
-> (WriterOptions -> [Block] -> m (Doc a))
-> Bool
-> [Alignment]
-> [Double]
-> Notes
-> [Notes]
-> m (Doc a)
gridTable WriterOptions
opts forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock
              (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (t :: * -> *) a. Foldable t => t a -> Bool
null Notes
headers) (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Alignment
AlignDefault) [Alignment]
aligns)
                [Double]
widths Notes
headers [Notes]
rows
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Doc Text
tbl forall a. Doc a -> Doc a -> Doc a
$$ forall a. Doc a
blankline forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
caption'') forall a. Doc a -> Doc a -> Doc a
$$ forall a. Doc a
blankline
blockToHaddock WriterOptions
opts (BulletList Notes
items) = do
  [Doc Text]
contents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
bulletListItemToHaddock WriterOptions
opts) Notes
items
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (if Notes -> Bool
isTightList Notes
items then forall a. [Doc a] -> Doc a
vcat else forall a. [Doc a] -> Doc a
vsep) [Doc Text]
contents forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
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' = forall a b. (a -> b) -> [a] -> [b]
map (\Text
m -> if Text -> Int
T.length Text
m forall a. Ord a => a -> a -> Bool
< Int
3
                               then Text
m forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
3 forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
m) Text
" "
                               else Text
m) [Text]
markers
  [Doc Text]
contents <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Text -> [Block] -> StateT WriterState m (Doc Text)
orderedListItemToHaddock WriterOptions
opts) [Text]
markers' Notes
items
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (if Notes -> Bool
isTightList Notes
items then forall a. [Doc a] -> Doc a
vcat else forall a. [Doc a] -> Doc a
vsep) [Doc Text]
contents forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
blockToHaddock WriterOptions
opts (DefinitionList [([Inline], Notes)]
items) = do
  [Doc Text]
contents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> ([Inline], Notes) -> StateT WriterState m (Doc Text)
definitionListItemToHaddock WriterOptions
opts) [([Inline], Notes)]
items
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
vcat [Doc Text]
contents forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline
blockToHaddock WriterOptions
opts (Figure Attr
_ (Caption Maybe [Inline]
_ [Block]
longcapt) [Block]
body) =
  -- Haddock has no concept of figures, floats, or captions.
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline) (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts ([Block]
body 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
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
items
  let sps :: String
sps = forall a. Int -> a -> [a]
replicate (WriterOptions -> Int
writerTabStop WriterOptions
opts forall a. Num a => a -> a -> a
- Int
2) Char
' '
  let start :: Doc Text
start = forall a. HasChars a => String -> Doc a
text (Char
'-' forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: String
sps)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang (WriterOptions -> Int
writerTabStop WriterOptions
opts) Doc Text
start Doc Text
contents forall a. Doc a -> Doc a -> Doc a
$$
           if [Block] -> Bool
endsWithPlain [Block]
items
              then forall a. Doc a
cr
              else forall a. Doc a
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
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> StateT WriterState m (Doc Text)
blockListToHaddock WriterOptions
opts [Block]
items
  let sps :: Doc Text
sps = case Text -> Int
T.length Text
marker forall a. Num a => a -> a -> a
- WriterOptions -> Int
writerTabStop WriterOptions
opts of
                   Int
n | Int
n forall a. Ord a => a -> a -> Bool
> Int
0 -> forall a. HasChars a => String -> Doc a
text forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n Char
' '
                   Int
_ -> forall a. HasChars a => String -> Doc a
text String
" "
  let start :: Doc Text
start = forall a. HasChars a => a -> Doc a
literal Text
marker forall a. Semigroup a => a -> a -> a
<> Doc Text
sps
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang (WriterOptions -> Int
writerTabStop WriterOptions
opts) Doc Text
start Doc Text
contents forall a. Doc a -> Doc a -> Doc a
$$
           if [Block] -> Bool
endsWithPlain [Block]
items
              then forall a. Doc a
cr
              else forall a. Doc a
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
  Doc Text
labelText <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
label
  [[Doc Text]]
defs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> StateT WriterState m (Doc Text)
blockToHaddock WriterOptions
opts)) Notes
defs
  let contents :: Doc Text
contents = (if Notes -> Bool
isTightList Notes
defs then forall a. [Doc a] -> Doc a
vcat else forall a. [Doc a] -> Doc a
vsep) forall a b. (a -> b) -> a -> b
$
                 forall a b. (a -> b) -> [a] -> [b]
map (\[Doc Text]
d -> forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang Int
4 forall a. Doc a
empty forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
vcat [Doc Text]
d forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
cr) [[Doc Text]]
defs'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Doc a -> Doc a
nowrap (forall a. HasChars a => Doc a -> Doc a
brackets Doc Text
labelText) forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
contents forall a. Doc a -> Doc a -> Doc a
$$
           if Notes -> Bool
isTightList Notes
defs
              then forall a. Doc a
cr
              else forall a. Doc a
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 =
  forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 =
  forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
ils
  if Bool -> Bool
not (Text -> Bool
T.null Text
ident) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
ils
     then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
ident forall a. Semigroup a => a -> a -> a
<> Doc Text
"#"
     else forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
contents
inlineToHaddock WriterOptions
opts (Emph [Inline]
lst) = do
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"/" forall a. Semigroup a => a -> a -> a
<> Doc Text
contents forall a. Semigroup a => a -> a -> a
<> Doc Text
"/"
-- Underline is not supported, treat the same as Emph
inlineToHaddock WriterOptions
opts (Underline [Inline]
lst) =
  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
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"__" forall a. Semigroup a => a -> a -> a
<> Doc Text
contents forall a. Semigroup a => a -> a -> a
<> Doc Text
"__"
inlineToHaddock WriterOptions
opts (Strikeout [Inline]
lst) = do
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  -- not supported in haddock, but we fake it:
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"~~" forall a. Semigroup a => a -> a -> a
<> Doc Text
contents forall a. Semigroup a => a -> a -> a
<> Doc Text
"~~"
-- not supported in haddock:
inlineToHaddock WriterOptions
opts (Superscript [Inline]
lst) = 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) = 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) = 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
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"‘" forall a. Semigroup a => a -> a -> a
<> Doc Text
contents forall a. Semigroup a => a -> a -> a
<> Doc Text
"’"
inlineToHaddock WriterOptions
opts (Quoted QuoteType
DoubleQuote [Inline]
lst) = do
  Doc Text
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> StateT WriterState m (Doc Text)
inlineListToHaddock WriterOptions
opts [Inline]
lst
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"“" forall a. Semigroup a => a -> a -> a
<> Doc Text
contents forall a. Semigroup a => a -> a -> a
<> Doc Text
"”"
inlineToHaddock WriterOptions
_ (Code Attr
_ Text
str) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"@" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal (Text -> Text
escapeString Text
str) forall a. Semigroup a => a -> a -> a
<> Doc Text
"@"
inlineToHaddock WriterOptions
_ (Str Text
str) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeString Text
str
inlineToHaddock WriterOptions
_ (Math MathType
mt Text
str) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case MathType
mt of
    MathType
DisplayMath -> forall a. Doc a
cr forall a. Semigroup a => a -> a -> a
<> Doc Text
"\\[" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
str forall a. Semigroup a => a -> a -> a
<> Doc Text
"\\]" forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
cr
    MathType
InlineMath  -> Doc Text
"\\(" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
str forall a. Semigroup a => a -> a -> a
<> Doc Text
"\\)"
inlineToHaddock WriterOptions
_ il :: Inline
il@(RawInline Format
f Text
str)
  | Format
f forall a. Eq a => a -> a -> Bool
== Format
"haddock" = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal Text
str
  | Bool
otherwise = do
    forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Inline -> LogMessage
InlineNotRendered Inline
il
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
empty
-- no line break in haddock (see above on CodeBlock)
inlineToHaddock WriterOptions
_ Inline
LineBreak = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
cr
inlineToHaddock WriterOptions
opts Inline
SoftBreak =
  case WriterOptions -> WrapOption
writerWrapText WriterOptions
opts of
       WrapOption
WrapAuto     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
space
       WrapOption
WrapNone     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
space
       WrapOption
WrapPreserve -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
cr
inlineToHaddock WriterOptions
_ Inline
Space = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Doc a
space
inlineToHaddock WriterOptions
opts (Cite [Citation]
_ [Inline]
lst) = 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 = forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeString forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Text
src -> Bool
True
                      [Inline]
_       -> Bool
False
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => Doc a -> Doc a
nowrap forall a b. (a -> b) -> a -> b
$ Doc Text
"<" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
src forall a. Semigroup a => a -> a -> a
<>
           (if Bool
useAuto then forall a. Doc a
empty else forall a. Doc a
space forall a. Semigroup a => a -> a -> a
<> Doc Text
linktext) forall a. Semigroup a => a -> a -> a
<> Doc Text
">"
inlineToHaddock WriterOptions
opts (Image Attr
attr [Inline]
alternate (Text
source, Text
tit)) = do
  Doc Text
linkhaddock <- 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))
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"<" forall a. Semigroup a => a -> a -> a
<> Doc Text
linkhaddock forall a. Semigroup a => a -> a -> a
<> Doc Text
">"
-- haddock doesn't have notes, but we can fake it:
inlineToHaddock WriterOptions
opts (Note [Block]
contents) = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\WriterState
st -> WriterState
st{ stNotes :: Notes
stNotes = [Block]
contents forall a. a -> [a] -> [a]
: WriterState -> Notes
stNotes WriterState
st })
  WriterState
st <- forall s (m :: * -> *). MonadState s m => m s
get
  let ref :: Doc Text
ref = forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ WriterOptions -> Text
writerIdentifierPrefix WriterOptions
opts forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ WriterState -> Notes
stNotes WriterState
st)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
"<#notes [" forall a. Semigroup a => a -> a -> a
<> Doc Text
ref forall a. Semigroup a => a -> a -> a
<> Doc Text
"]>"