aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface.hs
blob: e493471111712f9b9954f36a3b9dfe32b6f67f7b (plain) (blame)
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
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-}
-----------------------------------------------------------------------------
-- |
-- 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 (
    plugin
  , processModules
) where


import Haddock.GhcUtils (moduleString, pretty)
import Haddock.Interface.AttachInstances (attachInstances)
import Haddock.Interface.Create (createInterface1, runIfM)
import Haddock.Interface.Rename (renameInterface)
import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv)
import Haddock.Options hiding (verbosity)
import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv,
                      expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage,
                      ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE)
import Haddock.Utils (Verbosity (..), normal, out, verbose)

import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef (atomicModifyIORef', newIORef, readIORef)
import Data.List (foldl', isPrefixOf, nub)
import Text.Printf (printf)
import qualified Data.Map as Map
import qualified Data.Set as Set

import GHC hiding (verbosity)
import GHC.Data.FastString (unpackFS)
import GHC.Data.Graph.Directed
import GHC.Driver.Env
import GHC.Driver.Monad (modifySession, withTimingM)
import GHC.Driver.Session hiding (verbosity)
import GHC.HsToCore.Docs (getMainDeclBinder)
import GHC.Plugins
import GHC.Tc.Types (TcGblEnv (..), TcM)
import GHC.Tc.Utils.Env (tcLookupGlobal)
import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
import GHC.Types.Name.Occurrence (isTcOcc)
import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK)
import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary)
import GHC.Unit.Types (IsBootInterface (..))
import GHC.Utils.Error (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 stdout $ mkLocaleEncoding TransliterateCodingFailure
  liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
#endif

  out verbosity verbose "Creating interfaces..."
  let
    instIfaceMap :: InstIfaceMap
    instIfaceMap = Map.fromList
      [ (instMod iface, iface)
      | ext <- extIfaces
      , iface <- ifInstalledIfaces ext
      ]

  (interfaces, ms) <- createIfaces 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 #-}
                 withTimingM "attachInstances" (const ()) $ do
                   attachInstances (exportedNames, mods) interfaces instIfaceMap ms

  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 (ignoredSymbols flags) links warnings) interfaces'
  liftIO $ mapM_ putStrLn msgs

  return (interfaces'', homeLinks)


--------------------------------------------------------------------------------
-- * Module typechecking and Interface creation
--------------------------------------------------------------------------------


createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces verbosity modules flags instIfaceMap = do
  (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin
    verbosity flags instIfaceMap

  let
    installHaddockPlugin :: HscEnv -> HscEnv
    installHaddockPlugin hsc_env =
      let 
        old_plugins = hsc_plugins hsc_env
        new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }
        hsc_env'    = hsc_env { hsc_plugins = new_plugins }
      in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env'

  -- Note that we would rather use withTempSession but as long as we
  -- have the separate attachInstances step we need to keep the session
  -- alive to be able to find all the instances.
  modifySession installHaddockPlugin

  targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules
  setTargets targets

  loadOk <- withTimingM "load" (const ()) $
    {-# SCC load #-} GHC.load LoadAllTargets

  case loadOk of
    Failed ->
      throwE "Cannot typecheck modules"
    Succeeded -> do
      modGraph <- GHC.getModuleGraph
      ifaceMap  <- liftIO getIfaces
      moduleSet <- liftIO getModules

      let
        -- We topologically sort the module graph including boot files,
        -- so it should be acylic (hopefully we failed much earlier if this is not the case)
        -- We then filter out boot modules from the resultant topological sort
        --
        -- We do it this way to make 'buildHomeLinks' a bit more stable
        -- 'buildHomeLinks' depends on the topological order of its input in order
        -- to construct its result. In particular, modules closer to the bottom of
        -- the dependency chain are to be prefered for link destinations.
        --
        -- If there are cycles in the graph, then this order is indeterminate
        -- (the nodes in the cycle can be ordered in any way).
        -- While 'topSortModuleGraph' does guarantee stability for equivalent
        -- module graphs, seemingly small changes in the ModuleGraph can have
        -- big impacts on the `LinkEnv` constructed.
        --
        -- For example, suppose
        --  G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
        --
        -- Then suppose C.hs is changed to have a cyclic dependency on A
        --
        --  G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
        --
        -- For G1, `C.hs` is preferred for link destinations. However, for G2,
        -- the topologically sorted order not taking into account boot files (so
        -- C -> A) is completely indeterminate.
        -- Using boot files to resolve cycles, we end up with the original order
        -- [C, B, A] (in decreasing order of preference for links)
        --
        -- This exact case came up in testing for the 'base' package, where there
        -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
        -- include 'Prelude' on non-windows platforms. This lead to drastically different
        -- LinkEnv's (and failing haddockHtmlTests) across the platforms
        --
        -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
        -- means that {-# SOURCE #-} imports no longer count towards re-ordering
        -- the preference of modules for linking.
        --
        -- i.e. if module A imports B, then B is preferred over A,
        -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
        --
        go (AcyclicSCC (ModuleNode ems))
          | NotBoot <- isBootSummary (emsModSummary ems) = [ems]
          | otherwise = []
        go (AcyclicSCC _) = []
        go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"

        ifaces :: [Interface]
        ifaces =
          [ Map.findWithDefault
              (error "haddock:iface")
              (ms_mod (emsModSummary ems))
              ifaceMap
          | ems <- concatMap go $ topSortModuleGraph False modGraph Nothing
          ]

      return (ifaces, moduleSet)


-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock
-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to
-- parallelize the compilation process.
plugin
  :: MonadIO m
  => Verbosity
  -> [Flag]
  -> InstIfaceMap
  -> m
     (
       StaticPlugin -- the plugin to install with GHC
     , m IfaceMap  -- get the processed interfaces
     , m ModuleSet -- get the loaded modules
     )
plugin verbosity flags instIfaceMap = liftIO $ do
  ifaceMapRef  <- newIORef Map.empty
  moduleSetRef <- newIORef emptyModuleSet

  let
    processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
    processTypeCheckedResult mod_summary tc_gbl_env
      -- Don't do anything for hs-boot modules
      | IsBoot <- isBootSummary mod_summary =
          pure ()
      | otherwise = do
          hsc_env <- getTopEnv
          ifaces <- liftIO $ readIORef ifaceMapRef
          (iface, modules) <- withTiming (hsc_logger hsc_env)
                                "processModule" (const ()) $
            processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env

          liftIO $ do
            atomicModifyIORef' ifaceMapRef $ \xs ->
              (Map.insert (ms_mod mod_summary) iface xs, ())

            atomicModifyIORef' moduleSetRef $ \xs ->
              (modules `unionModuleSet` xs, ())

    staticPlugin :: StaticPlugin
    staticPlugin = StaticPlugin
      {
        spPlugin = PluginWithArgs
        {
          paPlugin = defaultPlugin
          {
            renamedResultAction = keepRenamedSource
          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
              processTypeCheckedResult mod_summary tc_gbl_env
              pure tc_gbl_env

          }
        , paArguments = []
        }
      }

  pure
    ( staticPlugin
    , liftIO (readIORef ifaceMapRef)
    , liftIO (readIORef moduleSetRef)
    )


processModule1
  :: Verbosity
  -> [Flag]
  -> IfaceMap
  -> InstIfaceMap
  -> HscEnv
  -> ModSummary
  -> TcGblEnv
  -> TcM (Interface, ModuleSet)
processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do
  out verbosity verbose "Creating interface..."

  let
    TcGblEnv { tcg_rdr_env } = tc_gbl_env

    unit_state = hsc_units hsc_env

  (!interface, messages) <- do
    logger <- getLogger
    {-# SCC createInterface #-}
     withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
      createInterface1 flags unit_state mod_summary tc_gbl_env
        ifaces inst_ifaces

  -- 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.
  let
    mods :: ModuleSet
    !mods = mkModuleSet
      [ nameModule name
      | gre <- globalRdrEnvElts tcg_rdr_env
      , let name = greMangledName gre
      , nameIsFromExternalPackage (hsc_home_unit hsc_env) name
      , isTcOcc (nameOccName name)   -- Types and classes only
      , unQualOK gre -- In scope unqualified
      ]

  liftIO $ mapM_ putStrLn (nub messages)
  dflags <- getDynFlags

  let
    (haddockable, haddocked) =
      ifaceHaddockCoverage interface

    percentage :: Int
    percentage = div (haddocked * 100) haddockable

    modString :: String
    modString = moduleString (ifaceMod interface)

    coverageMsg :: String
    coverageMsg =
      printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString

    header :: Bool
    header = case ifaceDoc interface of
      Documentation Nothing _ -> False
      _ -> True

    undocumentedExports :: [String]
    undocumentedExports =
      [ formatName (locA 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 :: Outputable a => [a] -> String
          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

  pure (interface, mods)


--------------------------------------------------------------------------------
-- * 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