aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface.hs
diff options
context:
space:
mode:
authorCale Gibbard <cgibbard@gmail.com>2020-04-09 14:34:57 -0400
committerJohn Ericson <John.Ericson@Obsidian.Systems>2020-05-21 16:02:06 -0400
commit35c0c99e16d278f0809b9658bc7dc4fdb42e4cb8 (patch)
tree9ce0c797da2f50dbe35a797f1b60291287672174 /haddock-api/src/Haddock/Interface.hs
parenta8d7e66da4dcc3b242103271875261604be42d6e (diff)
isBootSummary now produces a result of type IsBootInterface
Diffstat (limited to 'haddock-api/src/Haddock/Interface.hs')
-rw-r--r--haddock-api/src/Haddock/Interface.hs113
1 files changed, 57 insertions, 56 deletions
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index fa0f648f..b35b54e0 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -152,62 +152,63 @@ processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
- if not $ isBootSummary modsum then do
- out verbosity verbose "Creating interface..."
- (interface, msgs) <- {-# SCC createIterface #-}
- withTimingD "createInterface" (const ()) $ do
- runWriterGhc $ createInterface tm flags modMap instIfaceMap
-
- -- We need to keep track of which modules were somehow in scope so that when
- -- Haddock later looks for instances, it also looks in these modules too.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- hsc_env <- getSession
- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- this_pkg = thisPackage (hsc_dflags hsc_env)
- !mods = mkModuleSet [ nameModule name
- | gre <- globalRdrEnvElts new_rdr_env
- , let name = gre_name gre
- , nameIsFromExternalPackage this_pkg name
- , isTcOcc (nameOccName name) -- Types and classes only
- , unQualOK gre ] -- In scope unqualified
-
- liftIO $ mapM_ putStrLn (nub msgs)
- dflags <- getDynFlags
- let (haddockable, haddocked) = ifaceHaddockCoverage interface
- percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
- modString = moduleString (ifaceMod interface)
- coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
- header = case ifaceDoc interface of
- Documentation Nothing _ -> False
- _ -> True
- undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
- , expItemMbDoc = (Documentation Nothing _, _)
- } <- ifaceExportItems interface ]
- where
- formatName :: SrcSpan -> HsDecl GhcRn -> String
- formatName loc n = p (getMainDeclBinder n) ++ case loc of
- RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
- _ -> ""
-
- p [] = ""
- p (x:_) = let n = pretty dflags x
- ms = modString ++ "."
- in if ms `isPrefixOf` n
- then drop (length ms) n
- else n
-
- when (OptHide `notElem` ifaceOptions interface) $ do
- out verbosity normal coverageMsg
- when (Flag_NoPrintMissingDocs `notElem` flags
- && not (null undocumentedExports && header)) $ do
- out verbosity normal " Missing documentation for:"
- unless header $ out verbosity normal " Module header"
- mapM_ (out verbosity normal . (" " ++)) undocumentedExports
- interface' <- liftIO $ evaluate interface
- return (Just (interface', mods))
- else
- return Nothing
+ case isBootSummary modsum of
+ IsBoot ->
+ return Nothing
+ NotBoot -> do
+ out verbosity verbose "Creating interface..."
+ (interface, msgs) <- {-# SCC createIterface #-}
+ withTimingD "createInterface" (const ()) $ do
+ runWriterGhc $ createInterface tm flags modMap instIfaceMap
+
+ -- We need to keep track of which modules were somehow in scope so that when
+ -- Haddock later looks for instances, it also looks in these modules too.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ hsc_env <- getSession
+ let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ !mods = mkModuleSet [ nameModule name
+ | gre <- globalRdrEnvElts new_rdr_env
+ , let name = gre_name gre
+ , nameIsFromExternalPackage this_pkg name
+ , isTcOcc (nameOccName name) -- Types and classes only
+ , unQualOK gre ] -- In scope unqualified
+
+ liftIO $ mapM_ putStrLn (nub msgs)
+ dflags <- getDynFlags
+ let (haddockable, haddocked) = ifaceHaddockCoverage interface
+ percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
+ modString = moduleString (ifaceMod interface)
+ coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
+ header = case ifaceDoc interface of
+ Documentation Nothing _ -> False
+ _ -> True
+ undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
+ , expItemMbDoc = (Documentation Nothing _, _)
+ } <- ifaceExportItems interface ]
+ where
+ formatName :: SrcSpan -> HsDecl GhcRn -> String
+ formatName loc n = p (getMainDeclBinder n) ++ case loc of
+ RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
+ _ -> ""
+
+ p [] = ""
+ p (x:_) = let n = pretty dflags x
+ ms = modString ++ "."
+ in if ms `isPrefixOf` n
+ then drop (length ms) n
+ else n
+
+ when (OptHide `notElem` ifaceOptions interface) $ do
+ out verbosity normal coverageMsg
+ when (Flag_NoPrintMissingDocs `notElem` flags
+ && not (null undocumentedExports && header)) $ do
+ out verbosity normal " Missing documentation for:"
+ unless header $ out verbosity normal " Module header"
+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports
+ interface' <- liftIO $ evaluate interface
+ return (Just (interface', mods))
--------------------------------------------------------------------------------