ghc/compiler/rename/RnIfaces.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnIfaces]{Cacheing and Renaming of Interfaces}
   5
   6 \begin{code}
   7 module RnIfaces
   8      (
   9         recordLocalSlurps,
  10         mkImportInfo,
  11
  12         slurpImpDecls, closeDecls,
  13
  14         RecompileRequired, outOfDate, upToDate, recompileRequired
  15        )
  16 where
  17
  18 #include "HsVersions.h"
  19
  20 import CmdLineOpts      ( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
  21 import HscTypes
  22 import HsSyn            ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
  23                           InstDecl(..), HsType(..), hsTyVarNames, getBangType
  24                         )
  25 import HsImpExp         ( ImportDecl(..) )
  26 import RdrHsSyn         ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
  27 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl,
  28                           extractHsTyNames, extractHsCtxtTyNames,
  29                           tyClDeclFVs, ruleDeclFVs, instDeclFVs
  30                         )
  31 import RnHiFiles        ( tryLoadInterface, loadHomeInterface,
  32                           loadOrphanModules
  33                         )
  34 import RnSource         ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl )
  35 import RnEnv
  36 import RnMonad
  37 import Id               ( idType )
  38 import Type             ( namesOfType )
  39 import TyCon            ( isSynTyCon, getSynTyConDefn )
  40 import Name             ( Name {-instance NamedThing-}, nameOccName,
  41                           nameModule, isLocalName, nameUnique,
  42                           NamedThing(..)
  43                          )
  44 import Name             ( elemNameEnv, delFromNameEnv )
  45 import Module           ( Module, ModuleEnv,
  46                           moduleName, isHomeModule,
  47                           ModuleName, WhereFrom(..),
  48                           emptyModuleEnv,
  49                           extendModuleEnv_C, foldModuleEnv, lookupModuleEnv,
  50                           elemModuleSet, extendModuleSet
  51                         )
  52 import NameSet
  53 import PrelInfo         ( wiredInThingEnv, fractionalClassKeys )
  54 import TysWiredIn       ( doubleTyCon )
  55 import Maybes           ( orElse )
  56 import FiniteMap
  57 import Outputable
  58 import Bag
  59 import Util             ( sortLt )
  60 \end{code}
  61
  62
  63 %*********************************************************
  64 %*                                                      *
  65 \subsection{Keeping track of what we've slurped, and version numbers}
  66 %*                                                      *
  67 %*********************************************************
  68
  69 mkImportInof figures out what the ``usage information'' for this
  70 moudule is; that is, what it must record in its interface file as the
  71 things it uses.
  72
  73 We produce a line for every module B below the module, A, currently being
  74 compiled:
  75         import B <n> ;
  76 to record the fact that A does import B indireclty.  This is used to decide
  77 to look to look for B.hi rather than B.hi-boot when compiling a module that
  78 imports A.  This line says that A imports B, but uses nothing in it.
  79 So we'll get an early bale-out when compiling A if B's version changes.
  80
  81 \begin{code}
  82 mkImportInfo :: ModuleName                      -- Name of this module
  83              -> [ImportDecl n]                  -- The import decls
  84              -> RnMG [ImportVersion Name]
  85
  86 mkImportInfo this_mod imports
  87   = getIfacesRn                                 `thenRn` \ ifaces ->
  88     getHomeIfaceTableRn                         `thenRn` \ hit ->
  89     let
  90         (imp_pkg_mods, imp_home_names) = iVSlurp ifaces
  91         pit                            = iPIT    ifaces
  92
  93         import_all_mods :: [ModuleName]
  94                 -- Modules where we imported all the names
  95                 -- (apart from hiding some, perhaps)
  96         import_all_mods = [ m | ImportDecl m _ _ _ imp_list _ <- imports,
  97                                 import_all imp_list ]
  98                         where
  99                           import_all (Just (False, _)) = False  -- Imports are specified explicitly
 100                           import_all other             = True   -- Everything is imported
 101
 102         -- mv_map groups together all the things imported and used
 103         -- from a particular module in this package
 104         -- We use a finite map because we want the domain
 105         mv_map :: ModuleEnv [Name]
 106         mv_map  = foldNameSet add_mv emptyModuleEnv imp_home_names
 107         add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
 108                            where
 109                              mod = nameModule name
 110                              add_item names _ = name:names
 111
 112         -- In our usage list we record
 113         --      a) Specifically: Detailed version info for imports from modules in this package
 114         --                       Gotten from iVSlurp plus import_all_mods
 115         --
 116         --      b) Everything:   Just the module version for imports from modules in other packages
 117         --                       Gotten from iVSlurp plus import_all_mods
 118         --
 119         --      c) NothingAtAll: The name only of modules, Baz, in this package that are 'below' us,
 120         --                       but which we didn't need at all (this is needed only to decide whether
 121         --                       to open Baz.hi or Baz.hi-boot higher up the tree).
 122         --                       This happens when a module, Foo, that we explicitly imported has
 123         --                       'import Baz' in its interface file, recording that Baz is below
 124         --                       Foo in the module dependency hierarchy.  We want to propagate this info.
 125         --                       These modules are in a combination of HIT/PIT and iImpModInfo
 126         --
 127         --      d) NothingAtAll: The name only of all orphan modules we know of (this is needed
 128         --                       so that anyone who imports us can find the orphan modules)
 129         --                       These modules are in a combination of HIT/PIT and iImpModInfo
 130
 131         import_info0 = foldModuleEnv mk_imp_info  []           pit
 132         import_info1 = foldModuleEnv mk_imp_info  import_info0 hit
 133         import_info  = [ (mod_name, orphans, is_boot, NothingAtAll)
 134                        | (mod_name, (orphans, is_boot)) <- fmToList (iImpModInfo ifaces) ] ++
 135                        import_info1
 136
 137         mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name]
 138         mk_imp_info iface so_far
 139
 140           | Just ns <- lookupModuleEnv mv_map mod       -- Case (a)
 141           = go_for_it (Specifically mod_vers maybe_export_vers
 142                                     (mk_import_items ns) rules_vers)
 143
 144           | mod `elemModuleSet` imp_pkg_mods            -- Case (b)
 145           = go_for_it (Everything mod_vers)
 146
 147           | import_all_mod                              -- Case (a) and (b); the import-all part
 148           = if is_home_pkg_mod then
 149                 go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers)
 150             else
 151                 go_for_it (Everything mod_vers)
 152
 153           | is_home_pkg_mod || has_orphans              -- Case (c) or (d)
 154           = go_for_it NothingAtAll
 155
 156           | otherwise = so_far
 157           where
 158             go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far
 159
 160             mod             = mi_module iface
 161             mod_name        = moduleName mod
 162             is_home_pkg_mod = isHomeModule mod
 163             version_info    = mi_version iface
 164             version_env     = vers_decls   version_info
 165             mod_vers        = vers_module  version_info
 166             rules_vers      = vers_rules   version_info
 167             export_vers     = vers_exports version_info
 168             import_all_mod  = mod_name `elem` import_all_mods
 169             has_orphans     = mi_orphan iface
 170
 171                 -- The sort is to put them into canonical order
 172             mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns,
 173                                           let v = lookupNameEnv version_env n `orElse`
 174                                                   pprPanic "mk_whats_imported" (ppr n)
 175                                  ]
 176                          where
 177                            lt_occ n1 n2 = nameOccName n1 < nameOccName n2
 178
 179             maybe_export_vers | import_all_mod = Just (vers_exports version_info)
 180                               | otherwise      = Nothing
 181     in
 182     returnRn import_info
 183 \end{code}
 184
 185 %*********************************************************
 186 %*                                                       *
 187 \subsection{Slurping declarations}
 188 %*                                                       *
 189 %*********************************************************
 190
 191 \begin{code}
 192 -------------------------------------------------------
 193 slurpImpDecls source_fvs
 194   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
 195
 196         -- The current slurped-set records all local things
 197     slurpSourceRefs source_fvs  `thenRn` \ (decls, needed) ->
 198
 199         -- Then get everything else
 200     closeDecls decls needed
 201
 202
 203 -------------------------------------------------------
 204 slurpSourceRefs :: FreeVars                     -- Variables referenced in source
 205                 -> RnMG ([RenamedHsDecl],
 206                          FreeVars)              -- Un-satisfied needs
 207 -- The declaration (and hence home module) of each gate has
 208 -- already been loaded
 209
 210 slurpSourceRefs source_fvs
 211   = go_outer []                         -- Accumulating decls
 212              emptyFVs                   -- Unsatisfied needs
 213              emptyFVs                   -- Accumulating gates
 214              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
 215   where
 216         -- The outer loop repeatedly slurps the decls for the current gates
 217         -- and the instance decls
 218
 219         -- The outer loop is needed because consider
 220
 221     go_outer decls fvs all_gates []
 222         = returnRn (decls, fvs)
 223
 224     go_outer decls fvs all_gates refs   -- refs are not necessarily slurped yet
 225         = traceRn (text "go_outer" <+> ppr refs)                `thenRn_`
 226           foldlRn go_inner (decls, fvs, emptyFVs) refs          `thenRn` \ (decls1, fvs1, gates1) ->
 227           getImportedInstDecls (all_gates `plusFV` gates1)      `thenRn` \ inst_decls ->
 228           rnIfaceInstDecls decls1 fvs1 gates1 inst_decls        `thenRn` \ (decls2, fvs2, gates2) ->
 229           go_outer decls2 fvs2 (all_gates `plusFV` gates2)
 230                                (nameSetToList (gates2 `minusNameSet` all_gates))
 231                 -- Knock out the all_gates because even if we don't slurp any new
 232                 -- decls we can get some apparently-new gates from wired-in names
 233
 234     go_inner (decls, fvs, gates) wanted_name
 235         = importDecl wanted_name                `thenRn` \ import_result ->
 236           case import_result of
 237             AlreadySlurped     -> returnRn (decls, fvs, gates)
 238             InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing)
 239
 240             HereItIs decl -> rnIfaceTyClDecl decl               `thenRn` \ (new_decl, fvs1) ->
 241                              returnRn (TyClD new_decl : decls,
 242                                        fvs1 `plusFV` fvs,
 243                                        gates `plusFV` getGates source_fvs new_decl)
 244 \end{code}
 245
 246
 247 \begin{code}
 248 -------------------------------------------------------
 249 -- closeDecls keeps going until the free-var set is empty
 250 closeDecls decls needed
 251   | not (isEmptyFVs needed)
 252   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
 253     closeDecls decls1 needed1
 254
 255   | otherwise
 256   = getImportedRules                    `thenRn` \ rule_decls ->
 257     case rule_decls of
 258         []    -> returnRn decls -- No new rules, so we are done
 259         other -> rnIfaceDecls rnIfaceRuleDecl rule_decls        `thenRn` \ rule_decls' ->
 260                  let
 261                         rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
 262                  in
 263                  traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs)))     `thenRn_`
 264                  closeDecls (map RuleD rule_decls' ++ decls) rule_fvs
 265
 266
 267
 268 -------------------------------------------------------
 269 -- Augment decls with any decls needed by needed.
 270 -- Return also free vars of the new decls (only)
 271 slurpDecls decls needed
 272   = go decls emptyFVs (nameSetToList needed)
 273   where
 274     go decls fvs []         = returnRn (decls, fvs)
 275     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
 276                               go decls1 fvs1 refs
 277
 278 -------------------------------------------------------
 279 slurpDecl decls fvs wanted_name
 280   = importDecl wanted_name              `thenRn` \ import_result ->
 281     case import_result of
 282         -- Found a declaration... rename it
 283         HereItIs decl -> rnIfaceTyClDecl decl           `thenRn` \ (new_decl, fvs1) ->
 284                          returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
 285
 286         -- No declaration... (wired in thing, or deferred, or already slurped)
 287         other -> returnRn (decls, fvs)
 288
 289
 290 -------------------------------------------------------
 291 rnIfaceDecls rn decls      = mapRn (rnIfaceDecl rn) decls
 292 rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl)
 293
 294 rnIfaceInstDecls decls fvs gates inst_decls
 295   = rnIfaceDecls rnInstDecl inst_decls  `thenRn` \ inst_decls' ->
 296     returnRn (map InstD inst_decls' ++ decls,
 297               fvs `plusFV` plusFVs (map instDeclFVs inst_decls'),
 298               gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))
 299
 300 rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)       `thenRn` \ decl' ->
 301                               returnRn (decl', tyClDeclFVs decl')
 302 \end{code}
 303
 304
 305 \begin{code}
 306 recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
 307                              iSlurp = slurped_names,
 308                              iVSlurp = (imp_mods, imp_names) })
 309             avail
 310   = ASSERT2( not (isLocalName (availName avail)), ppr avail )
 311     ifaces { iDecls = (decls_map', n_slurped+1),
 312              iSlurp  = new_slurped_names,
 313              iVSlurp = new_vslurp }
 314   where
 315     decls_map' = foldl delFromNameEnv decls_map (availNames avail)
 316     main_name  = availName avail
 317     mod        = nameModule main_name
 318     new_slurped_names = addAvailToNameSet slurped_names avail
 319     new_vslurp | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name)
 320                | otherwise        = (extendModuleSet imp_mods mod, imp_names)
 321
 322 recordLocalSlurps new_names
 323   = getIfacesRn         `thenRn` \ ifaces ->
 324     setIfacesRn (ifaces { iSlurp  = iSlurp ifaces `unionNameSets` new_names })
 325 \end{code}
 326
 327
 328
 329 %*********************************************************
 330 %*                                                       *
 331 \subsection{Extracting the `gates'}
 332 %*                                                       *
 333 %*********************************************************
 334
 335 The gating story
 336 ~~~~~~~~~~~~~~~~~
 337 We want to avoid sucking in too many instance declarations.
 338 An instance decl is only useful if the types and classes mentioned in
 339 its 'head' are all available in the program being compiled.  E.g.
 340
 341         instance (..) => C (T1 a) (T2 b) where ...
 342
 343 is only useful if C, T1 and T2 are all "available".  So we keep
 344 instance decls that have been parsed from .hi files, but not yet
 345 slurped in, in a pool called the 'gated instance pool'.
 346 Each has its set of 'gates': {C, T1, T2} in the above example.
 347
 348 More precisely, the gates of a module are the types and classes
 349 that are mentioned in:
 350
 351         a) the source code
 352         b) the type of an Id that's mentioned in the source code
 353            [includes constructors and selectors]
 354         c) the RHS of a type synonym that is a gate
 355         d) the superclasses of a class that is a gate
 356         e) the context of an instance decl that is slurped in
 357
 358 We slurp in an instance decl from the gated instance pool iff
 359
 360         all its gates are either in the gates of the module,
 361         or are a previously-loaded class.
 362
 363 The latter constraint is because there might have been an instance
 364 decl slurped in during an earlier compilation, like this:
 365
 366         instance Foo a => Baz (Maybe a) where ...
 367
 368 In the module being compiled we might need (Baz (Maybe T)), where T
 369 is defined in this module, and hence we need (Foo T).  So @Foo@ becomes
 370 a gate.  But there's no way to 'see' that, so we simply treat all
 371 previously-loaded classes as gates.
 372
 373 Consructors and class operations
 374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 375 When we import a declaration like
 376
 377         data T = T1 Wibble | T2 Wobble
 378
 379 we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless}
 380 @T1@, @T2@ respectively are mentioned by the user program. If only
 381 @T@ is mentioned we want only @T@ to be a gate; that way we don't suck
 382 in useless instance decls for (say) @Eq Wibble@, when they can't
 383 possibly be useful.
 384
 385 And that's just what (b) says: we only treat T1's type as a gate if
 386 T1 is mentioned.  getGates, which deals with decls we are slurping in,
 387 has to be a bit careful, because a mention of T1 will slurp in T's whole
 388 declaration.
 389
 390 -----------------------------
 391 @getGates@ takes a newly imported (and renamed) decl, and the free
 392 vars of the source program, and extracts from the decl the gate names.
 393
 394 \begin{code}
 395 getGates :: FreeVars            -- Things mentioned in the source program
 396          -> RenamedTyClDecl
 397          -> FreeVars
 398
 399 getGates source_fvs decl
 400   = get_gates (\n -> n `elemNameSet` source_fvs) decl
 401
 402 get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
 403
 404 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
 405   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 406                         (hsTyVarNames tvs)
 407      `addOneToNameSet` cls)
 408     `plusFV` maybe_double
 409   where
 410     get (ClassOpSig n _ ty _)
 411         | is_used n = extractHsTyNames ty
 412         | otherwise = emptyFVs
 413
 414         -- If we load any numeric class that doesn't have
 415         -- Int as an instance, add Double to the gates.
 416         -- This takes account of the fact that Double might be needed for
 417         -- defaulting, but we don't want to load Double (and all its baggage)
 418         -- if the more exotic classes aren't used at all.
 419     maybe_double | nameUnique cls `elem` fractionalClassKeys
 420                  = unitFV (getName doubleTyCon)
 421                  | otherwise
 422                  = emptyFVs
 423
 424 get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty})
 425   = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
 426         -- A type synonym type constructor isn't a "gate" for instance decls
 427
 428 get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons})
 429   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
 430                        (hsTyVarNames tvs)
 431     `addOneToNameSet` tycon
 432   where
 433     get (ConDecl n _ tvs ctxt details _)
 434         | is_used n
 435                 -- If the constructor is method, get fvs from all its fields
 436         = delListFromNameSet (get_details details `plusFV`
 437                               extractHsCtxtTyNames ctxt)
 438                              (hsTyVarNames tvs)
 439     get (ConDecl n _ tvs ctxt (RecCon fields) _)
 440                 -- Even if the constructor isn't mentioned, the fields
 441                 -- might be, as selectors.  They can't mention existentially
 442                 -- bound tyvars (typechecker checks for that) so no need for
 443                 -- the deleteListFromNameSet part
 444         = foldr (plusFV . get_field) emptyFVs fields
 445
 446     get other_con = emptyFVs
 447
 448     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
 449     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
 450     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 451
 452     get_field (fs,t) | any is_used fs = get_bang t
 453                      | otherwise      = emptyFVs
 454
 455     get_bang bty = extractHsTyNames (getBangType bty)
 456 \end{code}
 457
 458 @getWiredInGates@ is just like @getGates@, but it sees a previously-loaded
 459 thing rather than a declaration.
 460
 461 \begin{code}
 462 getWiredInGates :: TyThing -> FreeVars
 463 -- The TyThing is one that we already have in our type environment, either
 464 --      a) because the TyCon or Id is wired in, or
 465 --      b) from a previous compile
 466 -- Either way, we might have instance decls in the (persistent) collection
 467 -- of parsed-but-not-slurped instance decls that should be slurped in.
 468 -- This might be the first module that mentions both the type and the class
 469 -- for that instance decl, even though both the type and the class were
 470 -- mentioned in other modules, and hence are in the type environment
 471
 472 getWiredInGates (AnId the_id) = namesOfType (idType the_id)
 473 getWiredInGates (AClass cl)   = emptyFVs        -- The superclasses must also be previously
 474                                                 -- loaded, and hence are automatically gates
 475 getWiredInGates (ATyCon tc)
 476   | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars)
 477   | otherwise     = unitFV (getName tc)
 478   where
 479     (tyvars,ty)  = getSynTyConDefn tc
 480
 481 getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty
 482 \end{code}
 483
 484 \begin{code}
 485 getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)]
 486 getImportedInstDecls gates
 487   =     -- First, load any orphan-instance modules that aren't aready loaded
 488         -- Orphan-instance modules are recorded in the module dependecnies
 489     getIfacesRn                                         `thenRn` \ ifaces ->
 490     let
 491         orphan_mods =
 492           [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
 493     in
 494     loadOrphanModules orphan_mods                       `thenRn_`
 495
 496         -- Now we're ready to grab the instance declarations
 497         -- Find the un-gated ones and return them,
 498         -- removing them from the bag kept in Ifaces
 499     getIfacesRn                                         `thenRn` \ ifaces ->
 500     getTypeEnvRn                                        `thenRn` \ lookup ->
 501     let
 502         (decls, new_insts) = selectGated gates lookup (iInsts ifaces)
 503     in
 504     setIfacesRn (ifaces { iInsts = new_insts })         `thenRn_`
 505
 506     traceRn (sep [text "getImportedInstDecls:",
 507                   nest 4 (fsep (map ppr gate_list)),
 508                   text "Slurped" <+> int (length decls) <+> text "instance declarations",
 509                   nest 4 (vcat (map ppr_brief_inst_decl decls))])       `thenRn_`
 510     returnRn decls
 511   where
 512     gate_list      = nameSetToList gates
 513
 514 ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _)
 515   = case inst_ty of
 516         HsForAllTy _ _ tau -> ppr tau
 517         other              -> ppr inst_ty
 518
 519 getImportedRules :: RnMG [(Module,RdrNameRuleDecl)]
 520 getImportedRules
 521   | opt_IgnoreIfacePragmas = returnRn []
 522   | otherwise
 523   = getIfacesRn         `thenRn` \ ifaces ->
 524     getTypeEnvRn        `thenRn` \ lookup ->
 525     let
 526         gates              = iSlurp ifaces      -- Anything at all that's been slurped
 527         rules              = iRules ifaces
 528         (decls, new_rules) = selectGated gates lookup rules
 529     in
 530     if null decls then
 531         returnRn []
 532     else
 533     setIfacesRn (ifaces { iRules = new_rules })              `thenRn_`
 534     traceRn (sep [text "getImportedRules:",
 535                   text "Slurped" <+> int (length decls) <+> text "rules"])   `thenRn_`
 536     returnRn decls
 537
 538 selectGated gates lookup (decl_bag, n_slurped)
 539         -- Select only those decls whose gates are *all* in 'gates'
 540         -- or are a class in 'lookup'
 541 #ifdef DEBUG
 542   | opt_NoPruneDecls    -- Just to try the effect of not gating at all
 543   = let
 544         decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag       -- Grab them all
 545     in
 546     (decls, (emptyBag, n_slurped + length decls))
 547
 548   | otherwise
 549 #endif
 550   = case foldrBag select ([], emptyBag) decl_bag of
 551         (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
 552   where
 553     available n = n `elemNameSet` gates
 554                 || case lookup n of { Just (AClass c) -> True; other -> False }
 555
 556     select (reqd, decl) (yes, no)
 557         | all available reqd = (decl:yes, no)
 558         | otherwise          = (yes,      (reqd,decl) `consBag` no)
 559 \end{code}
 560
 561
 562 %*********************************************************
 563 %*                                                      *
 564 \subsection{Getting in a declaration}
 565 %*                                                      *
 566 %*********************************************************
 567
 568 \begin{code}
 569 importDecl :: Name -> RnMG ImportDeclResult
 570
 571 data ImportDeclResult
 572   = AlreadySlurped
 573   | InTypeEnv TyThing
 574   | HereItIs (Module, RdrNameTyClDecl)
 575
 576 importDecl name
 577   =     -- STEP 1: Check if we've slurped it in while compiling this module
 578     getIfacesRn                         `thenRn` \ ifaces ->
 579     if name `elemNameSet` iSlurp ifaces then
 580         returnRn AlreadySlurped
 581     else
 582
 583         -- STEP 2: Check if it's already in the type environment
 584     getTypeEnvRn                        `thenRn` \ lookup ->
 585     case lookup name of {
 586         Just ty_thing | name `elemNameEnv` wiredInThingEnv
 587                       ->        -- When we find a wired-in name we must load its home
 588                                 -- module so that we find any instance decls lurking therein
 589                          loadHomeInterface wi_doc name  `thenRn_`
 590                          returnRn (InTypeEnv ty_thing)
 591
 592                       | otherwise
 593                       -> returnRn (InTypeEnv ty_thing) ;
 594
 595         Nothing ->
 596
 597         -- STEP 3: OK, we have to slurp it in from an interface file
 598         --         First load the interface file
 599     traceRn nd_doc                      `thenRn_`
 600     loadHomeInterface nd_doc name       `thenRn_`
 601     getIfacesRn                         `thenRn` \ ifaces ->
 602
 603         -- STEP 4: Get the declaration out
 604     let
 605         (decls_map, _) = iDecls ifaces
 606     in
 607     case lookupNameEnv decls_map name of
 608       Just (avail,_,decl)
 609         -> setIfacesRn (recordSlurp ifaces avail)       `thenRn_`
 610            returnRn (HereItIs decl)
 611
 612       Nothing
 613         -> addErrRn (getDeclErr name)   `thenRn_`
 614            returnRn AlreadySlurped
 615     }
 616   where
 617     wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
 618     nd_doc = ptext SLIT("need decl for") <+> ppr name
 619
 620 \end{code}
 621
 622
 623 %********************************************************
 624 %*                                                      *
 625 \subsection{Checking usage information}
 626 %*                                                      *
 627 %********************************************************
 628
 629 @recompileRequired@ is called from the HscMain.   It checks whether
 630 a recompilation is required.  It needs access to the persistent state,
 631 finder, etc, because it may have to load lots of interface files to
 632 check their versions.
 633
 634 \begin{code}
 635 type RecompileRequired = Bool
 636 upToDate  = False       -- Recompile not required
 637 outOfDate = True        -- Recompile required
 638
 639 recompileRequired :: FilePath           -- Only needed for debug msgs
 640                   -> ModIface           -- Old interface
 641                   -> RnMG RecompileRequired
 642 recompileRequired iface_path iface
 643   = traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon)        `thenRn_`
 644
 645         -- Source code unchanged and no errors yet... carry on
 646     checkList [checkModUsage u | u <- mi_usages iface]
 647
 648 checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
 649 checkList []             = returnRn upToDate
 650 checkList (check:checks) = check        `thenRn` \ recompile ->
 651                            if recompile then
 652                                 returnRn outOfDate
 653                            else
 654                                 checkList checks
 655 \end{code}
 656
 657 \begin{code}
 658 checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
 659 -- Given the usage information extracted from the old
 660 -- M.hi file for the module being compiled, figure out
 661 -- whether M needs to be recompiled.
 662
 663 checkModUsage (mod_name, _, _, NothingAtAll)
 664         -- If CurrentModule.hi contains
 665         --      import Foo :: ;
 666         -- then that simply records that Foo lies below CurrentModule in the
 667         -- hierarchy, but CurrentModule doesn't depend in any way on Foo.
 668         -- In this case we don't even want to open Foo's interface.
 669   = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)
 670
 671 checkModUsage (mod_name, _, is_boot, whats_imported)
 672   =     -- Load the imported interface is possible
 673         -- We use tryLoadInterface, because failure is not an error
 674         -- (might just be that the old .hi file for this module is out of date)
 675         -- We use ImportByUser/ImportByUserSource as the 'from' flag,
 676         --      a) because we need to know whether to load the .hi-boot file
 677         --      b) because loadInterface things matters are amiss if we
 678         --         ImportBySystem an interface it knows nothing about
 679     let
 680         doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
 681         from    | is_boot   = ImportByUserSource
 682                 | otherwise = ImportByUser
 683     in
 684     tryLoadInterface doc_str mod_name from      `thenRn` \ (iface, maybe_err) ->
 685
 686     case maybe_err of {
 687         Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
 688                                       ppr mod_name]) ;
 689                 -- Couldn't find or parse a module mentioned in the
 690                 -- old interface file.  Don't complain -- it might just be that
 691                 -- the current module doesn't need that import and it's been deleted
 692
 693         Nothing ->
 694     let
 695         new_vers      = mi_version iface
 696         new_decl_vers = vers_decls new_vers
 697     in
 698     case whats_imported of {    -- NothingAtAll dealt with earlier
 699
 700       Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers       `thenRn` \ recompile ->
 701                                  if recompile then
 702                                         out_of_date (ptext SLIT("...and I needed the whole module"))
 703                                  else
 704                                         returnRn upToDate ;
 705
 706       Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers ->
 707
 708         -- CHECK MODULE
 709     checkModuleVersion old_mod_vers new_vers    `thenRn` \ recompile ->
 710     if not recompile then
 711         returnRn upToDate
 712     else
 713
 714         -- CHECK EXPORT LIST
 715     if checkExportList maybe_old_export_vers new_vers then
 716         out_of_date (ptext SLIT("Export list changed"))
 717     else
 718
 719         -- CHECK RULES
 720     if old_rule_vers /= vers_rules new_vers then
 721         out_of_date (ptext SLIT("Rules changed"))
 722     else
 723
 724         -- CHECK ITEMS ONE BY ONE
 725     checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers]   `thenRn` \ recompile ->
 726     if recompile then
 727         returnRn outOfDate      -- This one failed, so just bail out now
 728     else
 729         up_to_date (ptext SLIT("...but the bits I use haven't."))
 730
 731     }}
 732
 733 ------------------------
 734 checkModuleVersion old_mod_vers new_vers
 735   | vers_module new_vers == old_mod_vers
 736   = up_to_date (ptext SLIT("Module version unchanged"))
 737
 738   | otherwise
 739   = out_of_date (ptext SLIT("Module version has changed"))
 740
 741 ------------------------
 742 checkExportList Nothing  new_vers = upToDate
 743 checkExportList (Just v) new_vers = v /= vers_exports new_vers
 744
 745 ------------------------
 746 checkEntityUsage new_vers (name,old_vers)
 747   = case lookupNameEnv new_vers name of
 748
 749         Nothing       ->        -- We used it before, but it ain't there now
 750                           out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
 751
 752         Just new_vers   -- It's there, but is it up to date?
 753           | new_vers == old_vers -> returnRn upToDate
 754           | otherwise            -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
 755
 756 up_to_date  msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
 757 out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate
 758 \end{code}
 759
 760
 761 %*********************************************************
 762 %*                                                       *
 763 \subsection{Errors}
 764 %*                                                       *
 765 %*********************************************************
 766
 767 \begin{code}
 768 getDeclErr name
 769   = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
 770           ptext SLIT("from module") <+> quotes (ppr (nameModule name))
 771          ]
 772 \end{code}