Haddock.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Render.Lib.Haddock where

import Control.Monad.Reader
import Data.Char (isSpace)
import Data.List.Compat
import Data.List.Split
import Data.Monoid.Compat
import Documentation.Haddock.Parser (Identifier)
import Documentation.Haddock.Types
import Prelude.Compat
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))

data FlattenBehavior
  = Flatten
  | WordBreak

data TextPosition
  = ParaStart
  | Body
  deriving (Eq)

data DocContext = DocContext
  { flattenBehavior :: FlattenBehavior
  , textPosition :: TextPosition
  , listContext :: Bool
  }

flattenedBody = withReader $ \d -> d {flattenBehavior = Flatten, textPosition = Body}

inPara = withReader $ \d -> d {textPosition = ParaStart}

inBody = withReader $ \d -> d {textPosition = Body}

inList = withReader $ \d -> d {listContext = True}

defaultDocContext = DocContext WordBreak ParaStart False

-- sadly can't use the built-in haddock markup functionality here. we need
-- to change rendering logic entirely inside a code block (i.e. don't
-- fillSep words).
renderDescription =
  vcat . intersperse (green ".") . map ((`runReader` defaultDocContext) . go) . flatten
  where
    flatten (DocAppend d1 d2) = flatten d1 ++ flatten d2
    flatten d = [d]
    -- flatten inline styling which the haddock parser doesn't preserve
    -- across line boundaries
    go :: DocH () Identifier -> Reader DocContext Doc
    go DocEmpty = pure empty
    go (DocEmphasis d) = enclose (green "/") (green "/") <$> flattenedBody (go d)
    go (DocMonospaced d) = enclose (green "@") (green "@") <$> flattenedBody (go d)
    go (DocBold d) = enclose (green "__") (green "__") <$> flattenedBody (go d)
    go (DocHeader (Header l t)) =
      (green (strBody $ replicate l '=') <+>) <$> inBody (go t)
    go (DocAppend a b) = liftM2 (<>) (go a) (inBody $ go b)
    go (DocParagraph d) = inPara $ go d
    go (DocUnorderedList ds) = do
      docs <-
        forM ds $ \item -> do
          doc <- inList $ inPara $ go item
          return $ hang 2 $ string "*" <+> doc
      return $ vcat docs
    go (DocOrderedList ds) = do
      docs <-
        forM (zip [1 ..] ds) $ \(n, item) -> do
          doc <- inList $ inPara $ go item
          return $ hang 3 $ integer n <> "." <+> doc
      return $ vcat docs
    go (DocCodeBlock cb) = do
      DocContext {..} <- ask
      return $
        case cb of
          DocString s
            | all (`notElem` ['{', '}']) s && not listContext ->
              green ">" <+> arrowblock s
            | listContext && notElem '\n' s -> cat [green "@", string s, green "@"]
          y -> vcat [green "@", goplain y <> green "@"]
    go (DocString s) = do
      DocContext {..} <- ask
      return $
        case flattenBehavior of
          Flatten ->
            case textPosition of
              Body -> strBody s
              ParaStart -> strPara s
          WordBreak ->
            fillSep $
            (if textPosition == ParaStart
               then map2 strPara strBody
               else map strBody) $
            splitWhen isSpace s
    go (DocDefList ds) = do
      docs <-
        forM ds $ \(hdr, body) -> do
          rhdr <- inBody $ go hdr
          rbdy <- inBody $ go body
          return $ enclose (green "[") (green "]") rhdr <+> rbdy
      return $ vcat docs
    go (DocExamples es) =
      return $
      vcat $
      map
        (\Example {..} ->
           vcat $ (green ">>>" <+> string exampleExpression) : map string exampleResult)
        es
    go (DocModule x) = return $ enclose (green "\"") (green "\"") (strBody x)
    go (DocIdentifier (c, x, c2)) =
      return $ enclose (green $ char c) (green $ char c2) (string x)
    go (DocMathDisplay x) = return $ enclose (green "\\[") (green "\\]") (strBody x)
    go (DocMathInline x) = return $ enclose (green "\\(") (green "\\)") (strBody x)
    -- go (DocAName x) = return $ enclose (green "#") (green "#") (strBody x)
    go (DocHyperlink (Hyperlink h l)) =
      return $
      enclose (green "<") (green ">") (string $ h ++ maybe "" (" " ++) (unNl <$> l))
    go (DocPic (Picture p t)) =
      return $
      enclose (green "<<") (green ">>") (string $ p ++ maybe "" (" " ++) (unNl <$> t))
    go x = error $ "Unhandled Haddock AST node: " ++ show x
    unNl =
      map
        (\x ->
           if x == '\n'
             then ' '
             else x)
    goplain (DocString s) = strPara $ escapeHtml s
    goplain (DocAppend a b) = goplain a <> goplain b
    goplain (DocIdentifier (a, b, c)) =
      enclose (green (char a)) (green (char c)) (string b)
    goplain (DocEmphasis x) = enclose (green "/") (green "/") (goplain x)
    goplain (DocModule x) = enclose (green "\"") (green "\"") (string x)
    goplain n = error $ "Unhandled in goplain: " ++ show n

map2 f g (x:xs) = f x : map g xs
map2 _ _ [] = []

arrowblock ('\n':ys) = line <> green "> " <> arrowblock ys
arrowblock (x:xs) = char x <> arrowblock xs
arrowblock "" = empty

escapeHtml "" = ""
escapeHtml ('\n':'\n':xs) = '\n' : '.' : '\n' : escapeHtml xs
escapeHtml ('\n':xs)
  | (spcs, '-':chrs) <- span isSpace xs = '\n' : spcs ++ ('\1' : '-' : escapeHtml chrs)
escapeHtml (c:cs) = c : escapeHtml cs

strPara ('>':'>':'>':cs) = text "\\>>>" <> strBody cs
strPara (x:cs)
    -- >, *, and - are mentioned by the haddock docks, but [ is also
    -- a special character b/c it starts a definition list
  | x `elem` ['>', '*', '-', '['] = char '\\' <> char x <> strBody cs
strPara x = strBody x

strBody ('\n':x) = line <> strPara x
strBody ('{':xs) = "&#x7b;" <> strBody xs
strBody ('}':xs) = "&#x7d;" <> strBody xs
strBody (x:xs)
  | x `elem` ['\\', '/', '\'', '`', '"', '@', '<', '#'] =
    char '\\' <> char x <> strBody xs
  | x == '\1' = char '\\' <> strBody xs
  | otherwise = char x <> strBody xs
strBody "" = empty