aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface.hs
blob: b9d409db7fee768ba19cea5a3b7f7c088dbbb4a0 (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
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface
-- Copyright   :  (c) Simon Marlow 2003-2006,
--                    David Waern  2006-2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Here we build the actual module interfaces. By interface we mean the
-- information that is used to render a Haddock page for a module. Parts of
-- this information are also stored in the .haddock files.
-----------------------------------------------------------------------------

module Haddock.Interface (
  createInterfaces
) where


import Haddock.Interface.Create
import Haddock.Interface.AttachInstances
import Haddock.Interface.Rename
import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.InterfaceFile

import qualified Data.Map as Map
import Data.List
import Data.Maybe
import Control.Monad
import Control.Exception ( evaluate )
import Distribution.Verbosity

import GHC hiding (verbosity, flags)
import Name
import Digraph
import HscTypes


-- | Turn a topologically sorted list of module names/filenames into interfaces. Also
-- return the home link environment created in the process.
#if __GLASGOW_HASKELL__ >= 609
createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile]
                 -> Ghc ([Interface], LinkEnv)
createInterfaces verbosity modules flags extIfaces = do
  -- part 1, create interfaces
  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
                                   , iface <- ifInstalledIfaces ext ]
  out verbosity verbose "Creating interfaces..."
  interfaces <- createInterfaces' verbosity modules flags instIfaceMap
#else
createInterfaces :: Verbosity -> Session -> [String] -> [Flag]
                 -> [InterfaceFile] -> IO ([Interface], LinkEnv)
createInterfaces verbosity session modules flags extIfaces = do
  -- part 1, create interfaces
  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
                                   , iface <- ifInstalledIfaces ext ]
  out verbosity verbose "Creating interfaces..."
  interfaces <- createInterfaces' verbosity session modules flags instIfaceMap
#endif
  -- part 2, build link environment
  out verbosity verbose "Building link 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
      allNames  = Map.keys links

  -- part 3, attach instances
  out verbosity verbose "Attaching instances..."
  let interfaces' = attachInstances interfaces allNames

  -- part 4, rename interfaces
  out verbosity verbose "Renaming interfaces..."
  let warnings = Flag_NoWarnings `notElem` flags
  let (interfaces'', msgs) = 
         runWriter $ mapM (renameInterface links warnings) interfaces'
  liftIO $ mapM_ putStrLn msgs

  return (interfaces'', homeLinks)  


#if __GLASGOW_HASKELL__ >= 609
createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
createInterfaces' verbosity modules flags instIfaceMap = do
  targets <- mapM (\f -> guessTarget f Nothing) modules
  setTargets targets
  modgraph <- depanal [] False

#if (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2) || __GLASGOW_HASKELL__ >= 611
  -- If template haskell is used by the package, we can not use
  -- HscNothing as target since we might need to run code generated from
  -- one or more of the modules during typechecking.
#if __GLASGOW_HASKELL__ < 611
  let needsTemplateHaskell = any (dopt Opt_TemplateHaskell . ms_hspp_opts)
#endif
  modgraph' <- if needsTemplateHaskell modgraph
       then do
         dflags <- getSessionDynFlags
         _ <- setSessionDynFlags dflags { hscTarget = HscAsm } 
         -- we need to set HscAsm on all the ModSummaries as well
         let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscAsm } }  
         return (map addHscAsm modgraph)
       else return modgraph
#else
  let modgraph' = modgraph
#endif

  let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing
  (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
    x <- processModule verbosity modsum flags modMap instIfaceMap
#else
createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
createInterfaces' verbosity session modules flags instIfaceMap = do
  targets <- mapM (\f -> guessTarget f Nothing) modules
  setTargets session targets
  mbGraph <- depanal session [] False
  modgraph <- case mbGraph of
    Just graph -> return graph
    Nothing -> throwE "Failed to create dependency graph"
  let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
  (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
    x <- processModule verbosity session modsum flags modMap instIfaceMap
#endif
    case x of
      Just interface ->
        return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
      Nothing -> return (ifaces, modMap)
    ) ([], Map.empty) orderedMods
  return (reverse ifaces)

{-    liftIO $ do
     putStrLn . ppModInfo $ ifaceInfo interface
     putStrLn . show $ fmap pretty (ifaceDoc interface)
     print (ifaceOptions interface)
     mapM (putStrLn . pretty . fst) (Map.elems . ifaceDeclMap $ interface)
     mapM (putStrLn . show . fmap pretty . snd) (Map.elems . ifaceDeclMap $ interface)
     mapM (putStrLn . ppExportItem) (ifaceExportItems interface)
     mapM (putStrLn . pretty) (ifaceLocals interface)
     mapM (putStrLn . pretty) (ifaceExports interface)
     mapM (putStrLn . pretty) (ifaceVisibleExports interface)
     mapM (putStrLn . pretty) (ifaceInstances interface)
     mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b)  (Map.toList $ ifaceSubMap interface)
     mapM (putStrLn . pretty) (ifaceInstances interface)-}

{-

ppInsts = concatMap ppInst 

ppInst (a,b,c) = concatMap pretty a ++ pretty b ++ concatMap pretty c 


ppExportItem (ExportDecl decl (Just doc) insts) = pretty decl ++ pretty doc ++ ppInsts insts
ppExportItem (ExportDecl decl Nothing insts) = pretty decl ++ ppInsts insts
ppExportItem (ExportNoDecl name name2 names) = pretty name ++ pretty name2 ++ pretty names
ppExportItem (ExportGroup level id doc) = show level ++ show id ++ pretty doc
ppExportItem (ExportDoc doc) = pretty doc
ppExportItem (ExportModule mod) = pretty mod


ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d 
-}

#if __GLASGOW_HASKELL__ >= 609
processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
processModule verbosity modsum flags modMap instIfaceMap = do
  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
  tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum
  if not $ isBootSummary modsum
    then do
      let filename = msHsFilePath modsum
      let dynflags = ms_hspp_opts modsum
      let Just renamed_src = renamedSource tc_mod
      let ghcMod = mkGhcModule (ms_mod modsum,
                            filename,
                            (parsedSource tc_mod,
                             renamed_src,
                             typecheckedSource tc_mod,
                             moduleInfo tc_mod))
                            dynflags
      out verbosity verbose "Creating interface..."
      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
      liftIO $ mapM_ putStrLn msg
      interface' <- liftIO $ evaluate interface
      return (Just interface')
    else
      return Nothing
#else
processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)
processModule verbosity session modsum flags modMap instIfaceMap = do
  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
  let filename = msHsFilePath modsum
  mbMod <- checkAndLoadModule session modsum False
  if not $ isBootSummary modsum
    then do
      ghcMod <- case mbMod of
        Just (CheckedModule a (Just b) (Just c) (Just d) _)
          -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
        _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
      mapM_ putStrLn msg
      return (Just interface)
    else
      return Nothing
#endif


type CheckedMod = (Module, FilePath, FullyCheckedMod)


type FullyCheckedMod = (ParsedSource, 
                        RenamedSource, 
                        TypecheckedSource, 
                        ModuleInfo)


-- | Dig out what we want from the typechecker output
mkGhcModule :: CheckedMod -> DynFlags -> GhcModule 
mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {
  ghcModule         = mdl,
  ghcFilename       = file,
  ghcMbDocOpts      = mbOpts,
  ghcHaddockModInfo = info,
  ghcMbDoc          = mbDoc,
  ghcGroup          = group_,
  ghcMbExports      = mbExports,
  ghcExportedNames  = modInfoExports modInfo,
  ghcDefinedNames   = map getName $ modInfoTyThings modInfo,
  ghcNamesInScope   = fromJust $ modInfoTopLevelScope modInfo, 
  ghcInstances      = modInfoInstances modInfo
}
  where
#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2
    HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed
#else
    mbOpts = haddockOptions dynflags
#endif
    (group_, _, mbExports, mbDoc, info) = renamed
    (_, renamed, _, modInfo) = checkedMod


-- | 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
        mdl            = ifaceMod iface
        keep_old env n = Map.insertWith (\_ old -> old) n mdl env
        keep_new env n = Map.insert n mdl env