{-# LANGUAGE RecordWildCards #-}

module Haddock.Backends.Hyperlinker.Renderer (render) where

import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils

import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC

import System.FilePath.Posix ((</>))

import Data.List
import Data.Maybe
import qualified Data.Map as Map

import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html

type StyleClass = String

render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
       -> Html
render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens

body :: SrcMap -> [RichToken] -> Html
body srcs tokens = Html.body . Html.pre $ hypsrc
  where
    hypsrc = mconcat . map (richToken srcs) $ tokens

header :: Maybe FilePath -> Maybe FilePath -> Html
header mcss mjs
    | isNothing mcss && isNothing mjs = Html.noHtml
header mcss mjs =
    Html.header $ css mcss <> js mjs
  where
    css Nothing = Html.noHtml
    css (Just cssFile) = Html.thelink Html.noHtml !
        [ Html.rel "stylesheet"
        , Html.thetype "text/css"
        , Html.href cssFile
        ]
    js Nothing = Html.noHtml
    js (Just scriptFile) = Html.script Html.noHtml !
        [ Html.thetype "text/javascript"
        , Html.src scriptFile
        ]

-- | Given information about the source position of definitions, render a token
richToken :: SrcMap -> RichToken -> Html
richToken srcs (RichToken Token{..} details)
    | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue
    | otherwise = linked content
  where
    content = tokenSpan ! [ multiclass style ]
    tokenSpan = Html.thespan (Html.toHtml tkValue)
    style = tokenStyle tkType ++ maybe [] richTokenStyle details

    -- If we have name information, we can make links
    linked = case details of
      Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d
      Nothing -> id

richTokenStyle :: TokenDetails -> [StyleClass]
richTokenStyle (RtkVar _) = ["hs-var"]
richTokenStyle (RtkType _) = ["hs-type"]
richTokenStyle _ = []

tokenStyle :: TokenType -> [StyleClass]
tokenStyle TkIdentifier = ["hs-identifier"]
tokenStyle TkKeyword = ["hs-keyword"]
tokenStyle TkString = ["hs-string"]
tokenStyle TkChar = ["hs-char"]
tokenStyle TkNumber = ["hs-number"]
tokenStyle TkOperator = ["hs-operator"]
tokenStyle TkGlyph = ["hs-glyph"]
tokenStyle TkSpecial = ["hs-special"]
tokenStyle TkSpace = []
tokenStyle TkComment = ["hs-comment"]
tokenStyle TkCpp = ["hs-cpp"]
tokenStyle TkPragma = ["hs-pragma"]
tokenStyle TkUnknown = []

multiclass :: [StyleClass] -> HtmlAttr
multiclass = Html.theclass . intercalate " "

externalAnchor :: TokenDetails -> Html -> Html
externalAnchor (RtkDecl name) content =
    Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
externalAnchor _ content = content

internalAnchor :: TokenDetails -> Html -> Html
internalAnchor (RtkBind name) content =
    Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
internalAnchor _ content = content

externalAnchorIdent :: GHC.Name -> String
externalAnchorIdent = hypSrcNameUrl

internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique

hyperlink :: SrcMap -> TokenDetails -> Html -> Html
hyperlink srcs details = case rtkName details of
    Left name ->
        if GHC.isInternalName name
        then internalHyperlink name
        else externalNameHyperlink srcs name
    Right name -> externalModHyperlink srcs name

internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
    Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]

externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
    Just SrcLocal -> Html.anchor content !
        [ Html.href $ hypSrcModuleNameUrl mdl name ]
    Just (SrcExternal path) -> Html.anchor content !
        [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
    Nothing -> content
  where
    mdl = GHC.nameModule name

externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
externalModHyperlink srcs name content =
    let srcs' = Map.mapKeys GHC.moduleName srcs in
    case Map.lookup name srcs' of
      Just SrcLocal -> Html.anchor content !
        [ Html.href $ hypSrcModuleUrl' name ]
      Just (SrcExternal path) -> Html.anchor content !
        [ Html.href $ path </> hypSrcModuleUrl' name ]
      Nothing -> content

renderSpace :: Int -> String -> Html
renderSpace _ [] = Html.noHtml
renderSpace line ('\n':rest) = mconcat
    [ Html.thespan . Html.toHtml $ "\n"
    , lineAnchor (line + 1)
    , renderSpace (line + 1) rest
    ]
renderSpace line space =
    let (hspace, rest) = span (/= '\n') space
    in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest

lineAnchor :: Int -> Html
lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]


module Haddock.Backends.Hyperlinker.Types where

import qualified GHC

import Data.Map (Map)

data Token = Token
    { tkType :: TokenType
    , tkValue :: String
    , tkSpan :: {-# UNPACK #-} !Span
    }
    deriving (Show)

type Position = GHC.RealSrcLoc
type Span = GHC.RealSrcSpan

data TokenType
    = TkIdentifier
    | TkKeyword
    | TkString
    | TkChar
    | TkNumber
    | TkOperator
    | TkGlyph
    | TkSpecial
    | TkSpace
    | TkComment
    | TkCpp
    | TkPragma
    | TkUnknown
    deriving (Show, Eq)

data RichToken = RichToken
    { rtkToken :: Token
    , rtkDetails :: Maybe TokenDetails
    }

data TokenDetails
    = RtkVar GHC.Name
    | RtkType GHC.Name
    | RtkBind GHC.Name
    | RtkDecl GHC.Name
    | RtkModule GHC.ModuleName
    deriving (Eq)

rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
rtkName (RtkVar name) = Left name
rtkName (RtkType name) = Left name
rtkName (RtkBind name) = Left name
rtkName (RtkDecl name) = Left name
rtkName (RtkModule name) = Right name

-- | Path for making cross-package hyperlinks in generated sources.
--
-- Used in 'SrcMap' to determine whether module originates in current package
-- or in an external package.
data SrcPath
    = SrcExternal FilePath
    | SrcLocal

-- | Mapping from modules to cross-package source paths.
type SrcMap = Map GHC.Module SrcPath


module Haddock.Backends.Hyperlinker.Utils
    ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
    , hypSrcModuleUrl, hypSrcModuleUrl'
    , hypSrcNameUrl
    , hypSrcLineUrl
    , hypSrcModuleNameUrl, hypSrcModuleLineUrl
    , hypSrcModuleUrlFormat
    , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
    ) where

import Haddock.Backends.Xhtml.Utils

import GHC
import FastString
import System.FilePath.Posix ((</>))

hypSrcDir :: FilePath
hypSrcDir = "src"

hypSrcModuleFile :: Module -> FilePath
hypSrcModuleFile = hypSrcModuleFile' . moduleName

hypSrcModuleFile' :: ModuleName -> FilePath
hypSrcModuleFile' mdl = spliceURL'
    Nothing (Just mdl) Nothing Nothing moduleFormat

hypSrcModuleUrl :: Module -> String
hypSrcModuleUrl = hypSrcModuleFile

hypSrcModuleUrl' :: ModuleName -> String
hypSrcModuleUrl' = hypSrcModuleFile'

hypSrcNameUrl :: Name -> String
hypSrcNameUrl name = spliceURL
    Nothing Nothing (Just name) Nothing nameFormat

hypSrcLineUrl :: Int -> String
hypSrcLineUrl line = spliceURL
    Nothing Nothing Nothing (Just spn) lineFormat
  where
    loc = mkSrcLoc nilFS line 1
    spn = mkSrcSpan loc loc

hypSrcModuleNameUrl :: Module -> Name -> String
hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name

hypSrcModuleLineUrl :: Module -> Int -> String
hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line

hypSrcModuleUrlFormat :: String
hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat

hypSrcModuleNameUrlFormat :: String
hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat

hypSrcModuleLineUrlFormat :: String
hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat

moduleFormat :: String
moduleFormat = "%{MODULE}.html"

nameFormat :: String
nameFormat = "%{NAME}"

lineFormat :: String
lineFormat = "line-%{LINE}"


{-# LANGUAGE TransformListComp #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.Decl
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Decl (
  ppDecl,

  ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances,
  tyvarNames
) where

import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
import Haddock.Doc (combineDocumentation)

import           Data.List             ( intersperse, sort )
import qualified Data.Map as Map
import           Data.Maybe
import           Text.XHtml hiding     ( name, title, p, quote )

import GHC hiding (LexicalFixity(..))
import GHC.Exts
import Name
import BooleanFormula
import RdrName ( rdrNameOcc )

ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
       -> [(HsDecl DocNameI, DocForDecl DocName)]
       -> DocForDecl DocName ->  [DocInstance DocNameI] -> [(DocName, Fixity)]
       -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode
       -> Maybe Package -> Qualification -> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
  TyClD (FamDecl d)            -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
  TyClD d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
  TyClD d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
  TyClD d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
  SigD (TypeSig lnames lty)    -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
                                         (hsSigWcType lty) fixities splice unicode pkg qual
  SigD (PatSynSig lnames ty)   -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
                                         ty fixities splice unicode pkg qual
  ForD d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
  InstD _                      -> noHtml
  DerivD _                     -> noHtml
  _                            -> error "declaration not supported by ppDecl"

ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
             [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
             Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
  ppFunSig summary links loc doc (map unLoc lnames) lty fixities
           splice unicode pkg qual

ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
            [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
            Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
  ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
            splice unicode pkg qual HideEmptyContexts
  where
    pp_typ = ppLType unicode qual HideEmptyContexts typ

ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
             [Located DocName] -> LHsSigType DocNameI ->
             [(DocName, Fixity)] ->
             Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice
          unicode pkg qual
  | summary = pref1
  | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)
                +++ docSection Nothing pkg qual doc
  where
    pref1 = hsep [ keyword "pattern"
                 , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
                 , dcolon unicode
                 , ppPatSigType unicode qual (hsSigType typ)
                 ]

ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
             [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
             Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
          splice unicode pkg qual emptyCtxts =
  ppTypeOrFunSig summary links loc docnames typ doc
    ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
    , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
    , dcolon unicode
    )
    splice unicode pkg qual emptyCtxts
  where
    occnames = map (nameOccName . getName) docnames
    addFixities html
      | summary   = html
      | otherwise = html <+> ppFixities fixities qual

ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
               -> DocForDecl DocName -> (Html, Html, Html)
               -> Splice -> Unicode -> Maybe Package -> Qualification
               -> HideEmptyContexts -> Html
ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
               splice unicode pkg qual emptyCtxts
  | summary = pref1
  | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc
  | otherwise = topDeclElem links loc splice docnames pref2 +++
      subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc
  where
    curName = getName <$> listToMaybe docnames
    argDoc n = Map.lookup n argDocs

    do_largs n leader (L _ t) = do_args n leader t

    do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
    do_args n leader (HsForAllTy tvs ltype)
      = do_largs n leader' ltype
      where
        leader' = leader <+> ppForAll tvs unicode qual

    do_args n leader (HsQualTy lctxt ltype)
      | null (unLoc lctxt)
      = do_largs n leader ltype
      | otherwise
      = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
        : do_largs n (darrow unicode) ltype

    do_args n leader (HsFunTy lt r)
      = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
        : do_largs (n+1) (arrow unicode) r
    do_args n leader t
      = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]

ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
    [] -> noHtml
    ts -> forallSymbol unicode <+> hsep ts +++ dot
  where ppKTv n k = parens $
          ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k

ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
ppFixities [] _ = noHtml
ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
  where
    ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<
                         (toHtml d <+> toHtml (show p) <+> ppNames ns)

    ppDir InfixR = "infixr"
    ppDir InfixL = "infixl"
    ppDir InfixN = "infix"

    ppNames = case fs of
      _:[] -> const noHtml -- Don't display names for fixities on single names
      _    -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)

    uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs
                                   , let d' = ppDir d
                                   , then group by Down (p,d') using groupWith ]

    rightEdge = thespan ! [theclass "rightedge"] << noHtml

-- | Pretty-print type variables.
ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs

tyvarNames :: LHsQTyVars DocNameI -> [Name]
tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit

ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
      -> ForeignDecl DocNameI -> [(DocName, Fixity)]
      -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
      splice unicode pkg qual
  = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"

-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
        -> DocForDecl DocName -> TyClDecl DocNameI
        -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                                                , tcdRhs = ltype })
        splice unicode pkg qual
  = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
                   (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
                   splice unicode pkg qual ShowEmptyToplevelContexts
  where
    hdr  = hsep ([keyword "type", ppBinder summary occ]
                 ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
    full = hdr <+> equals <+> ppPatSigType unicode qual ltype
    occ  = nameOccName . getName $ name
    fixs
      | summary   = noHtml
      | otherwise = ppFixities fixities qual
ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"

ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html
ppTypeSig summary nms pp_ty unicode =
  concatHtml htmlNames <+> dcolon unicode <+> pp_ty
  where
    htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms

ppTyName :: Name -> Html
ppTyName = ppName Prefix

ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
            -> [DocName] -> HsType DocNameI
            -> Html
ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
    topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
  where
    topDeclElem' = topDeclElem links loc splice
    ppTyp = ppType unicode qual emptyCtxts typ
    occNames = map getOccName names

--------------------------------------------------------------------------------
-- * Type families
--------------------------------------------------------------------------------

ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html
ppFamilyInfo assoc OpenTypeFamily
    | assoc = keyword "type"
    | otherwise = keyword "type family"
ppFamilyInfo assoc DataFamily
    | assoc = keyword "data"
    | otherwise = keyword "data family"
ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"

ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI
              -> Unicode -> Qualification -> Html
ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
                                               , fdResultSig = L _ result
                                               , fdInjectivityAnn = injectivity })
              unicode qual =
  (case info of
     OpenTypeFamily
       | associated -> keyword "type"
       | otherwise  -> keyword "type family"
     DataFamily
       | associated -> keyword "data"
       | otherwise  -> keyword "data family"
     ClosedTypeFamily _
                    -> keyword "type family"
  ) <+>

  ppFamDeclBinderWithVars summary unicode qual d <+>
  ppResultSig result unicode qual <+>

  (case injectivity of
     Nothing                   -> noHtml
     Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
  ) <+>

  (case info of
     ClosedTypeFamily _ -> keyword "where ..."
     _                  -> mempty
  )

ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
ppResultSig result unicode qual = case result of
    NoSig               -> noHtml
    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr

ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
                     -> Html
ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
    ppFamilyInfo True pfdInfo <+>
    ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>
    ppResultSig (unLoc pfdKindSig) unicode qual

ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html
ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
    char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>
    hsep (map (ppLDocName qual Raw) rhs)

ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->
           [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
           FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package ->
           Qualification -> Html
ppTyFam summary associated links instances fixities loc doc decl splice unicode
        pkg qual

  | summary   = ppTyFamHeader True associated decl unicode qual
  | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit

  where
    docname = unLoc $ fdLName decl

    header_ = topDeclElem links loc splice [docname] $
       ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual

    instancesBit
      | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl
      , not summary
      = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns

      | otherwise
      = ppInstances links (OriginFamily docname) instances splice unicode pkg qual

    -- Individual equation of a closed type family
    ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl
    ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs
                                          , feqn_pats = ts } })
      = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
          <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
        , Nothing, [] )

ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
                   -> PseudoFamilyDecl DocNameI
                   -> Html
ppPseudoFamilyDecl links splice unicode qual
                   decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =
    wrapper $ ppPseudoFamilyHeader unicode qual decl
  where
    wrapper = topDeclElem links loc splice [name]

--------------------------------------------------------------------------------
-- * Associated Types
--------------------------------------------------------------------------------

ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI
            -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package
            -> Qualification -> Html
ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
   ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual

--------------------------------------------------------------------------------
-- * TyClDecl helpers
--------------------------------------------------------------------------------

-- | Print a type family and its variables
ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
  ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)

-- | Print a newtype / data binder and its variables
ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
ppDataBinderWithVars summ unicode qual decl =
  ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)

--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------

ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
ppAppDocNameTyVarBndrs summ unicode qual n vs =
    ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
  where
    ppDN notation = ppBinderFixity notation summ . nameOccName . getName
    ppBinderFixity Infix = ppBinderInfix
    ppBinderFixity _ = ppBinder

-- | Print an application of a 'DocName' to its list of 'HsType's
ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html
ppAppNameTypes n ts unicode qual =
    ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)

-- | General printing of type applications
ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
ppTypeApp n (t1:t2:rest) ppDN ppT
  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
  | operator                    = opApp
  where
    operator = isNameSym . getName $ n
    opApp = ppT t1 <+> ppDN Infix n <+> ppT t2

ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)

-------------------------------------------------------------------------------
-- * Contexts
-------------------------------------------------------------------------------

ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
                              -> Qualification -> HideEmptyContexts -> Html
ppLContext        = ppContext        . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc

ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
                                               ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts

ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $
                                              ppContextNoLocsMaybe cxt unicode qual emptyCtxts

ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html
ppContextNoLocsMaybe [] _ _ emptyCtxts =
  case emptyCtxts of
    HideEmptyContexts -> Nothing
    ShowEmptyToplevelContexts -> Just (toHtml "()")
ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual

ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts

ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html
ppHsContext []  _       _    = noHtml
ppHsContext [p] unicode qual = ppCtxType unicode qual p
ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)

-------------------------------------------------------------------------------
-- * Class declarations
-------------------------------------------------------------------------------

ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
           -> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
  keyword "class"
  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
  <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
  <+> ppFds fds unicode qual

ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html
ppFds fds unicode qual =
  if null fds then noHtml else
        char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
  where
        fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
        ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)

ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan
                 -> [(DocName, DocForDecl DocName)]
                 -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
                                          , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
    subdocs splice unicode pkg qual =
  if not (any isUserLSig sigs) && null ats
    then (if summary then id else topDeclElem links loc splice [nm]) hdr
    else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
      +++ shortSubDecls False
          (
            [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats
              , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]  ++

                -- ToDo: add associated type defaults

            [ ppFunSig summary links loc doc names (hsSigType typ)
                       [] splice unicode pkg qual
              | L _ (ClassOpSig False lnames typ) <- sigs
              , let doc = lookupAnySubdoc (head names) subdocs
                    names = map unLoc lnames ]
              -- FIXME: is taking just the first name ok? Is it possible that
              -- there are different subdocs for different names in a single
              -- type signature?
          )
  where
    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
    nm  = unLoc lname
ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"

ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)]
            -> SrcSpan -> Documentation DocName
            -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI
            -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppClassDecl summary links instances fixities loc d subdocs
        decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
                        , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
            splice unicode pkg qual
  | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual
  | otherwise = classheader +++ docSection Nothing pkg qual d
                  +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
  where
    sigs = map unLoc lsigs

    classheader
      | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
      | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)

    -- Only the fixity relevant to the class header
    fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual

    nm   = tcdName decl

    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds

    -- ToDo: add assocatied typ defaults
    atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual
                      | at <- ats
                      , let n = unL . fdLName $ unL at
                            doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
                            subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]

    methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)
                                      subfixs splice unicode pkg qual
                           | L _ (ClassOpSig _ lnames typ) <- lsigs
                           , name <- map unLoc lnames
                           , let doc = lookupAnySubdoc name subdocs
                                 subfixs = [ f | f@(n',_) <- fixities
                                               , name == n' ]
                           ]
                           -- N.B. taking just the first name is ok. Signatures with multiple names
                           -- are expanded so that each name gets its own signature.

    minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
      -- Miminal complete definition = every shown method
      And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
                   sort [getName n | ClassOpSig _ ns _ <- sigs, L _ n <- ns]
        -> noHtml

      -- Minimal complete definition = the only shown method
      Var (L _ n) : _ | [getName n] ==
                        [getName n' | L _ (ClassOpSig _ ns _) <- lsigs, L _ n' <- ns]
        -> noHtml

      -- Minimal complete definition = nothing
      And [] : _ -> subMinimal $ toHtml "Nothing"

      m : _  -> subMinimal $ ppMinimal False m
      _ -> noHtml

    ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs
    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs
      where wrap | p = parens | otherwise = id
    ppMinimal p (Parens x) = ppMinimal p (unLoc x)

    instancesBit = ppInstances links (OriginClass nm) instances
        splice unicode pkg qual

ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"

ppInstances :: LinksInfo
            -> InstOrigin DocName -> [DocInstance DocNameI]
            -> Splice -> Unicode -> Maybe Package -> Qualification
            -> Html
ppInstances links origin instances splice unicode pkg qual
  = subInstances pkg qual instName links True (zipWith instDecl [1..] instances)
  -- force Splice = True to use line URLs
  where
    instName = getOccString origin
    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)
    instDecl no (inst, mdoc, loc, mdl) =
        ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc)

ppOrphanInstances :: LinksInfo
                  -> [DocInstance DocNameI]
                  -> Splice -> Unicode -> Maybe Package -> Qualification
                  -> Html
ppOrphanInstances links instances splice unicode pkg qual
  = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances)
  where
    instOrigin :: InstHead name -> InstOrigin (IdP name)
    instOrigin inst = OriginClass (ihdClsName inst)

    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)
    instDecl no (inst, mdoc, loc, mdl) =
        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)

ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
           -> Maybe (MDoc DocName)
           -> InstOrigin DocName
           -> Bool -- ^ Is instance orphan
           -> Int  -- ^ Normal
           -> InstHead DocNameI
           -> Maybe Module
           -> SubDecl
ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl =
    case ihdInstType of
        ClassInst { .. } ->
            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ
            , mdoc
            , [subInstDetails iid ats sigs mname]
            )
          where
            sigs = ppInstanceSigs links splice unicode qual clsiSigs
            ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
        TypeInst rhs ->
            ( subInstHead iid ptype
            , mdoc
            , [subFamInstDetails iid prhs mname]
            )
          where
            ptype = keyword "type" <+> typ
            prhs = ptype <+> maybe noHtml
                                   (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs
        DataInst dd ->
            ( subInstHead iid pdata
            , mdoc
            , [subFamInstDetails iid pdecl mname])
          where
            pdata = keyword "data" <+> typ
            pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
  where
    mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl
    iid = instanceId origin no orphan ihd
    typ = ppAppNameTypes ihdClsName ihdTypes unicode qual

ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
                   -> [PseudoFamilyDecl DocNameI]
                   -> [Html]
ppInstanceAssocTys links splice unicode qual =
    map ppFamilyDecl'
  where
    ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual

ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
              -> [Sig DocNameI]
              -> [Html]
ppInstanceSigs links splice unicode qual sigs = do
    TypeSig lnames typ <- sigs
    let names = map unLoc lnames
        L _ rtyp = hsSigWcType typ
    -- Instance methods signatures are synified and thus don't have a useful
    -- SrcSpan value. Use the methods name location instead.
    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp

lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n

instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String
instanceId origin no orphan ihd = concat $
    [ "o:" | orphan ] ++
    [ qual origin
    , ":" ++ getOccString origin
    , ":" ++ (occNameString . getOccName . ihdClsName) ihd
    , ":" ++ show no
    ]
  where
    qual (OriginClass _) = "ic"
    qual (OriginData _) = "id"
    qual (OriginFamily _) = "if"

-------------------------------------------------------------------------------
-- * Data & newtype declarations
-------------------------------------------------------------------------------

-- TODO: print contexts
ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI
                -> [(HsDecl DocNameI, DocForDecl DocName)]
                -> Unicode -> Qualification -> Html
ppShortDataDecl summary dataInst dataDecl pats unicode qual

  | [] <- cons
  , [] <- pats = dataHeader

  | [lcon] <- cons, [] <- pats, isH98,
    (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
       = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot

  | [] <- pats, isH98 = dataHeader
      +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)

  | otherwise = (dataHeader <+> keyword "where")
      +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)

  where
    dataHeader
      | dataInst  = noHtml
      | otherwise = ppDataHeader summary dataDecl unicode qual
    doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
    doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual

    cons      = dd_cons (tcdDataDefn dataDecl)
    isH98     = case unLoc (head cons) of
                  ConDeclH98 {} -> True
                  ConDeclGADT{} -> False

    pats1 = [ hsep [ keyword "pattern"
                   , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
                   , dcolon unicode
                   , ppPatSigType unicode qual (hsSigType typ)
                   ]
            | (SigD (PatSynSig lnames typ),_) <- pats
            ]

ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->
              [(DocName, DocForDecl DocName)] ->
              SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
              [(HsDecl DocNameI, DocForDecl DocName)] ->
              Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
           splice unicode pkg qual

  | summary   = ppShortDataDecl summary False dataDecl pats unicode qual
  | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit

  where
    docname   = tcdName dataDecl
    cons      = dd_cons (tcdDataDefn dataDecl)
    isH98     = case unLoc (head cons) of
                  ConDeclH98 {} -> True
                  ConDeclGADT{} -> False

    header_ = topDeclElem links loc splice [docname] $
             ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix

    fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual

    whereBit
      | null cons
      , null pats = noHtml
      | null cons = keyword "where"
      | otherwise = if isH98 then noHtml else keyword "where"

    constrBit = subConstructors pkg qual
      [ ppSideBySideConstr subdocs subfixs unicode pkg qual c
      | c <- cons
      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
                                     (map unLoc (getConNames (unLoc c)))) fixities
      ]

    patternBit = subPatterns pkg qual
      [ (hsep [ keyword "pattern"
              , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
              , dcolon unicode
              , ppPatSigType unicode qual (hsSigType typ)
              ] <+> ppFixities subfixs qual
        ,combineDocumentation (fst d), [])
      | (SigD (PatSynSig lnames typ),d) <- pats
      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
      ]

    instancesBit = ppInstances links (OriginData docname) instances
        splice unicode pkg qual

ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html
ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
  where
    (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual

-- returns three pieces: header, body, footer so that header & footer can be
-- incorporated into the declaration
ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html)
ppShortConstrParts summary dataInst con unicode qual = case con of
  ConDeclH98{} -> case con_details con of
    PrefixCon args ->
      (header_ unicode qual +++ hsep (ppOcc
            : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)
    RecCon (L _ fields) ->
      (header_ unicode qual +++ ppOcc <+> char '{',
       doRecordFields fields,
       char '}')
    InfixCon arg1 arg2 ->
      (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,
            ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
       noHtml, noHtml)

  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)

  where
    resTy = hsib_body (con_type con)

    doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))

    header_  = ppConstrHdr forall_ tyVars context
    occ        = map (nameOccName . getName . unLoc) $ getConNames con

    ppOcc      = case occ of
      [one] -> ppBinder summary one
      _     -> hsep (punctuate comma (map (ppBinder summary) occ))

    ppOccInfix = case occ of
      [one] -> ppBinderInfix summary one
      _     -> hsep (punctuate comma (map (ppBinderInfix summary) occ))

    ltvs     = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)
    tyVars   = tyvarNames ltvs
    lcontext = fromMaybe (noLoc []) (con_cxt con)
    context  = unLoc lcontext
    forall_  = False

-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode
            -> Qualification -> Html
ppConstrHdr forall_ tvs ctxt unicode qual
 = (if null tvs then noHtml else ppForall)
   +++
   (if null ctxt then noHtml
    else ppContextNoArrow ctxt unicode qual HideEmptyContexts
         <+> darrow unicode +++ toHtml " ")
  where
    ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
                           <+> toHtml ". "
             | otherwise = noHtml

ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
                   -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl
ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
 = (decl, mbDoc, fieldPart)
 where
    decl = case con of
      ConDeclH98{} -> case con_details con of
        PrefixCon args ->
          hsep ((header_ +++ ppOcc)
            : map (ppLParendType unicode qual HideEmptyContexts) args)
          <+> fixity

        RecCon _ -> header_ +++ ppOcc <+> fixity

        InfixCon arg1 arg2 ->
          hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,
            ppOccInfix,
            ppLParendType unicode qual HideEmptyContexts arg2]
          <+> fixity

      ConDeclGADT{} -> doGADTCon resTy

    resTy = hsib_body (con_type con)

    fieldPart = case getConDetails con of
        RecCon (L _ fields) -> [doRecordFields fields]
        _ -> []

    doRecordFields fields = subFields pkg qual
      (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))

    doGADTCon :: Located (HsType DocNameI) -> Html
    doGADTCon ty = ppOcc <+> dcolon unicode
        -- ++AZ++ make this prepend "{..}" when it is a record style GADT
        <+> ppLType unicode qual HideEmptyContexts ty
        <+> fixity

    fixity  = ppFixities fixities qual
    header_ = ppConstrHdr forall_ tyVars context unicode qual
    occ       = map (nameOccName . getName . unLoc) $ getConNames con

    ppOcc     = case occ of
      [one] -> ppBinder False one
      _     -> hsep (punctuate comma (map (ppBinder False) occ))

    ppOccInfix = case occ of
      [one] -> ppBinderInfix False one
      _     -> hsep (punctuate comma (map (ppBinderInfix False) occ))

    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))
    context = unLoc (fromMaybe (noLoc []) (con_cxt con))
    forall_ = False
    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
    -- or also because we want Haddock to do the doc-parsing, not GHC.
    mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>=
            combineDocumentation . fst

ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
                  -> ConDeclField DocNameI -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
  ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
      <+> dcolon unicode
      <+> ppLType unicode qual HideEmptyContexts ltype
  , mbDoc
  , []
  )
  where
    -- don't use cd_fld_doc for same reason we don't use con_doc above
    -- Where there is more than one name, they all have the same documentation
    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst

ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField names ltype _)
  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
    <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype

-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html
ppDataHeader summary decl@(DataDecl { tcdDataDefn =
                                         HsDataDefn { dd_ND = nd
                                                    , dd_ctxt = ctxt
                                                    , dd_kindSig = ks } })
             unicode qual
  = -- newtype or data
    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
    <+>
    -- context
    ppLContext ctxt unicode qual HideEmptyContexts <+>
    -- T a b c ..., or a :+: b
    ppDataBinderWithVars summary unicode qual decl
    <+> case ks of
      Nothing -> mempty
      Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x

ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"

--------------------------------------------------------------------------------
-- * Types and contexts
--------------------------------------------------------------------------------

ppBang :: HsSrcBang -> Html
ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"
ppBang (HsSrcBang _ _ SrcLazy)   = toHtml "~"
ppBang _                         = noHtml

tupleParens :: HsTupleSort -> [Html] -> Html
tupleParens HsUnboxedTuple = ubxParenList
tupleParens _              = parenList

sumParens :: [Html] -> Html
sumParens = ubxSumList

--------------------------------------------------------------------------------
-- * Rendering of HsType
--------------------------------------------------------------------------------

pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int

pREC_TOP = 0 :: Int   -- type in ParseIface.y in GHC
pREC_CTX = 1 :: Int   -- Used for single contexts, eg. ctx => type
                      -- (as opposed to (ctx1, ctx2) => type)
pREC_FUN = 2 :: Int   -- btype in ParseIface.y in GHC
                      -- Used for LH arg of (->)
pREC_OP  = 3 :: Int   -- Used for arg of any infix operator
                      -- (we don't keep their fixities around)
pREC_CON = 4 :: Int   -- Used for arg of type applicn:
                      -- always parenthesise unless atomic

maybeParen :: Int           -- Precedence of context
           -> Int           -- Precedence of top-level operator
           -> Html -> Html  -- Wrap in parens if (ctxt >= op)
maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
                               | otherwise            = p

ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)

ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts

ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html
ppType       unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts
ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts
ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts

ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
ppHsTyVarBndr _       qual (UserTyVar (L _ name)) =
    ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar name kind) =
    parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
            ppLKind unicode qual kind)

ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)

ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts

ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
  let emptyCtxts =
        if hasNonEmptyContext typ && isFirstContextEmpty typ
          then ShowEmptyToplevelContexts
          else HideEmptyContexts
  in ppLType unicode qual emptyCtxts typ
  where
    hasNonEmptyContext :: LHsType name -> Bool
    hasNonEmptyContext t =
      case unLoc t of
        HsForAllTy _ s -> hasNonEmptyContext s
        HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
        HsFunTy _ s -> hasNonEmptyContext s
        _ -> False
    isFirstContextEmpty :: LHsType name -> Bool
    isFirstContextEmpty t =
      case unLoc t of
        HsForAllTy _ s -> isFirstContextEmpty s
        HsQualTy cxt _ -> null (unLoc cxt)
        HsFunTy _ s -> isFirstContextEmpty s
        _ -> False

ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot

ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)

ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
  = maybeParen ctxt_prec pREC_FUN $
    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts

ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
  = maybeParen ctxt_prec pREC_FUN $
    ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts

-- UnicodeSyntax alternatives
ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _
  | getOccString (getName name) == "*"    = toHtml "â˜…"
  | getOccString (getName name) == "(->)" = toHtml "(â†’)"

ppr_mono_ty _         (HsBangTy b ty)     u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
ppr_mono_ty _         (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
ppr_mono_ty _         (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
ppr_mono_ty _         (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
ppr_mono_ty _         (HsKindSig ty kind) u q e =
    parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
ppr_mono_ty _         (HsListTy ty)       u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
ppr_mono_ty _         (HsPArrTy ty)       u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
    maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
ppr_mono_ty _         (HsSpliceTy {})     _ _ _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _         (HsRecTy {})        _ _ _ = toHtml "{..}"
       -- Can now legally occur in ConDeclGADT, the output here is to provide a
       -- placeholder in the signature, which is followed by the field
       -- declarations.
ppr_mono_ty _         (HsCoreTy {})       _ _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty _         (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _         (HsAppsTy {})       _ _ _ = error "ppr_mono_ty HsAppsTy"

ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
  = maybeParen ctxt_prec pREC_CTX $
    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts

ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _
  = maybeParen ctxt_prec pREC_CON $
    hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]

ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
  = maybeParen ctxt_prec pREC_FUN $
    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
  where
    -- `(:)` is valid in type signature only as constructor to promoted list
    -- and needs to be quoted in code so we explicitly quote it here too.
    ppr_op
        | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'
        | otherwise = ppr_op'
    ppr_op' = ppLDocName qual Infix op

ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
--  = parens (ppr_mono_lty pREC_TOP ty)
  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts

ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts

ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n

ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)

ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts
  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts
        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts
    in
    maybeParen ctxt_prec pREC_FUN $
    hsep [p1, arrow unicode <+> p2]


-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.DocMarkup
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.DocMarkup (
  docToHtml,
  rdrDocToHtml,
  origDocToHtml,
  docToHtmlNoAnchors,

  docElement, docSection, docSection_,
) where

import Data.List
import Documentation.Haddock.Markup
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils
import Haddock.Doc (combineDocumentation, emptyMetaDoc,
                    metaDocAppend, metaConcat)

import Text.XHtml hiding ( name, p, quote )
import Data.Maybe (fromMaybe)

import GHC
import Name

parHtmlMarkup :: Qualification -> Bool
              -> (Bool -> a -> Html) -> DocMarkup a Html
parHtmlMarkup qual insertAnchors ppId = Markup {
  markupEmpty                = noHtml,
  markupString               = toHtml,
  markupParagraph            = paragraph,
  markupAppend               = (+++),
  markupIdentifier           = thecode . ppId insertAnchors,
  markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,
  markupModule               = \m -> let (mdl,ref) = break (=='#') m
                                         -- Accomodate for old style
                                         -- foo\#bar anchors
                                         mdl' = case reverse mdl of
                                           '\\':_ -> init mdl
                                           _ -> mdl
                                     in ppModuleRef (mkModuleName mdl') ref,
  markupWarning              = thediv ! [theclass "warning"],
  markupEmphasis             = emphasize,
  markupBold                 = strong,
  markupMonospaced           = thecode,
  markupUnorderedList        = unordList,
  markupOrderedList          = ordList,
  markupDefList              = defList,
  markupCodeBlock            = pre,
  markupHyperlink            = \(Hyperlink url mLabel)
                               -> if insertAnchors
                                  then anchor ! [href url]
                                       << fromMaybe url mLabel
                                  else toHtml $ fromMaybe url mLabel,
  markupAName                = \aname
                               -> if insertAnchors
                                  then namedAnchor aname << ""
                                  else noHtml,
  markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
  markupMathInline           = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"),
  markupMathDisplay          = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"),
  markupProperty             = pre . toHtml,
  markupExample              = examplesToHtml,
  markupHeader               = \(Header l t) -> makeHeader l t,
  markupTable                = \(Table h r) -> makeTable h r
  }
  where
    makeHeader :: Int -> Html -> Html
    makeHeader 1 mkup = h1 mkup
    makeHeader 2 mkup = h2 mkup
    makeHeader 3 mkup = h3 mkup
    makeHeader 4 mkup = h4 mkup
    makeHeader 5 mkup = h5 mkup
    makeHeader 6 mkup = h6 mkup
    makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"

    makeTable :: [TableRow Html] -> [TableRow Html] -> Html
    makeTable hs bs = table (concatHtml (hs' ++ bs'))
      where
        hs' | null hs   = []
            | otherwise = [thead (concatHtml (map (makeTableRow th) hs))]

        bs' = [tbody (concatHtml (map (makeTableRow td) bs))]

    makeTableRow :: (Html -> Html) -> TableRow Html -> Html
    makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs))

    makeTableCell :: (Html -> Html) -> TableCell Html -> Html
    makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j')
      where
        i' = if i == 1 then [] else [ colspan i ]
        j' = if j == 1 then [] else [ rowspan j ]

    examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]

    exampleToHtml (Example expression result) = htmlExample
      where
        htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
        htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
        htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]

-- | We use this intermediate type to transform the input 'Doc' tree
-- in an arbitrary way before rendering, such as grouping some
-- elements. This is effectivelly a hack to prevent the 'Doc' type
-- from changing if it is possible to recover the layout information
-- we won't need after the fact.
data Hack a id =
  UntouchedDoc (MetaDoc a id)
  | CollapsingHeader (Header (DocH a id)) (MetaDoc a id) Int (Maybe String)
  | HackAppend (Hack a id) (Hack a id)
  deriving Eq

-- | Group things under bold 'DocHeader's together.
toHack :: Int -- ^ Counter for header IDs which serves to assign
              -- unique identifiers within the comment scope
       -> Maybe String
       -- ^ It is not enough to have unique identifier within the
       -- scope of the comment: if two different comments have the
       -- same ID for headers, the collapse/expand behaviour will act
       -- on them both. This serves to make each header a little bit
       -- more unique. As we can't export things with the same names,
       -- this should work more or less fine: it is in fact the
       -- implicit assumption the collapse/expand mechanism makes for
       -- things like â€˜Instancesâ€™ boxes.
       -> [MetaDoc a id] -> Hack a id
toHack _ _ [] = UntouchedDoc emptyMetaDoc
toHack _ _ [x] = UntouchedDoc x
toHack n nm (MetaDoc { _doc = DocHeader (Header l (DocBold x)) }:xs) =
  let -- Header with dropped bold
      h = Header l x
      -- Predicate for takeWhile, grab everything including â€˜smallerâ€™
      -- headers
      p (MetaDoc { _doc = DocHeader (Header l' _) }) = l' > l
      p _ = True
      -- Stuff â€˜underâ€™ this header
      r = takeWhile p xs
      -- Everything else that didn't make it under
      r' = drop (length r) xs
      app y [] = y
      app y ys = HackAppend y (toHack (n + 1) nm ys)
  in case r of
      -- No content under this header
      [] -> CollapsingHeader h emptyMetaDoc n nm `app` r'
      -- We got something out, stitch it back together into one chunk
      y:ys -> CollapsingHeader h (foldl metaDocAppend y ys) n nm `app` r'
toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs)

-- | Remove â€˜top-levelâ€™ 'DocAppend's turning them into a flat list.
-- This lends itself much better to processing things in order user
-- might look at them, such as in 'toHack'.
flatten :: MetaDoc a id -> [MetaDoc a id]
flatten MetaDoc { _meta = m, _doc = DocAppend x y } =
  let f z = MetaDoc { _meta = m, _doc = z }
  in flatten (f x) ++ flatten (f y)
flatten x = [x]

-- | Generate the markup needed for collapse to happen. For
-- 'UntouchedDoc' and 'HackAppend' we do nothing more but
-- extract/append the underlying 'Doc' and convert it to 'Html'. For
-- 'CollapsingHeader', we attach extra info to the generated 'Html'
-- that allows us to expand/collapse the content.
hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html
hackMarkup fmt' currPkg h' =
  let (html, ms) = hackMarkup' fmt' h'
  in html +++ renderMeta fmt' currPkg (metaConcat ms)
  where
    hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id
                -> (Html, [Meta])
    hackMarkup' fmt h = case h of
      UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
      CollapsingHeader (Header lvl titl) par n nm ->
        let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
            col' = collapseControl id_ "caption"
            summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand"
            instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents)
            lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
            getHeader = fromMaybe caption (lookup lvl lvs)
            subCaption = getHeader ! col' << markup fmt titl
        in ((subCaption +++) . instTable $ markup fmt (_doc par), [_meta par])
      HackAppend d d' -> let (x, m) = hackMarkup' fmt d
                             (y, m') = hackMarkup' fmt d'
                         in (markupAppend fmt x y, m ++ m')

renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html
renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) =
  markupParagraph fmt . markupEmphasis fmt . toHtml $
    "Since: " ++ formatPkgMaybe pkg ++ formatVersion x
  where
    formatVersion v = concat . intersperse "." $ map show v
    formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"
    formatPkgMaybe _ = ""
renderMeta _ _ _ = noHtml

-- | Goes through 'hackMarkup' to generate the 'Html' rather than
-- skipping straight to 'markup': this allows us to employ XHtml
-- specific hacks to the tree first.
markupHacked :: DocMarkup id Html
             -> Maybe Package      -- this package
             -> Maybe String
             -> MDoc id
             -> Html
markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten

-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers).  FIXME: Does this still apply?
docToHtml :: Maybe String  -- ^ Name of the thing this doc is for. See
                           -- comments on 'toHack' for details.
          -> Maybe Package -- ^ Current package
          -> Qualification -> MDoc DocName -> Html
docToHtml n pkg qual = markupHacked fmt pkg n . cleanup
  where fmt = parHtmlMarkup qual True (ppDocName qual Raw)

-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
-- in links. This is used to generate the Contents box elements.
docToHtmlNoAnchors :: Maybe String  -- ^ See 'toHack'
                   -> Maybe Package -- ^ Current package
                   -> Qualification -> MDoc DocName -> Html
docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup
  where fmt = parHtmlMarkup qual False (ppDocName qual Raw)

origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html
origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
  where fmt = parHtmlMarkup qual True (const $ ppName Raw)

rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html
rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup
  where fmt = parHtmlMarkup qual True (const ppRdrName)

docElement :: (Html -> Html) -> Html -> Html
docElement el content_ =
  if isNoHtml content_
    then el ! [theclass "doc empty"] << spaceHtml
    else el ! [theclass "doc"] << content_

docSection :: Maybe Name -- ^ Name of the thing this doc is for
           -> Maybe Package -- ^ Current package
           -> Qualification -> Documentation DocName -> Html
docSection n pkg qual =
  maybe noHtml (docSection_ n pkg qual) . combineDocumentation

docSection_ :: Maybe Name    -- ^ Name of the thing this doc is for
            -> Maybe Package -- ^ Current package
            -> Qualification -> MDoc DocName -> Html
docSection_ n pkg qual =
  (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual

cleanup :: MDoc a -> MDoc a
cleanup = overDoc (markup fmtUnParagraphLists)
  where
    -- If there is a single paragraph, then surrounding it with <P>..</P>
    -- can add too much whitespace in some browsers (eg. IE).  However if
    -- we have multiple paragraphs, then we want the extra whitespace to
    -- separate them.  So we catch the single paragraph case and transform it
    -- here. We don't do this in code blocks as it eliminates line breaks.
    unParagraph :: Doc a -> Doc a
    unParagraph (DocParagraph d) = d
    unParagraph doc              = doc

    fmtUnParagraphLists :: DocMarkup a (Doc a)
    fmtUnParagraphLists = idMarkup {
      markupUnorderedList = DocUnorderedList . map unParagraph,
      markupOrderedList   = DocOrderedList   . map unParagraph
      }


-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.Layout
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Layout (
  miniBody,

  divPackageHeader, divContent, divModuleHeader, divFooter,
  divTableOfContents, divDescription, divSynopsis, divInterface,
  divIndex, divAlphabet, divModuleList,

  sectionName,
  nonEmptySectionName,

  shortDeclList,
  shortSubDecls,

  divTopDecl,

  SubDecl,
  subArguments,
  subAssociatedTypes,
  subConstructors,
  subPatterns,
  subEquations,
  subFields,
  subInstances, subOrphanInstances,
  subInstHead, subInstDetails, subFamInstDetails,
  subMethods,
  subMinimal,

  topDeclElem, declElem,
) where

import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils (makeAnchorId, nameAnchorId)
import qualified Data.Map as Map
import Text.XHtml hiding ( name, title, quote )
import Data.Maybe (fromMaybe)

import FastString            ( unpackFS )
import GHC
import Name (nameOccName)

--------------------------------------------------------------------------------
-- * Sections of the document
--------------------------------------------------------------------------------

miniBody :: Html -> Html
miniBody = body ! [identifier "mini"]

sectionDiv :: String -> Html -> Html
sectionDiv i = thediv ! [identifier i]

sectionName :: Html -> Html
sectionName = paragraph ! [theclass "caption"]

-- | Make an element that always has at least something (a non-breaking space).
-- If it would have otherwise been empty, then give it the class ".empty".
nonEmptySectionName :: Html -> Html
nonEmptySectionName c
  | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
  | otherwise  = paragraph ! [theclass "caption"]       $ c

divPackageHeader, divContent, divModuleHeader, divFooter,
  divTableOfContents, divDescription, divSynopsis, divInterface,
  divIndex, divAlphabet, divModuleList
    :: Html -> Html

divPackageHeader    = sectionDiv "package-header"
divContent          = sectionDiv "content"
divModuleHeader     = sectionDiv "module-header"
divFooter           = sectionDiv "footer"
divTableOfContents  = sectionDiv "table-of-contents"
divDescription      = sectionDiv "description"
divSynopsis         = sectionDiv "synopsis"
divInterface        = sectionDiv "interface"
divIndex            = sectionDiv "index"
divAlphabet         = sectionDiv "alphabet"
divModuleList       = sectionDiv "module-list"

--------------------------------------------------------------------------------
-- * Declaration containers
--------------------------------------------------------------------------------

shortDeclList :: [Html] -> Html
shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items

shortSubDecls :: Bool -> [Html] -> Html
shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items
  where i | inst      = li ! [theclass "inst"]
          | otherwise = li
        c | inst      = "inst"
          | otherwise = "subs"

divTopDecl :: Html -> Html
divTopDecl = thediv ! [theclass "top"]

type SubDecl = (Html, Maybe (MDoc DocName), [Html])

divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html
divSubDecls cssClass captionName = maybe noHtml wrap
  where
    wrap = (subSection <<) . (subCaption +++)
    subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
    subCaption = paragraph ! [theclass "caption"] << captionName

subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
subDlist _ _ [] = Nothing
subDlist pkg qual decls = Just $ ulist << map subEntry decls
  where
    subEntry (decl, mdoc, subs) =
      li <<
        (define ! [theclass "src"] << decl +++
         docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs))

subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html
subTable _ _ [] = Nothing
subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls)
  where
    subRow (decl, mdoc, subs) =
      (td ! [theclass "src"] << decl
       <->
       docElement td << fmap (docToHtml Nothing pkg qual) mdoc)
      : map (cell . (td <<)) subs

-- | Sub table with source information (optional).
subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool
            -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html
subTableSrc _ _ _ _ [] = Nothing
subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
  where
    subRow ((decl, mdoc, subs), mdl, L loc dn) =
      (td ! [theclass "src clearfix"] <<
        (thespan ! [theclass "inst-left"] << decl)
        <+> linkHtml loc mdl dn
      <->
      docElement td << fmap (docToHtml Nothing pkg qual) mdoc
      )
      : map (cell . (td <<)) subs

    linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html
    linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn
    linkHtml _ _ _ = noHtml

subBlock :: [Html] -> Maybe Html
subBlock [] = Nothing
subBlock hs = Just $ toHtml hs

subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html
subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual

subAssociatedTypes :: [Html] -> Html
subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock

subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html
subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual

subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html
subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual

subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html
subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual

subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html
subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual

-- | Generate sub table for instance declarations, with source
subInstances :: Maybe Package -> Qualification
             -> String -- ^ Class name, used for anchor generation
             -> LinksInfo -> Bool
             -> [(SubDecl, Maybe Module, Located DocName)] -> Html
subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
  where
    wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))
    instTable = subTableSrc pkg qual lnks splice
    subSection = thediv ! [theclass "subs instances"]
    summary = thesummary << "Instances"
    id_ = makeAnchorId $ "i:" ++ nm

subOrphanInstances :: Maybe Package -> Qualification
                   -> LinksInfo -> Bool
                   -> [(SubDecl, Maybe Module, Located DocName)] -> Html
subOrphanInstances pkg qual lnks splice  = maybe noHtml wrap . instTable
  where
    wrap = ((h1 << "Orphan instances") +++)
    instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice
    id_ = makeAnchorId $ "orphans"

subInstHead :: String -- ^ Instance unique id (for anchor generation)
            -> Html -- ^ Header content (instance name and type)
            -> Html
subInstHead iid hdr =
    expander noHtml <+> hdr
  where
    expander = thespan ! collapseControl (instAnchorId iid) "instance"

subInstDetails :: String -- ^ Instance unique id (for anchor generation)
               -> [Html] -- ^ Associated type contents
               -> [Html] -- ^ Method contents (pretty-printed signatures)
               -> Html   -- ^ Source module
               -> Html
subInstDetails iid ats mets mdl =
    subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets)

subFamInstDetails :: String -- ^ Instance unique id (for anchor generation)
                  -> Html   -- ^ Type or data family instance
                  -> Html   -- ^ Source module TODO: use this
                  -> Html
subFamInstDetails iid fi mdl =
    subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi))

subInstSection :: String -- ^ Instance unique id (for anchor generation)
               -> Html
               -> Html
subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents)
  where
    summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details"

instAnchorId :: String -> String
instAnchorId iid = makeAnchorId $ "i:" ++ iid

subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock

subMinimal :: Html -> Html
subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem

-- a box for displaying code
declElem :: Html -> Html
declElem = paragraph ! [theclass "src"]

-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
topDeclElem lnks loc splice names html =
    declElem << (html <+> (links lnks loc splice Nothing $ head names))
        -- FIXME: is it ok to simply take the first name?

-- | Adds a source and wiki link at the right hand side of the box.
-- Name must be documented, otherwise we wouldn't get here.
links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html
links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) =
  srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")
  where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName)))

        srcLink = let nameUrl = Map.lookup origPkg sourceMap
                      lineUrl = Map.lookup origPkg lineMap
                      mUrl | splice    = lineUrl
                                        -- Use the lineUrl as a backup
                           | otherwise = maybe lineUrl Just nameUrl in
          case mUrl of
            Nothing  -> noHtml
            Just url -> let url' = spliceURL (Just fname) (Just origMod)
                                               (Just n) (Just loc) url
                          in anchor ! [href url', theclass "link"] << "Source"

        wikiLink =
          case maybe_wiki_url of
            Nothing  -> noHtml
            Just url -> let url' = spliceURL (Just fname) (Just mdl)
                                               (Just n) (Just loc) url
                          in anchor ! [href url', theclass "link"] << "Comments"

        -- For source links, we want to point to the original module,
        -- because only that will have the source.
        --
        -- 'mdl'' is a way of "overriding" the module. Without it, instances
        -- will point to the module defining the class/family, which is wrong.
        origMod = fromMaybe (nameModule n) mdl'
        origPkg = moduleUnitId origMod

        fname = case loc of
          RealSrcSpan l -> unpackFS (srcSpanFile l)
          UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
links _ _ _ _ _ = noHtml


module Haddock.Backends.Xhtml.Meta where

import Haddock.Utils.Json
import Haddock.Version

import Data.ByteString.Builder (hPutBuilder)
import System.FilePath ((</>))
import System.IO (withFile, IOMode (WriteMode))

-- | Everytime breaking changes to the Quckjump api
-- happen this needs to be modified.
quickjumpVersion :: Int
quickjumpVersion = 1

-- | Writes a json encoded file containing additional
-- information about the generated documentation. This
-- is useful for external tools (e.g. hackage).
writeHaddockMeta :: FilePath -> Bool -> IO ()
writeHaddockMeta odir withQuickjump = do
  let
    meta_json :: Value
    meta_json = object (concat [
        [ "haddock_version"   .= String projectVersion ]
      , [ "quickjump_version" .= quickjumpVersion | withQuickjump ]
      ])

  withFile (odir </> "meta.json") WriteMode $ \h ->
    hPutBuilder h (encodeToBuilder meta_json)


-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.Names
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Names (
  ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
  ppBinder, ppBinderInfix, ppBinder',
  ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
) where

import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
import Haddock.Utils

import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
import qualified Data.List as List

import GHC hiding (LexicalFixity(..))
import Name
import RdrName
import FastString (unpackFS)

-- | Indicator of how to render a 'DocName' into 'Html'
data Notation = Raw -- ^ Render as-is.
              | Infix -- ^ Render using infix notation.
              | Prefix -- ^ Render using prefix notation.
                deriving (Eq, Show)

ppOccName :: OccName -> Html
ppOccName = toHtml . occNameString

ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc

ppIPName :: HsIPName -> Html
ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS

ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName

-- The Bool indicates if it is to be rendered in infix notation
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
ppLDocName qual notation (L _ d) = ppDocName qual notation True d

ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
ppDocName qual notation insertAnchors docName =
  case docName of
    Documented name mdl ->
      linkIdOcc mdl (Just (nameOccName name)) insertAnchors
      << ppQualifyName qual notation name mdl
    Undocumented name
      | isExternalName name || isWiredInName name ->
          ppQualifyName qual notation name (nameModule name)
      | otherwise -> ppName notation name

-- | Render a name depending on the selected qualification mode
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName qual notation name mdl =
  case qual of
    NoQual   -> ppName notation name
    FullQual -> ppFullQualName notation mdl name
    LocalQual localmdl ->
      if moduleString mdl == moduleString localmdl
        then ppName notation name
        else ppFullQualName notation mdl name
    RelativeQual localmdl ->
      case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
        -- local, A.x -> x
        Just []      -> ppName notation name
        -- sub-module, A.B.x -> B.x
        Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
        -- some module with same prefix, ABC.x -> ABC.x
        Just _       -> ppFullQualName notation mdl name
        -- some other module, D.x -> D.x
        Nothing      -> ppFullQualName notation mdl name
    AliasedQual aliases localmdl ->
      case (moduleString mdl == moduleString localmdl,
            M.lookup mdl aliases) of
        (False, Just alias) -> ppQualName notation alias name
        _ -> ppName notation name

ppFullQualName :: Notation -> Module -> Name -> Html
ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname
  where
    qname = toHtml $ moduleString mdl ++ '.' : getOccString name

ppQualName :: Notation -> ModuleName -> Name -> Html
ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname
  where
    qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name

ppName :: Notation -> Name -> Html
ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)

ppBinder :: Bool -> OccName -> Html
ppBinder = ppBinderWith Prefix

ppBinderInfix :: Bool -> OccName -> Html
ppBinderInfix = ppBinderWith Infix

ppBinderWith :: Notation -> Bool -> OccName -> Html
-- 'isRef' indicates whether this is merely a reference from another part of
-- the documentation or is the actual definition; in the latter case, we also
-- set the 'id' and 'class' attributes.
ppBinderWith notation isRef n =
  makeAnchor << ppBinder' notation n
  where
    name = nameAnchorId n
    makeAnchor | isRef     = linkedAnchor name
               | otherwise = namedAnchor name ! [theclass "def"]

ppBinder' :: Notation -> OccName -> Html
ppBinder' notation n = wrapInfix notation n $ ppOccName n

wrapInfix :: Notation -> OccName -> Html -> Html
wrapInfix notation n = case notation of
  Infix | is_star_kind -> id
        | not is_sym -> quote
  Prefix | is_star_kind -> id
         | is_sym -> parens
  _ -> id
  where
    is_sym = isSymOcc n
    is_star_kind = isTcOcc n && occNameString n == "*"

linkId :: Module -> Maybe Name -> Html -> Html
linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True

linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc mdl mbName insertAnchors =
  if insertAnchors
  then anchor ! [href url, title ttl]
  else id
  where
    ttl = moduleNameString (moduleName mdl)
    url = case mbName of
      Nothing   -> moduleUrl mdl
      Just name -> moduleNameUrl mdl name

linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
linkIdOcc' mdl mbName = anchor ! [href url, title ttl]
  where
    ttl = moduleNameString mdl
    url = case mbName of
      Nothing   -> moduleHtmlFile' mdl
      Just name -> moduleNameUrl' mdl name

ppModule :: Module -> Html
ppModule mdl = anchor ! [href (moduleUrl mdl)]
               << toHtml (moduleString mdl)

ppModuleRef :: ModuleName -> String -> Html
ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
                      << toHtml (moduleNameString mdl)
    -- NB: The ref parameter already includes the '#'.
    -- This function is only called from markupModule expanding a
    -- DocModule, which doesn't seem to be ever be used.


-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.Themes
-- Copyright   :  (c) Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Themes (
    Themes,
    getThemes,

    cssFiles, styleSheet
    )
    where

import Haddock.Options

import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Either (lefts, rights)
import Data.List (nub)
import Data.Maybe (isJust, listToMaybe)

import System.Directory
import System.FilePath
import Text.XHtml hiding ( name, title, p, quote, (</>) )
import qualified Text.XHtml as XHtml

--------------------------------------------------------------------------------
-- * CSS Themes
--------------------------------------------------------------------------------

data Theme = Theme {
  themeName :: String,
  themeHref :: String,
  themeFiles :: [FilePath]
  }

type Themes = [Theme]

type PossibleTheme = Either String Theme
type PossibleThemes = Either String Themes

-- | Find a theme by name (case insensitive match)
findTheme :: String -> Themes -> Maybe Theme
findTheme s = listToMaybe . filter ((== ls).lower.themeName)
  where lower = map toLower
        ls = lower s

-- | Standard theme used by default
standardTheme :: FilePath -> IO PossibleThemes
standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)

-- | Default themes that are part of Haddock; added with --default-themes
-- The first theme in this list is considered the standard theme.
-- Themes are "discovered" by scanning the html sub-dir of the libDir,
-- and looking for directories with the extension .theme or .std-theme.
-- The later is, obviously, the standard theme.
defaultThemes :: FilePath -> IO PossibleThemes
defaultThemes libDir = do
  themeDirs <- getDirectoryItems (libDir </> "html")
  themes <- mapM directoryTheme $ discoverThemes themeDirs
  return $ sequenceEither themes
  where
    discoverThemes paths =
      filterExt ".std-theme" paths ++ filterExt ".theme" paths
    filterExt ext = filter ((== ext).takeExtension)

-- | Build a theme from a single .css file
singleFileTheme :: FilePath -> IO PossibleTheme
singleFileTheme path =
  if isCssFilePath path
      then retRight $ Theme name file [path]
      else errMessage "File extension isn't .css" path
  where
    name = takeBaseName path
    file = takeFileName path

-- | Build a theme from a directory
directoryTheme :: FilePath -> IO PossibleTheme
directoryTheme path = do
  items <- getDirectoryItems path
  case filter isCssFilePath items of
    [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items
    [] -> errMessage "No .css file in theme directory" path
    _ -> errMessage "More than one .css file in theme directory" path

-- | Check if we have a built in theme
doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
doesBuiltInExist pts s = fmap (either (const False) test) pts
  where test = isJust . findTheme s

-- | Find a built in theme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme pts s = either Left fetch <$> pts
  where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s

--------------------------------------------------------------------------------
-- * CSS Theme Arguments
--------------------------------------------------------------------------------

-- | Process input flags for CSS Theme arguments
getThemes :: FilePath -> [Flag] -> IO PossibleThemes
getThemes libDir flags =
  liftM concatEither (mapM themeFlag flags) >>= someTheme
  where
    themeFlag :: Flag -> IO (Either String Themes)
    themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)
    themeFlag (Flag_BuiltInThemes) = builtIns
    themeFlag _ = retRight []

    theme :: FilePath -> IO PossibleTheme
    theme path = pick path
      [(doesFileExist,              singleFileTheme),
       (doesDirectoryExist,         directoryTheme),
       (doesBuiltInExist builtIns,  builtInTheme builtIns)]
      "Theme not found"

    pick :: FilePath
      -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String
      -> IO PossibleTheme
    pick path [] msg = errMessage msg path
    pick path ((test,build):opts) msg = do
      pass <- test path
      if pass then build path else pick path opts msg

    someTheme :: Either String Themes -> IO (Either String Themes)
    someTheme (Right []) = standardTheme libDir
    someTheme est = return est

    builtIns = defaultThemes libDir

errMessage :: String -> FilePath -> IO (Either String a)
errMessage msg path = return (Left msg')
  where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"

retRight :: a -> IO (Either String a)
retRight = return . Right

--------------------------------------------------------------------------------
-- * File Utilities
--------------------------------------------------------------------------------

getDirectoryItems :: FilePath -> IO [FilePath]
getDirectoryItems path =
  map (combine path) . filter notDot <$> getDirectoryContents path
  where notDot s = s /= "." && s /= ".."

isCssFilePath :: FilePath -> Bool
isCssFilePath path = takeExtension path == ".css"

--------------------------------------------------------------------------------
-- * Style Sheet Utilities
--------------------------------------------------------------------------------

cssFiles :: Themes -> [String]
cssFiles ts = nub $ concatMap themeFiles ts

styleSheet :: Themes -> Html
styleSheet ts = toHtml $ zipWith mkLink rels ts
  where
    rels = "stylesheet" : repeat "alternate stylesheet"
    mkLink aRel t =
      thelink
        ! [ href (themeHref t),  rel aRel, thetype "text/css",
            XHtml.title (themeName t)
          ]
        << noHtml

--------------------------------------------------------------------------------
-- * Either Utilities
--------------------------------------------------------------------------------

-- These three routines are here because Haddock does not have access to the
-- Control.Monad.Error module which supplies the Functor and Monad instances
-- for Either String.

sequenceEither :: [Either a b] -> Either a [b]
sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es))

liftEither :: (b -> c) -> Either a b -> Either a c
liftEither f = either Left (Right . f)

concatEither :: [Either a [b]] -> Either a [b]
concatEither = liftEither concat . sequenceEither


-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html.Types
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Types (
  SourceURLs, WikiURLs,
  LinksInfo,
  Splice,
  Unicode,
) where

import Data.Map
import GHC

-- the base, module and entity URLs for the source code and wiki links.
type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath)
type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)

-- The URL for source and wiki links
type LinksInfo = (SourceURLs, WikiURLs)

-- Whether something is a splice or not
type Splice = Bool

-- Whether unicode syntax is to be used
type Unicode = Bool