<commit_before>{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.Create
-- Copyright   :  (c) <NAME> 2003-2006,
--                    <NAME>  2006-2009
-- 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.Monad
import qualified Data.Traversable as Traversable

import GHC hiding (flags)
import HscTypes
import Name
import Bag
import RdrName (GlobalRdrEnv)
import TcRnTypes (tcg_warns)
import FastString (unpackFS)


-- | 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
      mdl           = ms_mod ms
      dflags        = ms_hspp_opts ms
      instances     = modInfoInstances mi
      exportedNames = modInfoExports mi
      warnings      = tcg_warns . fst . 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)

  -- The pattern-match should not fail, because createInterface is only
  -- done on loaded modules.
  Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)

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

  (info, mbDoc) <- do
    (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
    return (i, addModuleWarnig warnings d)

  let declsWithDocs = topDecls group_
      (decls, _) = unzip declsWithDocs
      localInsts = filter (nameIsLocalOrFrom mdl . getName) instances

  maps@(docMap, argMap, subMap, declMap) <-
    liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs

  let exports0 = fmap (reverse . map unLoc) mayExports
      exports
       | OptIgnoreExports `elem` opts = Nothing
       | otherwise = exports0

  liftErrMsg $ warnAboutFilteredDecls mdl decls

  exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
                   instances instIfaceMap dflags

  let visibleNames = mkVisibleNames exportItems opts

  -- Measure haddock documentation coverage.<commit_msg>Add support for warnings<commit_after>{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.Create
-- Copyright   :  (c) <NAME> 2003-2006,
--                    <NAME>  2006-2009
-- 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.Monad
import qualified Data.Traversable as Traversable

import GHC hiding (flags)
import HscTypes
import Name
import Bag
import RdrName (GlobalRdrEnv)
import TcRnTypes (tcg_warns)
import FastString (unpackFS)


-- | 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
      mdl           = ms_mod ms
      dflags        = ms_hspp_opts ms
      instances     = modInfoInstances mi
      exportedNames = modInfoExports mi
      warnings      = tcg_warns . fst . 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)

  -- The pattern-match should not fail, because createInterface is only
  -- done on loaded modules.
  Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)

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

  (info, mbDoc) <- do
    (i, d) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
    return (i, addModuleWarnig warnings d)

  let declsWithDocs = topDecls group_
      (decls, _) = unzip declsWithDocs
      localInsts = filter (nameIsLocalOrFrom mdl . getName) instances

  (docs, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs

  -- Attach warnings to documentation as appropriate.  If there is a warning
  -- for an identifier with no documentation, create a piece of documentation,
  -- that just contains the warning.
  let docMap = warningMap `combine` docs
        where
          combine :: (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
          combine = M.unionWith mappend

          warningMap = case warnings of
            -- NOTE: warningMap may contain more elements than xs, e.g.  when
            -- we have a warning for:
            --
            --   data Foo = Foo
            --
            -- So you can not just map over xs!
            (WarnSome xs) -> foldr f M.empty exportedNames
              where
                f name m = case lookup (getOccName name) xs of
                  Just x  -> M.insert name (warningToDoc x) m
                  Nothing -> m
            _ -> M.empty

  let maps = (docMap, argMap, subMap, declMap)

  let exports0 = fmap (reverse . map unLoc) mayExports
      exports
       | OptIgnoreExports `elem` opts = Nothing
       | otherwise = exports0

  liftErrMsg $ warnAboutFilteredDecls mdl decls

  exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
                   instances instIfaceMap dflags

  let visibleNames = mkVisibleNames exportItems opts

  -- Measure haddock documentation coverage.
{'fraction_non_alphanumeric': 0.11380243572395128, 'fraction_numerical': 0.005683355886332882, 'mean_word_length': 2.353448275862069, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 28, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5301707', 'n_tokens_mistral': 2179, 'n_tokens_neox': 2117, 'n_words': 720}