blob: 297d30d61dc2b1d5e04f90ccc7ad73fc1922b817 (
plain) (
tree)
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Documentation.Haddock.Doc (docParagraph, docAppend,
docConcat, metaDocConcat,
metaDocAppend, emptyMetaDoc,
metaAppend, metaConcat) where
import Control.Applicative ((<|>), empty)
import Documentation.Haddock.Types
import Data.Char (isSpace)
docConcat :: [DocH mod id] -> DocH mod id
docConcat = foldr docAppend DocEmpty
-- | Concat using 'metaAppend'.
metaConcat :: [Meta] -> Meta
metaConcat = foldr metaAppend emptyMeta
-- | Like 'docConcat' but also joins the 'Meta' info.
metaDocConcat :: [MetaDoc mod id] -> MetaDoc mod id
metaDocConcat = foldr metaDocAppend emptyMetaDoc
-- | We do something perhaps unexpected here and join the meta info
-- in ‘reverse’: this results in the metadata from the ‘latest’
-- paragraphs taking precedence.
metaDocAppend :: MetaDoc mod id -> MetaDoc mod id -> MetaDoc mod id
metaDocAppend (MetaDoc { _meta = m, _doc = d })
(MetaDoc { _meta = m', _doc = d' }) =
MetaDoc { _meta = m' `metaAppend` m, _doc = d `docAppend` d' }
-- | This is not a monoidal append, it uses '<|>' for the '_version' and
-- '_package'.
metaAppend :: Meta -> Meta -> Meta
metaAppend (Meta v1 p1) (Meta v2 p2) = Meta (v1 <|> v2) (p1 <|> p2)
emptyMetaDoc :: MetaDoc mod id
emptyMetaDoc = MetaDoc { _meta = emptyMeta, _doc = DocEmpty }
emptyMeta :: Meta
emptyMeta = Meta empty empty
docAppend :: DocH mod id -> DocH mod id -> DocH mod id
docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)
docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) = DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend DocEmpty d = d
docAppend d DocEmpty = d
docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2)
docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2))
docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d
docAppend d1 d2 = DocAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph :: DocH mod id -> DocH mod id
docParagraph (DocMonospaced p)
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
| all isSpace s1
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1)
(DocAppend (DocMonospaced p) (DocString s2)))
| all isSpace s1 && all isSpace s2
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocMonospaced p) (DocString s2))
| all isSpace s2
= DocCodeBlock (docCodeBlock p)
docParagraph p
= DocParagraph p
-- Drop trailing whitespace from @..@ code blocks. Otherwise this:
--
-- -- @
-- -- foo
-- -- @
--
-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
-- gives an extra vertical space after the code block. The single space
-- on the final line seems to trigger the extra vertical space.
--
docCodeBlock :: DocH mod id -> DocH mod id
docCodeBlock (DocString s)
= DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
docCodeBlock (DocAppend l r)
= DocAppend l (docCodeBlock r)
docCodeBlock d = d
|