<commit_before>{-# LANGUAGE TupleSections, BangPatterns, LambdaCase #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.Create
-- Copyright   :  (c) <NAME>      2003-2006,
--                    <NAME>       2006-2009,
--                    <NAME> 2013
-- License     :  BSD-like
--
-- Maintainer  :  <EMAIL>
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where


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 UniqFM


-- | 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.fsToPackageKey $
              ideclPkgQual impDecl)
             (case ideclName impDecl of SrcLoc.L _ name -> name),
           alias))
        impDecls

-- similar to GHC.lookupModule
lookupModuleDyn ::
  DynFlags -> Maybe PackageKey -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
  Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
  flip Module.mkModule mdlName $
  case filter Packages.modConfExposed . eltsUFM $
       Packages.lookupModuleInAllPackages dflags mdlName of
    m:_ -> Packages.packageConfigId (Packages.modConfPkg m)
    [] -> Module.mainPackageKey


-------------------------------------------------------------------------------
-- 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)<commit_msg>Track type signature change of lookupModuleInAllPackages<commit_after>{-# LANGUAGE TupleSections, BangPatterns, LambdaCase #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.Create
-- Copyright   :  (c) <NAME>      2003-2006,
--                    <NAME>       2006-2009,
--                    <NAME> 2013
-- License     :  BSD-like
--
-- Maintainer  :  <EMAIL>
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where


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)


-- | 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.fsToPackageKey $
              ideclPkgQual impDecl)
             (case ideclName impDecl of SrcLoc.L _ name -> name),
           alias))
        impDecls

-- similar to GHC.lookupModule
lookupModuleDyn ::
  DynFlags -> Maybe PackageKey -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
  Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
  case Packages.lookupModuleInAllPackages dflags mdlName of
    (m,_):_ -> m
    [] -> Module.mkModule Module.mainPackageKey mdlName


-------------------------------------------------------------------------------
-- 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)
{'fraction_non_alphanumeric': 0.11889455405305549, 'fraction_numerical': 0.004581393630384985, 'mean_word_length': 2.237799043062201, 'pattern_counts': {'":': 0, '<': 27, '<?xml version=': 0, '>': 65, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3690340', 'n_tokens_mistral': 4068, 'n_tokens_neox': 3942, 'n_words': 1168}