path: root/haddock-api/src/Haddock/Interface/Create.hs

{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.Create
-- Copyright   :  (c) Simon Marlow      2003-2006,
--                    David Waern       2006-2009,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where

import Documentation.Haddock.Doc (docAppend)
import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn

import qualified Data.Map as M
import Data.Map (Map)
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
import Control.Applicative
import Control.Arrow (second)
import Control.DeepSeq
import Control.Monad
import Data.Function (on)
import qualified Data.Foldable as F

import qualified Packages
import qualified Module
import qualified SrcLoc
import GHC
import HscTypes
import Name
import Bag
import RdrName
import TcRnTypes
import FastString (concatFS)
import qualified Outputable as O

-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
createInterface tm flags modMap instIfaceMap = do

  let ms             = pm_mod_summary . tm_parsed_module $ tm
      mi             = moduleInfo tm
      L _ hsm        = parsedSource tm
      !safety        = modInfoSafe mi
      mdl            = ms_mod ms
      dflags         = ms_hspp_opts ms
      !instances     = modInfoInstances mi
      !fam_instances = md_fam_insts md
      !exportedNames = modInfoExports mi

      (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm

  -- The renamed source should always be available to us, but it's best
  -- to be on the safe side.
  (group_, mayExports, mayDocHeader) <-
    case renamedSource tm of
      Nothing -> do
        liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
        return (emptyRnGroup, Nothing, Nothing)
      Just (x, _, y, z) -> return (x, y, z)

  opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
  let opts
        | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
        | otherwise = opts0

  (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader

  let declsWithDocs = topDecls group_
      fixMap = mkFixMap group_
      (decls, _) = unzip declsWithDocs
      localInsts = filter (nameIsLocalOrFrom mdl) $  map getName instances
                                                  ++ map getName fam_instances
      -- Locations of all TH splices
      splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]

      maps@(!docMap, !argMap, !subMap, !declMap, _) =
        mkMaps dflags gre localInsts declsWithDocs

  let exports0 = fmap (reverse . map unLoc) mayExports
      exports
        | OptIgnoreExports `elem` opts = Nothing
        | otherwise = exports0
      warningMap = mkWarningMap dflags warnings gre exportedNames

  let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))

  exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
                   maps fixMap splices exports instIfaceMap dflags

  let !visibleNames = mkVisibleNames maps exportItems opts

  -- Measure haddock documentation coverage.
  let prunedExportItems0 = pruneExportItems exportItems
      !haddockable = 1 + length exportItems -- module + exports
      !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
      !coverage = (haddockable, haddocked)

  -- Prune the export list to just those declarations that have
  -- documentation, if the 'prune' option is on.
  let prunedExportItems'
        | OptPrune `elem` opts = prunedExportItems0
        | otherwise = exportItems
      !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'

  let !aliases =
        mkAliasMap dflags $ tm_renamed_source tm
      modWarn = moduleWarning dflags gre warnings

  return $! Interface {
    ifaceMod             = mdl
  , ifaceOrigFilename    = msHsFilePath ms
  , ifaceInfo            = info
  , ifaceDoc             = Documentation mbDoc modWarn
  , ifaceRnDoc           = Documentation Nothing Nothing
  , ifaceOptions         = opts
  , ifaceDocMap          = docMap
  , ifaceArgMap          = argMap
  , ifaceRnDocMap        = M.empty
  , ifaceRnArgMap        = M.empty
  , ifaceExportItems     = prunedExportItems
  , ifaceRnExportItems   = []
  , ifaceExports         = exportedNames
  , ifaceVisibleExports  = visibleNames
  , ifaceDeclMap         = declMap
  , ifaceSubMap          = subMap
  , ifaceFixMap          = fixMap
  , ifaceModuleAliases   = aliases
  , ifaceInstances       = instances
  , ifaceFamInstances    = fam_instances
  , ifaceHaddockCoverage = coverage
  , ifaceWarningMap      = warningMap
  }

mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap dflags mRenamedSource =
  case mRenamedSource of
    Nothing -> M.empty
    Just (_,impDecls,_,_) ->
      M.fromList $
      mapMaybe (\(SrcLoc.L _ impDecl) -> do
        alias <- ideclAs impDecl
        return $
          (lookupModuleDyn dflags
             (fmap Module.fsToPackageId $
              ideclPkgQual impDecl)
             (case ideclName impDecl of SrcLoc.L _ name -> name),
           alias))
        impDecls

-- similar to GHC.lookupModule
lookupModuleDyn ::
  DynFlags -> Maybe PackageId -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
  Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
  flip Module.mkModule mdlName $
  case filter snd $
       Packages.lookupModuleInAllPackages dflags mdlName of
    (pkgId,_):_ -> Packages.packageConfigId pkgId
    [] -> Module.mainPackageId


-------------------------------------------------------------------------------
-- Warnings
-------------------------------------------------------------------------------

mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
mkWarningMap dflags warnings gre exps = case warnings of
  NoWarnings  -> M.empty
  WarnAll _   -> M.empty
  WarnSome ws ->
    let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
              , let n = gre_name elt, n `elem` exps ]
    in M.fromList $ map (second $ parseWarning dflags gre) ws'

moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
moduleWarning _ _ NoWarnings = Nothing
moduleWarning _ _ (WarnSome _) = Nothing
moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w

parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
parseWarning dflags gre w = force $ case w of
  DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
  WarningTxt    msg -> format "Warning: "    (concatFS msg)
  where
    format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
                  . processDocString dflags gre $ HsDocString xs


-------------------------------------------------------------------------------
-- Doc options
--
-- Haddock options that are embedded in the source file
-------------------------------------------------------------------------------


mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
mkDocOpts mbOpts flags mdl = do
  opts <- case mbOpts of
    Just opts -> case words $ replace ',' ' ' opts of
      [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
      xs -> liftM catMaybes (mapM parseOption xs)
    Nothing -> return []
  hm <- if Flag_HideModule (moduleString mdl) `elem` flags
        then return $ OptHide : opts
        else return opts
  if Flag_ShowExtensions (moduleString mdl) `elem` flags
    then return $ OptShowExtensions : hm
    else return hm


parseOption :: String -> ErrMsgM (Maybe DocOption)
parseOption "hide"            = return (Just OptHide)
parseOption "prune"           = return (Just OptPrune)
parseOption "ignore-exports"  = return (Just OptIgnoreExports)
parseOption "not-home"        = return (Just OptNotHome)
parseOption "show-extensions" = return (Just OptShowExtensions)
parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing


--------------------------------------------------------------------------------
-- Maps
--------------------------------------------------------------------------------


type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)

-- | Create 'Maps' by looping through the declarations. For each declaration,
-- find its names, its subordinates, and its doc strings. Process doc strings
-- into 'Doc's.
mkMaps :: DynFlags
       -> GlobalRdrEnv
       -> [Name]
       -> [(LHsDecl Name, [HsDocString])]
       -> Maps
mkMaps dflags gre instances decls =
  let (a, b, c, d) = unzip4 $ map mappings decls
  in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
  where
    f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
    f = M.fromListWith (<>) . concat

    f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)
    f' = M.fromListWith docAppend . concat

    mappings :: (LHsDecl Name, [HsDocString])
             -> ( [(Name, Doc Name)]
                , [(Name, Map Int (Doc Name))]
                , [(Name, [Name])]
                , [(Name,  [LHsDecl Name])]
                )
    mappings (ldecl, docStrs) =
      let L l decl = ldecl
          declDoc :: [HsDocString] -> Map Int HsDocString
                  -> (Maybe (Doc Name), Map Int (Doc Name))
          declDoc strs m =
            let doc' = processDocStrings dflags gre strs
                m' = M.map (processDocStringParas dflags gre) m
            in (doc', m')
          (doc, args) = declDoc docStrs (typeDocs decl)
          subs :: [(Name, [HsDocString], Map Int HsDocString)]
          subs = subordinates instanceMap decl
          (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
          ns = names l decl
          subNs = [ n | (n, _, _) <- subs ]
          dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
          am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
          sm = [ (n, subNs) | n <- ns ]
          cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
      in seqList ns `seq`
          seqList subNs `seq`
          doc `seq`
          seqList subDocs `seq`
          seqList subArgs `seq`
          (dm, am, sm, cm)

    instanceMap :: Map SrcSpan Name
    instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]

    names :: SrcSpan -> HsDecl Name -> [Name]
    names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
      where loc = case d of
              TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
              _ -> getInstLoc d
    names _ decl = getMainDeclBinder decl

-- Note [2]:
------------
-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
-- That should work for normal user-written instances (from looking at GHC
-- sources). We can assume that commented instances are user-written.
-- This lets us relate Names (from ClsInsts) to comments (associated
-- with InstDecls).


--------------------------------------------------------------------------------
-- Declarations
--------------------------------------------------------------------------------


-- | Get all subordinate declarations inside a declaration, and their docs.
subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
  InstD (ClsInstD d) -> do
    DataFamInstDecl { dfid_tycon = L l _
                    , dfid_defn = def    } <- unLoc <$> cid_datafam_insts d
    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def

  InstD (DataFamInstD d)  -> dataSubs (dfid_defn d)
  TyClD d | isClassDecl d -> classSubs d
          | isDataDecl  d -> dataSubs (tcdDataDefn d)
  _ -> []
  where
    classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
                   , name <- getMainDeclBinder d, not (isValD d)
                   ]
    dataSubs dd = constrs ++ fields
      where
        cons = map unL $ (dd_cons dd)
        constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
                  | c <- cons ]
        fields  = [ (unL n, maybeToList $ fmap unL doc, M.empty)
                  | RecCon flds <- map con_details cons
                  , ConDeclField n _ doc <- flds ]

-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
typeDocs d =
  let docs = go 0 in
  case d of
    SigD (TypeSig _ ty) -> docs (unLoc ty)
    SigD (PatSynSig _ arg_tys ty req prov) ->
        let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]
        in F.foldMap (docs . unLoc) allTys
    ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
    TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
    _ -> M.empty
  where
    go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
    go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
    go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
    go n (HsDocTy _ (L _ doc)) = M.singleton n doc
    go _ _ = M.empty


-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
  where
    decls = docs ++ defs ++ sigs ++ ats
    docs  = mkDecls tcdDocs DocD class_
#if MIN_VERSION_ghc(7,8,3)
    defs  = mkDecls (bagToList . tcdMeths) ValD class_
#else
    defs  = mkDecls (map snd . bagToList . tcdMeths) ValD class_
#endif
    sigs  = mkDecls tcdSigs SigD class_
    ats   = mkDecls tcdATs (TyClD . FamDecl) class_


-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup

-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup Name -> FixMap
mkFixMap group_ = M.fromList [ (n,f)
                             | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]


-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup Name -> [LHsDecl Name]
ungroup group_ =
  mkDecls (tyClGroupConcat . hs_tyclds) TyClD  group_ ++
  mkDecls hs_derivds             DerivD group_ ++
  mkDecls hs_defds               DefD   group_ ++
  mkDecls hs_fords               ForD   group_ ++
  mkDecls hs_docs                DocD   group_ ++
  mkDecls hs_instds              InstD  group_ ++
  mkDecls (typesigs . hs_valds)  SigD   group_ ++
#if MIN_VERSION_ghc(7,8,3)
  mkDecls (valbinds . hs_valds)  ValD   group_
#else
  mkDecls (map snd . valbinds . hs_valds)  ValD   group_
#endif
  where
    typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
    typesigs _ = error "expected ValBindsOut"

    valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
    valbinds _ = error "expected ValBindsOut"


-- | Take a field of declarations from a data structure and create HsDecls
-- using the given constructor
mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]


-- | Sort by source location
sortByLoc :: [Located a] -> [Located a]
sortByLoc = sortBy (comparing getLoc)


--------------------------------------------------------------------------------
-- Filtering of declarations
--
-- We filter out declarations that we don't intend to handle later.
--------------------------------------------------------------------------------


-- | Filter out declarations that we don't handle in Haddock
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
  where
    isHandled (ForD (ForeignImport {})) = True
    isHandled (TyClD {}) = True
    isHandled (InstD {}) = True
    isHandled (SigD d) = isVanillaLSig (reL d)
    isHandled (ValD _) = True
    -- we keep doc declarations to be able to get at named docs
    isHandled (DocD _) = True
    isHandled _ = False


-- | Go through all class declarations and filter their sub-declarations
filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
                      | x@(L loc d, doc) <- decls ]
  where
    filterClass (TyClD c) =
      TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }
    filterClass _ = error "expected TyClD"


--------------------------------------------------------------------------------
-- Collect docs
--
-- To be able to attach the right Haddock comment to the right declaration,
-- we sort the declarations by their SrcLoc and "collect" the docs for each
-- declaration.
--------------------------------------------------------------------------------


-- | Collect docs and attach them to the right declarations.
collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
collectDocs = go Nothing []
  where
    go Nothing _ [] = []
    go (Just prev) docs [] = finished prev docs []
    go prev docs (L _ (DocD (DocCommentNext str)) : ds)
      | Nothing <- prev = go Nothing (str:docs) ds
      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
    go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
    go Nothing docs (d:ds) = go (Just d) docs ds
    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)

    finished decl docs rest = (decl, reverse docs) : rest


-- | Build the list of items that will become the documentation, from the
-- export list.  At this point, the list of ExportItems is in terms of
-- original names.
--
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
  :: IfaceMap
  -> Module             -- this module
  -> WarningMap
  -> GlobalRdrEnv
  -> [Name]             -- exported names (orig)
  -> [LHsDecl Name]
  -> Maps
  -> FixMap
  -> [SrcSpan]          -- splice locations
  -> Maybe [IE Name]
  -> InstIfaceMap
  -> DynFlags
  -> ErrMsgGhc [ExportItem Name]
mkExportItems
  modMap thisMod warnings gre exportedNames decls
  maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
  case optExports of
    Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
    Just exports -> liftM concat $ mapM lookupExport exports
  where
    lookupExport (IEVar x)             = declWith x
    lookupExport (IEThingAbs t)        = declWith t
    lookupExport (IEThingAll t)        = declWith t
    lookupExport (IEThingWith t _)     = declWith t
    lookupExport (IEModuleContents m)  =
      moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
    lookupExport (IEGroup lev docStr)  = return $
      return . ExportGroup lev "" $ processDocString dflags gre docStr

    lookupExport (IEDoc docStr)        = return $
      return . ExportDoc $ processDocStringParas dflags gre docStr

    lookupExport (IEDocNamed str)      = liftErrMsg $
      findNamedDoc str [ unL d | d <- decls ] >>= return . \case
        Nothing -> []
        Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc

    declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
    declWith t =
      case findDecl t of
        ([L l (ValD _)], (doc, _)) -> do
          -- Top-level binding without type signature
          export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
          return [export]
        (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
          let declNames = getMainDeclBinder (unL decl)
          in case () of
            _
              -- temp hack: we filter out separately exported ATs, since we haven't decided how
              -- to handle them yet. We should really give an warning message also, and filter the
              -- name out in mkVisibleNames...
              | t `elem` declATs (unL decl)        -> return []

              -- We should not show a subordinate by itself if any of its
              -- parents is also exported. See note [1].
              | t `notElem` declNames,
                Just p <- find isExported (parents t $ unL decl) ->
                do liftErrMsg $ tell [
                     "Warning: " ++ moduleString thisMod ++ ": " ++
                     pretty dflags (nameOccName t) ++ " is exported separately but " ++
                     "will be documented under " ++ pretty dflags (nameOccName p) ++
                     ". Consider exporting it together with its parent(s)" ++
                     " for code clarity." ]
                   return []

              -- normal case
              | otherwise -> case decl of
                  -- A single signature might refer to many names, but we
                  -- create an export item for a single name only.  So we
                  -- modify the signature to contain only that single name.
                  L loc (SigD sig) ->
                    -- fromJust is safe since we already checked in guards
                    -- that 't' is a name declared in this declaration.
                    let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
                    in return [ mkExportDecl t newDecl docs_ ]

                  L loc (TyClD cl@ClassDecl{}) -> do
                    mdef <- liftGhcToErrMsgGhc $ minimalDef t
                    let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
                    return [ mkExportDecl t
                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]

                  _ -> return [ mkExportDecl t decl docs_ ]

        -- Declaration from another package
        ([], _) -> do
          mayDecl <- hiDecl dflags t
          case mayDecl of
            Nothing -> return [ ExportNoDecl t [] ]
            Just decl ->
              -- We try to get the subs and docs
              -- from the installed .haddock file for that package.
              case M.lookup (nameModule t) instIfaceMap of
                Nothing -> do
                   liftErrMsg $ tell
                      ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
                   let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
                   return [ mkExportDecl t decl (noDocForDecl, subs_) ]
                Just iface ->
                   return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]

        _ -> return []


    mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
    mkExportDecl name decl (doc, subs) = decl'
      where
        decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
        mdl = nameModule name
        subs' = filter (isExported . fst) subs
        sub_names = map fst subs'
        fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]


    isExported = (`elem` exportedNames)


    findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
    findDecl n
      | m == thisMod, Just ds <- M.lookup n declMap =
          (ds, lookupDocs n warnings docMap argMap subMap)
      | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
          (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
      | otherwise = ([], (noDocForDecl, []))
      where
        m = nameModule n


hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
hiDecl dflags t = do
  mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
  case mayTyThing of
    Nothing -> do
      liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
      return Nothing
    Just x -> case tyThingToLHsDecl x of
      Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
      Right (m, t) -> liftErrMsg (tell $ map bugWarn m)
                      >> return (Just $ noLoc t)
    where
      warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
                   O.comma O.<+> O.quotes (O.ppr t) O.<+>
                   O.text "-- Please report this on Haddock issue tracker!"
      bugWarn = O.showSDoc dflags . warnLine

hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
hiValExportItem dflags name doc splice fixity = do
  mayDecl <- hiDecl dflags name
  case mayDecl of
    Nothing -> return (ExportNoDecl name [])
    Just decl -> return (ExportDecl decl doc [] [] fixities splice)
  where
    fixities = case fixity of
      Just f  -> [(name, f)]
      Nothing -> []


-- | Lookup docs for a declaration from maps.
lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
lookupDocs n warnings docMap argMap subMap =
  let lookupArgDoc x = M.findWithDefault M.empty x argMap in
  let doc = (lookupDoc n, lookupArgDoc n) in
  let subs = M.findWithDefault [] n subMap in
  let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
  (doc, subDocs)
  where
    lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)


-- | Return all export items produced by an exported module. That is, we're
-- interested in the exports produced by \"module B\" in such a scenario:
--
-- > module A (module B) where
-- > import B (...) hiding (...)
--
-- There are three different cases to consider:
--
-- 1) B is hidden, in which case we return all its exports that are in scope in A.
-- 2) B is visible, but not all its exports are in scope in A, in which case we
--    only return those that are.
-- 3) B is visible and all its exports are in scope, in which case we return
--    a single 'ExportModule' item.
moduleExports :: Module           -- ^ Module A
              -> ModuleName       -- ^ The real name of B, the exported module
              -> DynFlags         -- ^ The flags used when typechecking A
              -> WarningMap
              -> GlobalRdrEnv     -- ^ The renaming environment used for A
              -> [Name]           -- ^ All the exports of A
              -> [LHsDecl Name]   -- ^ All the declarations in A
              -> IfaceMap         -- ^ Already created interfaces
              -> InstIfaceMap     -- ^ Interfaces in other packages
              -> Maps
              -> FixMap
              -> [SrcSpan]        -- ^ Locations of all TH splices
              -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
  | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
  | otherwise =
    case M.lookup m ifaceMap of
      Just iface
        | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
        | otherwise -> return [ ExportModule m ]

      Nothing -> -- We have to try to find it in the installed interfaces
                 -- (external packages).
        case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
          Just iface -> return [ ExportModule (instMod iface) ]
          Nothing -> do
            liftErrMsg $
              tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
                    "documentation for exported module: " ++ pretty dflags expMod]
            return []
  where
    m = mkModule packageId expMod
    packageId = modulePackageId thisMod


-- Note [1]:
------------
-- It is unnecessary to document a subordinate by itself at the top level if
-- any of its parents is also documented. Furthermore, if the subordinate is a
-- record field or a class method, documenting it under its parent
-- indicates its special status.
--
-- A user might expect that it should show up separately, so we issue a
-- warning. It's a fine opportunity to also tell the user she might want to
-- export the subordinate through the parent export item for clarity.
--
-- The code removes top-level subordinates also when the parent is exported
-- through a 'module' export. I think that is fine.
--
-- (For more information, see Trac #69)


fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
                   -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
  liftM catMaybes $ mapM mkExportItem (expandSig decls)
  where
    -- A type signature can have multiple names, like:
    --   foo, bar :: Types..
    --
    -- We go through the list of declarations and expand type signatures, so
    -- that every type signature has exactly one name!
    expandSig :: [LHsDecl name] -> [LHsDecl name]
    expandSig = foldr f []
      where
        f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
        f (L l (SigD (TypeSig    names t)))          xs = foldr (\n acc -> L l (SigD (TypeSig    [n] t))          : acc) xs names
        f (L l (SigD (GenericSig names t)))          xs = foldr (\n acc -> L l (SigD (GenericSig [n] t))          : acc) xs names
        f x xs = x : xs

    mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
    mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
      return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
    mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
      return . Just . ExportDoc $ processDocStringParas dflags gre docStr
    mkExportItem (L l (ValD d))
      | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
          -- Top-level binding without type signature.
          let (doc, _) = lookupDocs name warnings docMap argMap subMap in
          fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
      | otherwise = return Nothing
    mkExportItem decl@(L l (InstD d))
      | Just name <- M.lookup (getInstLoc d) instMap =
        let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
        return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
    mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
      mdef <- liftGhcToErrMsgGhc $ minimalDef name
      let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
      expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
    mkExportItem decl@(L l d)
      | name:_ <- getMainDeclBinder d = expDecl decl l name
      | otherwise = return Nothing

    fixities name subs = [ (n,f) | n <- name : map fst subs
                                 , Just f <- [M.lookup n fixMap] ]

    expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
      where (doc, subs) = lookupDocs name warnings docMap argMap subMap


-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method.  In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
extractDecl name mdl decl
  | name `elem` getMainDeclBinder (unLoc decl) = decl
  | otherwise  =
    case unLoc decl of
      TyClD d@ClassDecl {} ->
        let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
                        isVanillaLSig sig ] -- TODO: document fixity
        in case matches of
          [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
                      L pos sig = extractClassDecl n tyvar_names s0
                  in L pos (SigD sig)
          _ -> error "internal: extractDecl (ClassDecl)"
      TyClD d@DataDecl {} ->
        let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
        in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
      InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
                                          , dfid_pats = HsWB { hswb_cts = tys }
                                          , dfid_defn = defn }) ->
        SigD <$> extractRecSel name mdl n tys (dd_cons defn)
      InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
        let matches = [ d | L _ d <- insts
                          , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
                          , ConDeclField { cd_fld_name = L _ n } <- rec
                          , n == name
                      ]
        in case matches of
          [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
          _ -> error "internal: extractDecl (ClsInstD)"
      _ -> error "internal: extractDecl"
  where
    getTyVars = hsLTyVarLocNames . tyClDeclTyVars


toTypeNoLoc :: Located Name -> LHsType Name
toTypeNoLoc = noLoc . HsTyVar . unLoc


extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
  L _ (HsForAllTy expl tvs (L _ preds) ty) ->
    L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
  _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))
  where
    lctxt = noLoc . ctxt
    ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"


extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
              -> LSig Name
extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"

extractRecSel nm mdl t tvs (L _ con : rest) =
  case con_details con of
    RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
      L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
    _ -> extractRecSel nm mdl t tvs rest
 where
  matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
  data_ty
    | ResTyGADT ty <- con_res con = ty
    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs


-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
  where
    hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
    hasDoc _ = True


mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
mkVisibleNames (_, _, _, _, instMap) exports opts
  | OptHide `elem` opts = []
  | otherwise = let ns = concatMap exportName exports
                in seqList ns `seq` ns
  where
    exportName e@ExportDecl {} = name ++ subs
      where subs = map fst (expItemSubDocs e)
            name = case unLoc $ expItemDecl e of
              InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
              decl    -> getMainDeclBinder decl
    exportName ExportNoDecl {} = [] -- we don't count these as visible, since
                                    -- we don't want links to go to them.
    exportName _ = []

seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs

-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
  where
    search [] = do
      tell ["Cannot find documentation for: $" ++ name]
      return Nothing
    search (DocD (DocCommentNamed name' doc) : rest)
      | name == name' = return (Just doc)
      | otherwise = search rest
    search (_other_decl : rest) = search rest