1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
{-# LANGUAGE CPP, OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2010,
-- Mateusz Kowalczyk 2013
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
--
-- This module typechecks Haskell modules using the GHC API and processes
-- the result to create 'Interface's. The typechecking and the 'Interface'
-- creation is interleaved, so that when a module is processed, the
-- 'Interface's of all previously processed modules are available. The
-- creation of an 'Interface' from a typechecked module is delegated to
-- "Haddock.Interface.Create".
--
-- When all modules have been typechecked and processed, information about
-- instances are attached to each 'Interface'. This task is delegated to
-- "Haddock.Interface.AttachInstances". Note that this is done as a separate
-- step because GHC can't know about all instances until all modules have been
-- typechecked.
--
-- As a last step a link environment is built which maps names to the \"best\"
-- places to link to in the documentation, and all 'Interface's are \"renamed\"
-- using this environment.
-----------------------------------------------------------------------------
module Haddock.Interface (
processModules
) where
import Haddock.GhcUtils
import Haddock.InterfaceFile
import Haddock.Interface.Create
import Haddock.Interface.AttachInstances
import Haddock.Interface.Rename
import Haddock.Options hiding (verbosity)
import Haddock.Types
import Haddock.Utils
import Control.Monad
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Verbosity
import System.Directory
import System.FilePath
import Text.Printf
import Digraph
import DynFlags hiding (verbosity)
import Exception
import GHC hiding (verbosity)
import HscTypes
import FastString (unpackFS)
import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
import RdrName (plusGlobalRdrEnv)
import ErrUtils (withTiming)
#if defined(mingw32_HOST_OS)
import System.IO
import GHC.IO.Encoding.CodePage (mkLocaleEncoding)
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
#endif
-- | Create 'Interface's and a link environment by typechecking the list of
-- modules using the GHC API and processing the resulting syntax trees.
processModules
:: Verbosity -- ^ Verbosity of logging to 'stdout'
-> [String] -- ^ A list of file or module names sorted by
-- module topology
-> [Flag] -- ^ Command-line flags
-> [InterfaceFile] -- ^ Interface files of package dependencies
-> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
-- environment
processModules verbosity modules flags extIfaces = do
#if defined(mingw32_HOST_OS)
-- Avoid internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows
liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
#endif
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
interfaces <- createIfaces0 verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
mods = Set.fromList $ map ifaceMod interfaces
out verbosity verbose "Attaching instances..."
interfaces' <- {-# SCC attachInstances #-}
withTiming getDynFlags "attachInstances" (const ()) $ do
attachInstances (exportedNames, mods) interfaces instIfaceMap
out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
let extLinks = Map.unions (map ifLinkEnv extIfaces)
homeLinks = buildHomeLinks interfaces' -- Build the environment for the home
-- package
links = homeLinks `Map.union` extLinks
out verbosity verbose "Renaming interfaces..."
let warnings = Flag_NoWarnings `notElem` flags
dflags <- getDynFlags
let (interfaces'', msgs) =
runWriter $ mapM (renameInterface dflags links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
--------------------------------------------------------------------------------
-- * Module typechecking and Interface creation
--------------------------------------------------------------------------------
createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createIfaces0 verbosity modules flags instIfaceMap =
-- Output dir needs to be set before calling depanal since depanal uses it to
-- compute output file names that are stored in the DynFlags of the
-- resulting ModSummaries.
(if useTempDir then withTempOutputDir else id) $ do
modGraph <- depAnalysis
createIfaces verbosity flags instIfaceMap modGraph
where
useTempDir :: Bool
useTempDir = Flag_NoTmpCompDir `notElem` flags
withTempOutputDir :: Ghc a -> Ghc a
withTempOutputDir action = do
tmp <- liftIO getTemporaryDirectory
x <- liftIO getProcessID
let dir = tmp </> ".haddock-" ++ show x
modifySessionDynFlags (setOutputDir dir)
withTempDir dir action
depAnalysis :: Ghc ModuleGraph
depAnalysis = do
targets <- mapM (\f -> guessTarget f Nothing) modules
setTargets targets
depanal [] False
createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
createIfaces verbosity flags instIfaceMap mods = do
let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
out verbosity normal "Haddock coverage:"
(ifaces, _) <- foldM f ([], Map.empty) sortedMods
return (reverse ifaces)
where
f (ifaces, ifaceMap) modSummary = do
x <- {-# SCC processModule #-}
withTiming getDynFlags "processModule" (const ()) $ do
processModule verbosity modSummary flags ifaceMap instIfaceMap
return $ case x of
Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
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
-- We need to modify the interactive context's environment so that when
-- Haddock later looks for instances, it also looks in the modules it
-- encountered while typechecking.
--
-- See https://github.com/haskell/haddock/issues/469.
hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession
let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
setSession hsc_env{ hsc_IC = old_IC {
ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env
} }
if not $ isBootSummary modsum then do
out verbosity verbose "Creating interface..."
(interface, msgs) <- {-# SCC createIterface #-}
withTiming getDynFlags "createInterface" (const ()) $ do
runWriterGhc $ createInterface tm flags modMap instIfaceMap
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')
else
return Nothing
--------------------------------------------------------------------------------
-- * Building of cross-linking environment
--------------------------------------------------------------------------------
-- | Build a mapping which for each original name, points to the "best"
-- place to link to in the documentation. For the definition of
-- "best", we use "the module nearest the bottom of the dependency
-- graph which exports this name", not including hidden modules. When
-- there are multiple choices, we pick a random one.
--
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
buildHomeLinks :: [Interface] -> LinkEnv
buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
where
upd old_env iface
| OptHide `elem` ifaceOptions iface = old_env
| OptNotHome `elem` ifaceOptions iface =
foldl' keep_old old_env exported_names
| otherwise = foldl' keep_new old_env exported_names
where
exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface)
mdl = ifaceMod iface
keep_old env n = Map.insertWith (\_ old -> old) n mdl env
keep_new env n = Map.insert n mdl env
--------------------------------------------------------------------------------
-- * Utils
--------------------------------------------------------------------------------
withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
(liftIO $ removeDirectoryRecursive dir)
|
