{-# 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 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 $ 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