{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wwarn=x-partial #-}

-- |
-- Module      :  Haddock.Backends.Html
-- Copyright   :  (c) Simon Marlow      2003-2006,
--                    David Waern       2006-2009,
--                    Mark Lentczner    2010,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
module Haddock.Backends.Xhtml
  ( ppHtml
  , copyHtmlBits
  , ppHtmlIndex
  , ppHtmlContents
  , ppJsonIndex
  ) where

import Control.DeepSeq (force)
import Control.Monad (unless, when)
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Builder as Builder
import Data.Char (isSpace, toUpper)
import Data.Either (partitionEithers)
import Data.Foldable (traverse_)
import Data.List (intersperse, isPrefixOf, sortBy)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Ord (comparing)
import qualified Data.Set as Set hiding (Set)
import GHC hiding (LexicalFixity (..), NoLink, moduleInfo)
import GHC.Types.Name
import GHC.Unit.State
import System.Directory
import System.FilePath hiding ((</>))
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import Text.XHtml hiding (name, p, quote, title)
import qualified Text.XHtml as XHtml
import Prelude hiding (div)

import Haddock.Backends.Xhtml.Decl
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Themes
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo)
import Haddock.ModuleTree
import Haddock.Options (Visibility (..))
import Haddock.Types
import Haddock.Utils
import Haddock.Utils.Json
import Haddock.Version

--------------------------------------------------------------------------------

-- * Generating HTML documentation

--------------------------------------------------------------------------------

ppHtml
  :: UnitState
  -> String
  -- ^ Title
  -> Maybe String
  -- ^ Package
  -> [Interface]
  -> [InstalledInterface]
  -- ^ Reexported interfaces
  -> FilePath
  -- ^ Destination directory
  -> Maybe (MDoc GHC.RdrName)
  -- ^ Prologue text, maybe
  -> Themes
  -- ^ Themes
  -> Maybe String
  -- ^ The mathjax URL (--mathjax)
  -> SourceURLs
  -- ^ The source URL (--source)
  -> WikiURLs
  -- ^ The wiki URL (--wiki)
  -> BaseURL
  -- ^ The base URL (--base-url)
  -> Maybe String
  -- ^ The contents URL (--use-contents)
  -> Maybe String
  -- ^ The index URL (--use-index)
  -> Bool
  -- ^ Whether to use unicode in output (--use-unicode)
  -> Maybe String
  -- ^ Package name
  -> PackageInfo
  -- ^ Package info
  -> QualOption
  -- ^ How to qualify names
  -> Bool
  -- ^ Output pretty html (newlines and indenting)
  -> Bool
  -- ^ Also write Quickjump index
  -> IO ()
ppHtml
  state
  doctitle
  maybe_package
  ifaces
  reexported_ifaces
  odir
  prologue
  themes
  maybe_mathjax_url
  maybe_source_url
  maybe_wiki_url
  maybe_base_url
  maybe_contents_url
  maybe_index_url
  unicode
  pkg
  packageInfo
  qual
  debug
  withQuickjump = do
    let
      visible_ifaces = filter visible ifaces
      visible i = OptHide `notElem` ifaceOptions i

    when (isNothing maybe_contents_url) $
      ppHtmlContents
        state
        odir
        doctitle
        maybe_package
        themes
        maybe_mathjax_url
        maybe_index_url
        maybe_source_url
        maybe_wiki_url
        [ PackageInterfaces
            { piPackageInfo = packageInfo
            , piVisibility = Visible
            , piInstalledInterfaces =
                map toInstalledIface visible_ifaces
                  ++ reexported_ifaces
            }
        ]
        False -- we don't want to display the packages in a single-package contents
        prologue
        debug
        pkg
        (makeContentsQual qual)

    when (isNothing maybe_index_url) $ do
      ppHtmlIndex
        odir
        doctitle
        maybe_package
        themes
        maybe_mathjax_url
        maybe_contents_url
        maybe_source_url
        maybe_wiki_url
        (map toInstalledIface visible_ifaces ++ reexported_ifaces)
        debug

    when withQuickjump $
      ppJsonIndex
        odir
        maybe_source_url
        maybe_wiki_url
        unicode
        pkg
        qual
        visible_ifaces
        []

    mapM_
      ( ppHtmlModule
          odir
          doctitle
          themes
          maybe_mathjax_url
          maybe_source_url
          maybe_wiki_url
          maybe_base_url
          maybe_contents_url
          maybe_index_url
          unicode
          pkg
          qual
          debug
      )
      visible_ifaces

copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
copyHtmlBits odir libdir themes withQuickjump = do
  let
    libhtmldir = joinPath [libdir, "html"]
    copyCssFile f = copyFile f (combine odir (takeFileName f))
    copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
  mapM_ copyCssFile (cssFiles themes)
  copyLibFile haddockJsFile
  copyCssFile (joinPath [libhtmldir, quickJumpCssFile])
  when withQuickjump (copyLibFile jsQuickJumpFile)
  return ()

headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html
headHtml docTitle themes mathjax_url base_url =
  header
    ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url]) base_url)
    << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"]
       , meta ! [XHtml.name "viewport", content "width=device-width, initial-scale=1"]
       , thetitle << docTitle
       , styleSheet base_url themes
       , thelink
          ! [ rel "stylesheet"
            , thetype "text/css"
            , href (withBaseURL base_url quickJumpCssFile)
            ]
          << noHtml
       , thelink ! [rel "stylesheet", thetype "text/css", href fontUrl] << noHtml
       , script
          ! [ src (withBaseURL base_url haddockJsFile)
            , emptyAttr "async"
            , thetype "text/javascript"
            ]
          << noHtml
       , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf
       , script ! [src mjUrl, thetype "text/javascript"] << noHtml
       ]
  where
    fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"
    mjUrl = fromMaybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" mathjax_url
    mjConf =
      unwords
        [ "MathJax.Hub.Config({"
        , "tex2jax: {"
        , "processClass: \"mathjax\","
        , "ignoreClass: \".*\""
        , "}"
        , "});"
        ]

srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
srcButton (Just src_base_url, _, _, _) Nothing =
  Just (anchor ! [href src_base_url] << "Source")
srcButton (_, Just src_module_url, _, _) (Just iface) =
  let url = spliceURL (Just $ ifaceMod iface) Nothing Nothing src_module_url
   in Just (anchor ! [href url] << "Source")
srcButton _ _ =
  Nothing

wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
wikiButton (Just wiki_base_url, _, _) Nothing =
  Just (anchor ! [href wiki_base_url] << "User Comments")
wikiButton (_, Just wiki_module_url, _) (Just mdl) =
  let url = spliceURL (Just mdl) Nothing Nothing wiki_module_url
   in Just (anchor ! [href url] << "User Comments")
wikiButton _ _ =
  Nothing

contentsButton :: Maybe String -> Maybe Html
contentsButton maybe_contents_url =
  Just (anchor ! [href url] << "Contents")
  where
    url = fromMaybe contentsHtmlFile maybe_contents_url

indexButton :: Maybe String -> Maybe Html
indexButton maybe_index_url =
  Just (anchor ! [href url] << "Index")
  where
    url = fromMaybe indexHtmlFile maybe_index_url

bodyHtml
  :: String
  -> Maybe Interface
  -> SourceURLs
  -> WikiURLs
  -> Maybe String
  -> Maybe String
  -> Html
  -> Html
bodyHtml
  doctitle
  iface
  maybe_source_url
  maybe_wiki_url
  maybe_contents_url
  maybe_index_url
  pageContent =
    body
      << [ divPackageHeader
            << [ nonEmptySectionName << doctitle
               , unordList
                  ( catMaybes
                      [ srcButton maybe_source_url iface
                      , wikiButton maybe_wiki_url (ifaceMod <$> iface)
                      , contentsButton maybe_contents_url
                      , indexButton maybe_index_url
                      ]
                  )
                  ! [theclass "links", identifier "page-menu"]
               ]
         , divContent << pageContent
         , divFooter
            << paragraph
            << ( "Produced by "
                  +++ (anchor ! [href projectUrl] << toHtml projectName)
                  +++ (" version " ++ projectVersion)
               )
         ]

moduleInfo :: Interface -> Html
moduleInfo iface =
  let
    info = ifaceInfo iface

    doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
    doOneEntry (fldNm, fld) =
      fld info >>= \a -> return (th << fldNm <-> td << a)

    entries :: [HtmlTable]
    entries =
      maybeToList copyrightsTable
        ++ mapMaybe
          doOneEntry
          [ ("License", hmi_license)
          , ("Maintainer", hmi_maintainer)
          , ("Stability", hmi_stability)
          , ("Portability", hmi_portability)
          , ("Safe Haskell", hmi_safety)
          , ("Language", lg)
          ]
        ++ extsForm
      where
        lg inf = fmap show (hmi_language inf)

        multilineRow :: String -> [String] -> HtmlTable
        multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
          where
            toLines = mconcat . intersperse br . map toHtml

        copyrightsTable :: Maybe HtmlTable
        copyrightsTable = fmap (multilineRow "Copyright" . split) (hmi_copyright info)
          where
            split = map (trim . filter (/= ',')) . lines

        extsForm
          | OptShowExtensions `elem` ifaceOptions iface =
              let fs = map (dropOpt . show) (hmi_extensions info)
               in case map stringToHtml fs of
                    [] -> []
                    [x] -> extField x -- don't use a list for a single extension
                    xs -> extField $ unordList xs ! [theclass "extension-list"]
          | otherwise = []
          where
            extField x = return $ th << "Extensions" <-> td << x
            dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
   in
    case entries of
      [] -> noHtml
      _ -> table ! [theclass "info"] << aboves entries

--------------------------------------------------------------------------------

-- * Generate the module contents

--------------------------------------------------------------------------------

ppHtmlContents
  :: UnitState
  -> FilePath
  -> String
  -> Maybe String
  -> Themes
  -> Maybe String
  -> Maybe String
  -> SourceURLs
  -> WikiURLs
  -> [PackageInterfaces]
  -> Bool
  -> Maybe (MDoc GHC.RdrName)
  -> Bool
  -> Maybe Package
  -- ^ Current package
  -> Qualification
  -- ^ How to qualify names
  -> IO ()
ppHtmlContents
  state
  odir
  doctitle
  _maybe_package
  themes
  mathjax_url
  maybe_index_url
  maybe_source_url
  maybe_wiki_url
  packages
  showPkgs
  prologue
  debug
  pkg
  qual = do
    let trees =
          [ ( piPackageInfo pinfo
            , mkModuleTree
                state
                showPkgs
                [ (instMod iface, toInstalledDescription iface)
                | iface <- piInstalledInterfaces pinfo
                , not (instIsSig iface)
                ]
            )
          | pinfo <- mergedPackages
          ]
        sig_trees =
          [ ( piPackageInfo pinfo
            , mkModuleTree
                state
                showPkgs
                [ (instMod iface, toInstalledDescription iface)
                | iface <- piInstalledInterfaces pinfo
                , instIsSig iface
                ]
            )
          | pinfo <- mergedPackages
          ]
        html =
          headHtml doctitle themes mathjax_url Nothing
            +++ bodyHtml
              doctitle
              Nothing
              maybe_source_url
              maybe_wiki_url
              Nothing
              maybe_index_url
            << [ ppPrologue pkg qual doctitle prologue
               , ppSignatureTrees pkg qual sig_trees
               , ppModuleTrees pkg qual trees
               ]
    createDirectoryIfMissing True odir
    writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
    where
      -- Extract a module's short description.
      toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
      toInstalledDescription = fmap mkMeta . hmi_description . instInfo

      -- Merge package interfaces from the same package (f.e. like those generated by --incremental)
      mergedPackages = Map.elems $ Map.fromListWith merge $ map (\p -> ((ppPackageInfo (piPackageInfo p), piVisibility p), p)) packages
      merge p1 p2 = p1{piInstalledInterfaces = piInstalledInterfaces p1 ++ piInstalledInterfaces p2}

ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
ppPrologue _ _ _ Nothing = noHtml
ppPrologue pkg qual title (Just doc) =
  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))

ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
ppSignatureTrees pkg qual [(info, ts)] =
  divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
ppSignatureTrees pkg qual tss =
  divModuleList
    << ( sectionName
          << "Signatures"
          +++ concatHtml
            [ ppSignatureTree pkg qual ("n." ++ show i ++ ".") info ts
            | (i, (info, ts)) <- zip [(1 :: Int) ..] tss
            ]
       )

ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html
ppSignatureTree _ _ _ _ [] = mempty
ppSignatureTree pkg qual p info ts =
  divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)

ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
ppModuleTrees _ _ tss | all (null . snd) tss = mempty
ppModuleTrees pkg qual [(info, ts)] =
  divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)
ppModuleTrees pkg qual tss =
  divPackageList
    << ( sectionName
          << "Packages"
          +++ concatHtml
            [ ppModuleTree pkg qual ("n." ++ show i ++ ".") info ts
            | (i, (info, ts)) <- zip [(1 :: Int) ..] tss
            ]
       )

ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html
ppModuleTree _ _ _ _ [] = mempty
ppModuleTree pkg qual p info ts =
  divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)

mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
mkNodeList pkg qual ss p ts = case ts of
  [] -> noHtml
  _ -> unordList (zipWith (mkNode pkg qual ss) ps ts)
  where
    ps = [p ++ '.' : show i | i <- [(1 :: Int) ..]]

mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html
mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
  htmlModule <+> shortDescr +++ htmlPkg +++ subtree
  where
    modAttrs = case (ts, leaf) of
      (_ : _, Nothing) -> collapseControl p "module"
      (_, _) -> [theclass "module"]

    cBtn = case (ts, leaf) of
      (_ : _, Just _) -> thespan ! collapseControl p "" << spaceHtml
      ([], Just _) -> thespan ! [theclass "noexpander"] << spaceHtml
      (_, _) -> noHtml
    -- We only need an explicit collapser button when the module name
    -- is also a leaf, and so is a link to a module page. Indeed, the
    -- spaceHtml is a minor hack and does upset the layout a fraction.

    htmlModule =
      thespan
        ! modAttrs
        << ( cBtn
              +++ case leaf of
                Just m -> ppModule m
                Nothing -> toHtml s
           )

    shortDescr = maybe noHtml (origDocToHtml pkg qual) short
    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg

    subtree =
      if null ts
        then noHtml
        else
          collapseDetails
            p
            DetailsOpen
            ( thesummary
                ! [theclass "hide-when-js-enabled"]
                << "Submodules"
                +++ mkNodeList pkg qual (s : ss) p ts
            )

--------------------------------------------------------------------------------

-- * Generate the index

--------------------------------------------------------------------------------

data JsonIndexEntry = JsonIndexEntry
  { jieHtmlFragment :: String
  , jieName :: String
  , jieModule :: String
  , jieLink :: String
  }
  deriving (Show)

instance ToJSON JsonIndexEntry where
  toJSON
    JsonIndexEntry
      { jieHtmlFragment
      , jieName
      , jieModule
      , jieLink
      } =
      Object
        [ "display_html" .= String jieHtmlFragment
        , "name" .= String jieName
        , "module" .= String jieModule
        , "link" .= String jieLink
        ]

instance FromJSON JsonIndexEntry where
  parseJSON = withObject "JsonIndexEntry" $ \v ->
    JsonIndexEntry
      <$> v .: "display_html"
      <*> v .: "name"
      <*> v .: "module"
      <*> v .: "link"

ppJsonIndex
  :: FilePath
  -> SourceURLs
  -- ^ The source URL (--source)
  -> WikiURLs
  -- ^ The wiki URL (--wiki)
  -> Bool
  -> Maybe Package
  -> QualOption
  -> [Interface]
  -> [FilePath]
  -- ^ file paths to interface files
  -- (--read-interface)
  -> IO ()
ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do
  createDirectoryIfMissing True odir
  (errors, installedIndexes) <-
    partitionEithers
      <$> traverse
        ( \ifaceFile -> do
            let indexFile =
                  takeDirectory ifaceFile
                    FilePath.</> "doc-index.json"
            a <- doesFileExist indexFile
            if a
              then
                bimap (indexFile,) (map (fixLink ifaceFile))
                  <$> eitherDecodeFile @[JsonIndexEntry] indexFile
              else return (Right [])
        )
        installedIfacesPaths
  traverse_
    (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)
    errors
  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->
    Builder.hPutBuilder
      h
      (encodeToBuilder (encodeIndexes (concat installedIndexes)))
  where
    encodeIndexes :: [JsonIndexEntry] -> Value
    encodeIndexes installedIndexes =
      toJSON
        ( concatMap fromInterface ifaces
            ++ installedIndexes
        )

    fromInterface :: Interface -> [JsonIndexEntry]
    fromInterface iface =
      mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface
      where
        qual = makeModuleQual qual_opt mdl
        mdl = ifaceMod iface

    mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry
    mkIndex mdl qual item
      | Just item_html <- processExport True links_info unicode pkg qual item =
          Just
            JsonIndexEntry
              { jieHtmlFragment = showHtmlFragment item_html
              , jieName = unwords (map getOccString names)
              , jieModule = moduleString mdl
              , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names))
              }
      | otherwise = Nothing
      where
        names = exportName item ++ exportSubs item

    exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
    exportSubs (ExportDecl (RnExportD{rnExpDExpD = ExportD{expDSubDocs}})) = map fst expDSubDocs
    exportSubs _ = []

    exportName :: ExportItem DocNameI -> [IdP DocNameI]
    exportName (ExportDecl (RnExportD{rnExpDExpD = ExportD{expDDecl}})) = getMainDeclBinderI (unLoc expDDecl)
    exportName ExportNoDecl{expItemName} = [expItemName]
    exportName _ = []

    nameLink :: NamedThing name => Module -> name -> String
    nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName

    links_info = (maybe_source_url, maybe_wiki_url)

    -- update link using relative path to output directory
    fixLink
      :: FilePath
      -> JsonIndexEntry
      -> JsonIndexEntry
    fixLink ifaceFile jie =
      jie
        { jieLink =
            makeRelative odir (takeDirectory ifaceFile)
              FilePath.</> jieLink jie
        }

ppHtmlIndex
  :: FilePath
  -> String
  -> Maybe String
  -> Themes
  -> Maybe String
  -> Maybe String
  -> SourceURLs
  -> WikiURLs
  -> [InstalledInterface]
  -> Bool
  -> IO ()
ppHtmlIndex
  odir
  doctitle
  _maybe_package
  themes
  maybe_mathjax_url
  maybe_contents_url
  maybe_source_url
  maybe_wiki_url
  ifaces
  debug = do
    let html =
          indexPage
            split_indices
            Nothing
            (if split_indices then [] else index)

    createDirectoryIfMissing True odir

    when split_indices $ do
      mapM_ (do_sub_index index) initialChars
      -- Let's add a single large index as well for those who don't know exactly what they're looking for:
      let mergedhtml = indexPage False Nothing index
      writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)

    writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html)
    where
      indexPage showLetters ch items =
        headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing
          +++ bodyHtml
            doctitle
            Nothing
            maybe_source_url
            maybe_wiki_url
            maybe_contents_url
            Nothing
          << [ if showLetters then indexInitialLetterLinks else noHtml
             , if null items
                then noHtml
                else divIndex << [sectionName << indexName ch, buildIndex items]
             ]

      indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
      merged_name = "All"

      buildIndex items = table << aboves (map indexElt items)

      -- an arbitrary heuristic:
      -- too large, and a single-page will be slow to load
      -- too small, and we'll have lots of letter-indexes with only one
      --   or two members in them, which seems inefficient or
      --   unnecessarily hard to use.
      split_indices = length index > 150

      indexInitialLetterLinks =
        divAlphabet
          << unordList
            ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
                [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
                ]
                  ++ [merged_name]
            )

      -- todo: what about names/operators that start with Unicode
      -- characters?
      -- Exports beginning with '_' can be listed near the end,
      -- presumably they're not as important... but would be listed
      -- with non-split index!
      initialChars = ['A' .. 'Z'] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"

      do_sub_index this_ix c =
        unless (null index_part) $
          writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
        where
          html = indexPage True (Just c) index_part
          index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]

      index :: [(String, Map GHC.Name [(Module, Bool)])]
      index = sortBy cmp (Map.toAscList full_index)
        where
          cmp (n1, _) (n2, _) = comparing (map toUpper) n1 n2

      -- for each name (a plain string), we have a number of original HsNames that
      -- it can refer to, and for each of those we have a list of modules
      -- that export that entity.  Each of the modules exports the entity
      -- in a visible or invisible way (hence the Bool).
      full_index :: Map String (Map GHC.Name [(Module, Bool)])
      full_index = List.foldl' f Map.empty ifaces
        where
          f
            :: Map String (Map Name [(Module, Bool)])
            -> InstalledInterface
            -> Map String (Map Name [(Module, Bool)])
          f !idx iface =
            Map.unionWith
              (Map.unionWith (\a b -> let !x = force $ a ++ b in x))
              idx
              (getIfaceIndex iface)

      getIfaceIndex :: InstalledInterface -> Map String (Map Name [(Module, Bool)])
      getIfaceIndex iface =
        List.foldl' f Map.empty (instExports iface)
        where
          f
            :: Map String (Map Name [(Module, Bool)])
            -> Name
            -> Map String (Map Name [(Module, Bool)])
          f !idx name =
            let !vis = name `Set.member` visible
             in Map.insertWith
                  (Map.unionWith (++))
                  (getOccString name)
                  (Map.singleton name [(mdl, vis)])
                  idx

          mdl = instMod iface
          visible = Set.fromList (instVisibleExports iface)

      indexElt :: (String, Map GHC.Name [(Module, Bool)]) -> HtmlTable
      indexElt (str, entities) =
        case Map.toAscList entities of
          [(nm, entries)] ->
            td
              ! [theclass "src"]
              << toHtml str
              <-> indexLinks nm entries
          many_entities ->
            td
              ! [theclass "src"]
              << toHtml str
              <-> td
              << spaceHtml
              </> aboves (zipWith (curry doAnnotatedEntity) [1 ..] many_entities)

      doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
      doAnnotatedEntity (j, (nm, entries)) =
        td
          ! [theclass "alt"]
          << toHtml (show j)
          <+> parens (ppAnnot (nameOccName nm))
          <-> indexLinks nm entries

      ppAnnot n
        | not (isValOcc n) = toHtml "Type/Class"
        | isDataOcc n = toHtml "Data Constructor"
        | otherwise = toHtml "Function"

      indexLinks nm entries =
        td
          ! [theclass "module"]
          << hsep
            ( punctuate
                comma
                [ if visible
                  then linkId mdl (Just nm) << toHtml (moduleString mdl)
                  else toHtml (moduleString mdl)
                | (mdl, visible) <- entries
                ]
            )

--------------------------------------------------------------------------------

-- * Generate the HTML page for a module

--------------------------------------------------------------------------------

ppHtmlModule
  :: FilePath
  -> String
  -> Themes
  -> Maybe String
  -> SourceURLs
  -> WikiURLs
  -> BaseURL
  -> Maybe String
  -> Maybe String
  -> Bool
  -> Maybe Package
  -> QualOption
  -> Bool
  -> Interface
  -> IO ()
ppHtmlModule
  odir
  doctitle
  themes
  maybe_mathjax_url
  maybe_source_url
  maybe_wiki_url
  maybe_base_url
  maybe_contents_url
  maybe_index_url
  unicode
  pkg
  qual
  debug
  iface = do
    let
      mdl = ifaceMod iface
      mdl_str = moduleString mdl
      mdl_str_annot =
        mdl_str
          ++ if ifaceIsSig iface
            then " (signature)"
            else ""
      mdl_str_linked
        | ifaceIsSig iface =
            mdl_str
              +++ " (signature"
              +++ sup
              << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]")
              +++ ")"
        | otherwise =
            toHtml mdl_str
      real_qual = makeModuleQual qual mdl
      html =
        headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url
          +++ bodyHtml
            doctitle
            (Just iface)
            maybe_source_url
            maybe_wiki_url
            maybe_contents_url
            maybe_index_url
          << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked))
             , ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
             ]

    createDirectoryIfMissing True odir
    writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)

signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"

ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual =
  ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface)
    +++ description
    +++ synopsis
    +++ divInterface (maybe_doc_hdr +++ bdy +++ orphans)
  where
    exports = numberSectionHeadings (ifaceRnExportItems iface)

    -- todo: if something has only sub-docs, or fn-args-docs, should
    -- it be measured here and thus prevent omitting the synopsis?
    has_doc
      ( ExportDecl
          ( RnExportD
              { rnExpDExpD =
                ExportD
                  { expDMbDoc =
                    (Documentation mDoc mWarn, _)
                  }
              }
            )
        ) = isJust mDoc || isJust mWarn
    has_doc (ExportNoDecl _ _) = False
    has_doc (ExportModule _) = False
    has_doc _ = True

    no_doc_at_all = not (any has_doc exports)

    description
      | isNoHtml doc = doc
      | otherwise = divDescription $ sectionName << "Description" +++ doc
      where
        doc = docSection Nothing pkg qual (ifaceRnDoc iface)

    -- omit the synopsis if there are no documentation annotations at all
    synopsis
      | no_doc_at_all = noHtml
      | otherwise =
          divSynopsis $
            collapseDetails
              "syn"
              DetailsClosed
              ( thesummary
                  << "Synopsis"
                  +++ shortDeclList
                    ( mapMaybe (processExport True linksInfo unicode pkg qual) exports
                    )
                  ! collapseToggle "syn" ""
              )

    -- if the documentation doesn't begin with a section header, then
    -- add one ("Documentation").
    maybe_doc_hdr =
      case exports of
        [] -> noHtml
        ExportGroup{} : _ -> noHtml
        _ -> h1 << "Documentation"

    bdy =
      foldr (+++) noHtml $
        mapMaybe (processExport False linksInfo unicode pkg qual) exports

    orphans =
      ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual

    linksInfo = (maybe_source_url, maybe_wiki_url)

ppModuleContents
  :: Maybe Package
  -- ^ This package
  -> Qualification
  -> [ExportItem DocNameI]
  -> Bool
  -- ^ Orphans sections
  -> Html
ppModuleContents pkg qual exports orphan
  | null sections && not orphan = noHtml
  | otherwise = contentsDiv
  where
    contentsDiv =
      divTableOfContents
        << ( divContentsList
              << ( (sectionName << "Contents")
                    ! [strAttr "onclick" "window.scrollTo(0,0)"]
                    +++ unordList (sections ++ orphanSection)
                 )
           )

    (sections, _leftovers {-should be []-}) = process 0 exports
    orphanSection
      | orphan = [linkedAnchor "section.orphans" << "Orphan instances"]
      | otherwise = []

    process :: Int -> [ExportItem DocNameI] -> ([Html], [ExportItem DocNameI])
    process _ [] = ([], [])
    process n items@(ExportGroup lev id0 doc : rest)
      | lev <= n = ([], items)
      | otherwise = (html : secs, rest2)
      where
        html =
          linkedAnchor (groupId id0)
            << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
            +++ mk_subsections ssecs
        (ssecs, rest1) = process lev rest
        (secs, rest2) = process n rest1
    process n (_ : rest) = process n rest

    mk_subsections [] = noHtml
    mk_subsections ss = unordList ss

-- we need to assign a unique id to each section heading so we can hyperlink
-- them from the contents:
numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI]
numberSectionHeadings = go 1
  where
    go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI]
    go _ [] = []
    go n (ExportGroup lev _ doc : es) =
      case collectAnchors doc of
        [] -> ExportGroup lev (show n) doc : go (n + 1) es
        (a : _) -> ExportGroup lev a doc : go (n + 1) es
    go n (other : es) =
      other : go n es

    collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String]
    collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b
    collectAnchors (DocAName a) = [a]
    collectAnchors _ = []

processExport
  :: Bool
  -> LinksInfo
  -> Bool
  -> Maybe Package
  -> Qualification
  -> ExportItem DocNameI
  -> Maybe Html
processExport
  _
  _
  _
  _
  _
  ( ExportDecl
      ( RnExportD
          { rnExpDExpD =
            ExportD
              { expDDecl = L _ (InstD{})
              }
          }
        )
    ) =
    Nothing -- Hide empty instances
processExport
  summary
  links
  unicode
  pkg
  qual
  ( ExportDecl
      ( RnExportD
          { rnExpDExpD =
            ExportD decl pats doc subdocs insts fixities splice
          }
        )
    ) =
    processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ pkg qual (ExportGroup lev id0 doc) =
  nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
processExport summary _ _ _ qual (ExportNoDecl y []) =
  processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ _ qual (ExportNoDecl y subs) =
  processDeclOneLiner summary $
    ppDocName qual Prefix True y
      +++ parenList (map (ppDocName qual Prefix True) subs)
processExport summary _ _ pkg qual (ExportDoc doc) =
  nothingIf summary $ docSection_ Nothing pkg qual doc
processExport summary _ _ _ _ (ExportModule mdl) =
  processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl

nothingIf :: Bool -> a -> Maybe a
nothingIf True _ = Nothing
nothingIf False a = Just a

processDecl :: Bool -> Html -> Maybe Html
processDecl True = Just
processDecl False = Just . divTopDecl

trim :: String -> String
trim = f . f
  where
    f = reverse . dropWhile isSpace

processDeclOneLiner :: Bool -> Html -> Maybe Html
processDeclOneLiner True = Just
processDeclOneLiner False = Just . divTopDecl . declElem

groupHeading :: Int -> String -> Html -> Html
groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId]
  where
    grpId = groupId id0

groupTag :: Int -> Html -> Html
groupTag lev
  | lev == 1 = h1
  | lev == 2 = h2
  | lev == 3 = h3
  | otherwise = h4
