ghc/compiler/rename/RnIfaces.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 section
   4 \%[RnIfaces]{Cacheing and Renaming of Interfaces}
   5
   6 \begin{code}
   7 module RnIfaces
   8      (  slurpImpDecls, importSupportingDecls,
   9         RecompileRequired, outOfDate, upToDate, checkVersions
  10        )
  11 where
  12
  13 #include "HsVersions.h"
  14
  15 import CmdLineOpts      ( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
  16 import HscTypes
  17 import HsSyn            ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..),
  18                           InstDecl(..), HsType(..), hsTyVarNames, getBangType
  19                         )
  20 import RdrHsSyn         ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
  21 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl,
  22                           extractHsTyNames, extractHsCtxtTyNames,
  23                           tyClDeclFVs, ruleDeclFVs, impDeclFVs
  24                         )
  25 import RnHiFiles        ( loadInterface, loadHomeInterface, loadOrphanModules )
  26 import RnNames          ( mkModDeps )
  27 import RnSource         ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl )
  28 import TcEnv            ( getInGlobalScope, tcLookupGlobal_maybe )
  29 import TcRnMonad
  30 import Id               ( idType, idName, globalIdDetails )
  31 import IdInfo           ( GlobalIdDetails(..) )
  32 import TcType           ( tyClsNamesOfType, classNamesOfTheta )
  33 import FieldLabel       ( fieldLabelTyCon )
  34 import DataCon          ( dataConTyCon )
  35 import TyCon            ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
  36 import Class            ( className, classSCTheta )
  37 import Name             ( Name {-instance NamedThing-}, isWiredInName, isInternalName, nameModule, NamedThing(..)
  38                          )
  39 import NameEnv          ( delFromNameEnv, lookupNameEnv )
  40 import NameSet
  41 import Module           ( Module, isHomeModule )
  42 import PrelNames        ( hasKey, fractionalClassKey, numClassKey,
  43                           integerTyConName, doubleTyConName )
  44 import FiniteMap
  45 import Outputable
  46 import Bag
  47 import Maybe( fromJust )
  48 \end{code}
  49
  50
  51 %*********************************************************
  52 %*                                                       *
  53 \subsection{Slurping declarations}
  54 %*                                                       *
  55 %*********************************************************
  56
  57 \begin{code}
  58 -------------------------------------------------------
  59 slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl]
  60 slurpImpDecls source_fvs
  61   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_`
  62
  63         -- Slurp in things which might be 'gates' for instance
  64         -- declarations, plus the instance declarations themselves
  65     slurpSourceRefs source_fvs                          `thenM` \ (gate_decls, bndrs) ->
  66
  67         -- Then get everything else
  68     let
  69         needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls
  70     in
  71     import_supporting_decls (gate_decls, bndrs) needed
  72
  73
  74 -------------------------------------------------------
  75 slurpSourceRefs :: FreeVars                     -- Variables referenced in source
  76                 -> TcRn m ([RenamedHsDecl],     -- Needed declarations
  77                          NameSet)               -- Names bound by those declarations
  78 -- Slurp imported declarations needed directly by the source code;
  79 -- and some of the ones they need.  The goal is to find all the 'gates'
  80 -- for instance declarations.
  81
  82 slurpSourceRefs source_fvs
  83   = go_outer [] emptyFVs                -- Accumulating decls
  84              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
  85   where
  86         -- The outer loop repeatedly slurps the decls for the current gates
  87         -- and the instance decls
  88
  89         -- The outer loop is needed because consider
  90         --      instance Foo a => Baz (Maybe a) where ...
  91         -- It may be that Baz and Maybe are used in the source module,
  92         -- but not Foo; so we need to chase Foo too.
  93         --
  94         -- We also need to follow superclass refs.  In particular, 'chasing Foo' must
  95         -- include actually getting in Foo's class decl
  96         --      class Wib a => Foo a where ..
  97         -- so that its superclasses are discovered.  The point is that Wib is a gate too.
  98         -- We do this for tycons too, so that we look through type synonyms.
  99
 100     go_outer decls bndrs [] = returnM (decls, bndrs)
 101
 102     go_outer decls bndrs refs           -- 'refs' are not necessarily slurped yet
 103         = traceRn (text "go_outer" <+> ppr refs)        `thenM_`
 104           foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) ->
 105           getImportedInstDecls gates1                   `thenM` \ (inst_decls, new_gates) ->
 106           rnIfaceDecls rnInstDecl inst_decls            `thenM` \ inst_decls' ->
 107           go_outer (map InstD inst_decls' ++ decls1)
 108                    bndrs1
 109                    (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls')))
 110                 -- NB: we go round again to fetch the decls for any gates of any decls
 111                 --     we have loaded.  For example, if we mention
 112                 --              print :: Show a => a -> String
 113                 --     then we must load the decl for Show before stopping, to ensure
 114                 --     that instances from its home module are available
 115
 116     go_inner (decls, bndrs, gates) wanted_name
 117         = importDecl bndrs wanted_name          `thenM` \ import_result ->
 118           case import_result of
 119             AlreadySlurped -> returnM (decls, bndrs, gates)
 120
 121             InTypeEnv ty_thing
 122                 -> returnM (decls,
 123                             bndrs `addOneFV` wanted_name,       -- Avoid repeated calls to getWiredInGates
 124                             gates `plusFV` getWiredInGates ty_thing)
 125
 126             HereItIs decl new_bndrs
 127                 -> rnIfaceDecl rnTyClDecl decl          `thenM` \ new_decl ->
 128                    returnM (TyClD new_decl : decls,
 129                             bndrs `plusFV` new_bndrs,
 130                             gates `plusFV` getGates source_fvs new_decl)
 131 \end{code}
 132
 133 \begin{code}
 134 -------------------------------------------------------
 135 -- import_supporting_decls keeps going until the free-var set is empty
 136 importSupportingDecls needed
 137  = import_supporting_decls ([], emptyNameSet) needed
 138
 139 import_supporting_decls
 140         :: ([RenamedHsDecl], NameSet)   -- Some imported decls, with their binders
 141         -> FreeVars                     -- Remaining un-slurped names
 142         -> TcRn m [RenamedHsDecl]
 143 import_supporting_decls decls needed
 144   = slurpIfaceDecls decls needed        `thenM` \ (decls1, bndrs1) ->
 145     getImportedRules bndrs1             `thenM` \ rule_decls ->
 146     case rule_decls of
 147         []    -> returnM decls1 -- No new rules, so we are done
 148         other -> rnIfaceDecls rnIfaceRuleDecl rule_decls        `thenM` \ rule_decls' ->
 149                  let
 150                     rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
 151                     decls2   = decls1 ++ map RuleD rule_decls'
 152                  in
 153                  traceRn (text "closeRules" <+> ppr rule_decls' $$
 154                           fsep (map ppr (nameSetToList rule_fvs)))      `thenM_`
 155                  import_supporting_decls (decls2, bndrs1) rule_fvs
 156
 157
 158 -------------------------------------------------------
 159 -- Augment decls with any decls needed by needed,
 160 -- and so on transitively
 161 slurpIfaceDecls :: ([RenamedHsDecl], NameSet)   -- Already slurped
 162                 -> FreeVars                     -- Still needed
 163                 -> TcRn m ([RenamedHsDecl], NameSet)
 164 slurpIfaceDecls (decls, bndrs) needed
 165   = slurp decls bndrs (nameSetToList needed)
 166   where
 167     slurp decls bndrs [] = returnM (decls, bndrs)
 168     slurp decls bndrs (n:ns)
 169       = importDecl bndrs n              `thenM` \ import_result ->
 170         case import_result of
 171           HereItIs decl new_bndrs       -- Found a declaration... rename it
 172             ->  rnIfaceDecl rnTyClDecl decl     `thenM` \ new_decl ->
 173                 slurp (TyClD new_decl : decls)
 174                       (bndrs `plusFV` new_bndrs)
 175                       (nameSetToList (tyClDeclFVs new_decl) ++ ns)
 176
 177
 178           other ->      -- No declaration... (wired in thing, or deferred,
 179                         --                    or already slurped)
 180                 slurp decls (bndrs `addOneFV` n) ns
 181
 182 -------------------------------------------------------
 183 rnIfaceDecls rn decls      = mappM (rnIfaceDecl rn) decls
 184 rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl)
 185 \end{code}
 186
 187
 188 \begin{code}
 189         -- Tiresomely, we must get the "main" name for the
 190         -- thing, because that's what VSlurp contains, and what
 191         -- is recorded in the usage information
 192 get_main_name (AClass cl) = className cl
 193 get_main_name (ATyCon tc)
 194   | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
 195   | otherwise                        = tyConName tc
 196 get_main_name (AnId id)
 197   = case globalIdDetails id of
 198         DataConId     dc -> get_main_name (ATyCon (dataConTyCon dc))
 199         DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
 200         RecordSelId lbl  -> get_main_name (ATyCon (fieldLabelTyCon lbl))
 201         other            -> idName id
 202
 203
 204 recordUsage :: Name -> TcRn m ()
 205 -- Record that the Name has been used, for
 206 -- later generation of usage info in the interface file
 207 recordUsage name = updUsages (upd_usg name)
 208
 209 upd_usg name usages
 210   | isHomeModule mod = addOneToNameSet usages name
 211   | otherwise        = usages
 212   where
 213     mod = nameModule name
 214 \end{code}
 215
 216
 217 %*********************************************************
 218 %*                                                      *
 219 \subsection{Getting in a declaration}
 220 %*                                                      *
 221 %*********************************************************
 222
 223 \begin{code}
 224 importDecl :: NameSet -> Name -> TcRn m ImportDeclResult
 225
 226 data ImportDeclResult
 227   = AlreadySlurped
 228   | InTypeEnv TyThing
 229   | HereItIs (Module, RdrNameTyClDecl) NameSet
 230         -- The NameSet is the bunch of names bound by this decl
 231
 232 importDecl already_slurped name
 233   =     -- STEP 0: Check if it's from this module
 234         -- Doing this catches a common case quickly
 235     getModule                           `thenM` \ this_mod ->
 236     if isInternalName name || nameModule name == this_mod then
 237         -- Variables defined on the GHCi command line (e.g. let x = 3)
 238         -- are Internal names (which don't have a Module)
 239         returnM AlreadySlurped
 240     else
 241
 242         -- STEP 1: Check if we've slurped it in while compiling this module
 243     if name `elemNameSet` already_slurped then
 244         returnM AlreadySlurped
 245     else
 246
 247         -- STEP 2: Check if it's already in the type environment
 248     tcLookupGlobal_maybe name           `thenM` \ maybe_thing ->
 249     case maybe_thing of {
 250
 251       Just ty_thing
 252         | isWiredInName name
 253         ->  -- When we find a wired-in name we must load its home
 254             -- module so that we find any instance decls lurking therein
 255             loadHomeInterface wi_doc name       `thenM_`
 256             returnM (InTypeEnv ty_thing)
 257
 258         | otherwise
 259         ->  -- We have slurp something that's already in the type environment,
 260             -- that was not slurped in an earlier compilation.
 261             -- Must still record it in the Usages info, because that's used to
 262             -- generate usage information
 263
 264             traceRn (text "not wired in" <+> ppr name)  `thenM_`
 265             recordUsage (get_main_name ty_thing)        `thenM_`
 266             returnM (InTypeEnv ty_thing) ;
 267
 268         Nothing ->
 269
 270         -- STEP 4: OK, we have to slurp it in from an interface file
 271         --         First load the interface file
 272     traceRn nd_doc                      `thenM_`
 273     loadHomeInterface nd_doc name       `thenM_`
 274
 275         -- STEP 4: Get the declaration out
 276     getEps                              `thenM` \ eps ->
 277     let
 278         (decls_map, n_slurped) = eps_decls eps
 279     in
 280     case lookupNameEnv decls_map name of
 281       Just (avail,_,decl) -> setEps eps'                        `thenM_`
 282                              recordUsage (availName avail)      `thenM_`
 283                              returnM (HereItIs decl (mkFVs avail_names))
 284         where
 285            avail_names   = availNames avail
 286            new_decls_map = foldl delFromNameEnv decls_map avail_names
 287            eps'          = eps { eps_decls = (new_decls_map, n_slurped+1) }
 288
 289       Nothing -> addErr (getDeclErr name)       `thenM_`
 290                  returnM AlreadySlurped
 291     }
 292   where
 293     wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
 294     nd_doc = ptext SLIT("need decl for") <+> ppr name
 295
 296 \end{code}
 297
 298
 299 %*********************************************************
 300 %*                                                       *
 301 \subsection{Extracting the `gates'}
 302 %*                                                       *
 303 %*********************************************************
 304
 305 The gating story
 306 ~~~~~~~~~~~~~~~~~
 307 We want to avoid sucking in too many instance declarations.
 308 An instance decl is only useful if the types and classes mentioned in
 309 its 'head' are all available in the program being compiled.  E.g.
 310
 311         instance (..) => C (T1 a) (T2 b) where ...
 312
 313 is only useful if C, T1 and T2 are all "available".  So we keep
 314 instance decls that have been parsed from .hi files, but not yet
 315 slurped in, in a pool called the 'gated instance pool'.
 316 Each has its set of 'gates': {C, T1, T2} in the above example.
 317
 318 More precisely, the gates of a module are the types and classes
 319 that are mentioned in:
 320
 321         a) the source code      [Note: in fact these don't seem
 322                                 to be treated as gates, perhaps
 323                                 because no imported instance decl
 324                                 can mention them; mutter mutter
 325                                 recursive modules.]
 326         b) the type of an Id that's mentioned in the source code
 327            [includes constructors and selectors]
 328         c) the RHS of a type synonym that is a gate
 329         d) the superclasses of a class that is a gate
 330         e) the context of an instance decl that is slurped in
 331
 332 We slurp in an instance decl from the gated instance pool iff
 333
 334         all its gates are either in the gates of the module,
 335         or the gates of a previously-loaded module
 336
 337 The latter constraint is because there might have been an instance
 338 decl slurped in during an earlier compilation, like this:
 339
 340         instance Foo a => Baz (Maybe a) where ...
 341
 342 In the module being compiled we might need (Baz (Maybe T)), where T is
 343 defined in this module, and hence we need the instance for (Foo T).
 344 So @Foo@ becomes a gate.  But there's no way to 'see' that.  More
 345 generally, types might be involved as well:
 346
 347         instance Foo2 S a => Baz2 a where ...
 348
 349 Now we must treat S as a gate too, as well as Foo2.  So the solution
 350 we adopt is:
 351
 352         we simply treat the gates of all previously-loaded
 353         modules as gates of this one
 354
 355 So the gates are remembered across invocations of the renamer in the
 356 PersistentRenamerState.  This gloss mainly affects ghc --make and ghc
 357 --interactive.
 358
 359 (We used to use the persistent type environment for this purpose,
 360 but it has too much.  For a start, it contains all tuple types,
 361 because they are in the wired-in type env!)
 362
 363
 364 Consructors and class operations
 365 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 366 When we import a declaration like
 367
 368         data T = T1 Wibble | T2 Wobble
 369
 370 we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless}
 371 @T1@, @T2@ respectively are mentioned by the user program. If only
 372 @T@ is mentioned we want only @T@ to be a gate; that way we don't suck
 373 in useless instance decls for (say) @Eq Wibble@, when they can't
 374 possibly be useful.
 375
 376 And that's just what (b) says: we only treat T1's type as a gate if
 377 T1 is mentioned.  getGates, which deals with decls we are slurping in,
 378 has to be a bit careful, because a mention of T1 will slurp in T's whole
 379 declaration.
 380
 381 -----------------------------
 382 @getGates@ takes a newly imported (and renamed) decl, and the free
 383 vars of the source program, and extracts from the decl the gate names.
 384
 385 \begin{code}
 386 getGates :: FreeVars            -- Things mentioned in the source program
 387                                 -- Used for the cunning "constructors and
 388                                 -- class ops" story described 10 lines above.
 389          -> RenamedTyClDecl
 390          -> FreeVars
 391
 392 getGates source_fvs decl
 393   = get_gates (\n -> n `elemNameSet` source_fvs) decl
 394
 395 get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
 396 get_gates is_used (IfaceSig    {tcdType = ty})    = extractHsTyNames ty
 397
 398 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
 399   = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`
 400     implicitClassGates cls
 401   where
 402     super_cls_and_sigs = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 403                                             (hsTyVarNames tvs)
 404     get (ClassOpSig n _ ty _)
 405         | is_used n = extractHsTyNames ty
 406         | otherwise = emptyFVs
 407
 408 get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty})
 409   = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
 410         -- A type synonym type constructor isn't a "gate" for instance decls
 411
 412 get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons})
 413   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt)
 414                                              (visibleDataCons cons))
 415                        (hsTyVarNames tvs)
 416     `addOneToNameSet` tycon
 417   where
 418     get (ConDecl n tvs ctxt details _)
 419         | is_used n
 420                 -- If the constructor is method, get fvs from all its fields
 421         = delListFromNameSet (get_details details `plusFV`
 422                               extractHsCtxtTyNames ctxt)
 423                              (hsTyVarNames tvs)
 424     get (ConDecl n tvs ctxt (RecCon fields) _)
 425                 -- Even if the constructor isn't mentioned, the fields
 426                 -- might be, as selectors.  They can't mention existentially
 427                 -- bound tyvars (typechecker checks for that) so no need for
 428                 -- the deleteListFromNameSet part
 429         = foldr (plusFV . get_field) emptyFVs fields
 430
 431     get other_con = emptyFVs
 432
 433     get_details (PrefixCon tys)  = plusFVs (map get_bang tys)
 434     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
 435     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 436
 437     get_field (f,t) | is_used f = get_bang t
 438                     | otherwise = emptyFVs
 439
 440     get_bang bty = extractHsTyNames (getBangType bty)
 441
 442 implicitClassGates :: Name -> FreeVars
 443 implicitClassGates cls
 444         -- If we load class Num, add Integer to the free gates
 445         -- This takes account of the fact that Integer might be needed for
 446         -- defaulting, but we don't want to load Integer (and all its baggage)
 447         -- if there's no numeric stuff needed.
 448         -- Similarly for class Fractional and Double
 449         --
 450         -- NB: adding T to the gates will force T to be loaded
 451         --
 452         -- NB: If we load (say) Floating, we'll end up loading Fractional too,
 453         --     since Fractional is a superclass of Floating
 454   | cls `hasKey` numClassKey        = unitFV integerTyConName
 455   | cls `hasKey` fractionalClassKey = unitFV doubleTyConName
 456   | otherwise                       = emptyFVs
 457 \end{code}
 458
 459 @getWiredInGates@ is just like @getGates@, but it sees a previously-loaded
 460 thing rather than a declaration.
 461
 462 \begin{code}
 463 getWiredInGates :: TyThing -> FreeVars
 464 -- The TyThing is one that we already have in our type environment, either
 465 --      a) because the TyCon or Id is wired in, or
 466 --      b) from a previous compile
 467 --
 468 -- Either way, we might have instance decls in the (persistent) collection
 469 -- of parsed-but-not-slurped instance decls that should be slurped in.
 470 -- This might be the first module that mentions both the type and the class
 471 -- for that instance decl, even though both the type and the class were
 472 -- mentioned in other modules, and hence are in the type environment
 473
 474 getWiredInGates (AClass cl)
 475   = unitFV (getName cl) `plusFV` mkFVs super_classes
 476   where
 477     super_classes = classNamesOfTheta (classSCTheta cl)
 478
 479 getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id)
 480 getWiredInGates (ATyCon tc)
 481   | isSynTyCon tc = tyClsNamesOfType ty
 482   | otherwise     = unitFV (getName tc)
 483   where
 484     (_,ty)  = getSynTyConDefn tc
 485
 486 getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty
 487 \end{code}
 488
 489 \begin{code}
 490 getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet)
 491         -- Returns the gates that are new since last time
 492 getImportedInstDecls gates
 493   =     -- First, load any orphan-instance modules that aren't aready loaded
 494         -- Orphan-instance modules are recorded in the module dependecnies
 495     getImports                  `thenM` \ imports ->
 496     getEps                      `thenM` \ eps ->
 497     let
 498         old_gates = eps_inst_gates eps
 499         new_gates = gates `minusNameSet` old_gates
 500         all_gates = new_gates `unionNameSets` old_gates
 501         orphan_mods = imp_orphs imports
 502     in
 503     loadOrphanModules orphan_mods                       `thenM_`
 504
 505         -- Now we're ready to grab the instance declarations
 506         -- Find the un-gated ones and return them,
 507         -- removing them from the bag kept in EPS
 508         -- Don't foget to get the EPS a second time...
 509         --      loadOrphanModules may have side-effected it!
 510     getEps                                      `thenM` \ eps ->
 511     let
 512         available n        = n `elemNameSet` all_gates
 513         (decls, new_insts) = selectGated available (eps_insts eps)
 514     in
 515     setEps (eps { eps_insts = new_insts,
 516                   eps_inst_gates = all_gates })         `thenM_`
 517
 518     traceRn (sep [text "getImportedInstDecls:",
 519                   nest 4 (fsep (map ppr (nameSetToList gates))),
 520                   nest 4 (fsep (map ppr (nameSetToList all_gates))),
 521                   nest 4 (fsep (map ppr (nameSetToList new_gates))),
 522                   text "Slurped" <+> int (length decls) <+> text "instance declarations",
 523                   nest 4 (vcat (map ppr_brief_inst_decl decls))])       `thenM_`
 524     returnM (decls, new_gates)
 525
 526 ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _)
 527   = case inst_ty of
 528         HsForAllTy _ _ tau -> ppr tau
 529         other              -> ppr inst_ty
 530
 531 getImportedRules :: NameSet     -- Slurped already
 532                  -> TcRn m [(Module,RdrNameRuleDecl)]
 533 getImportedRules slurped
 534   | opt_IgnoreIfacePragmas = returnM []
 535   | otherwise
 536   = getEps              `thenM` \ eps ->
 537     getInGlobalScope    `thenM` \ in_type_env ->
 538     let
 539                 -- Slurp rules for anything that is slurped,
 540                 -- either now, or previously
 541         available n        = n `elemNameSet` slurped || in_type_env n
 542         (decls, new_rules) = selectGated available (eps_rules eps)
 543     in
 544     if null decls then
 545         returnM []
 546     else
 547     setEps (eps { eps_rules = new_rules })                   `thenM_`
 548     traceRn (sep [text "getImportedRules:",
 549                   text "Slurped" <+> int (length decls) <+> text "rules"])   `thenM_`
 550     returnM decls
 551
 552 selectGated :: (Name->Bool) -> GatedDecls d
 553             -> ([(Module,d)], GatedDecls d)
 554 selectGated available (decl_bag, n_slurped)
 555         -- Select only those decls whose gates are *all* available
 556 #ifdef DEBUG
 557   | opt_NoPruneDecls    -- Just to try the effect of not gating at all
 558   = let
 559         decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag       -- Grab them all
 560     in
 561     (decls, (emptyBag, n_slurped + length decls))
 562
 563   | otherwise
 564 #endif
 565   = case foldrBag select ([], emptyBag) decl_bag of
 566         (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
 567   where
 568     select (gate_fn, decl) (yes, no)
 569         | gate_fn available  = (decl:yes, no)
 570         | otherwise          = (yes,      (gate_fn,decl) `consBag` no)
 571 \end{code}
 572
 573
 574 %********************************************************
 575 %*                                                      *
 576 \subsection{Checking usage information}
 577 %*                                                      *
 578 %********************************************************
 579
 580 @recompileRequired@ is called from the HscMain.   It checks whether
 581 a recompilation is required.  It needs access to the persistent state,
 582 finder, etc, because it may have to load lots of interface files to
 583 check their versions.
 584
 585 \begin{code}
 586 type RecompileRequired = Bool
 587 upToDate  = False       -- Recompile not required
 588 outOfDate = True        -- Recompile required
 589
 590 checkVersions :: Bool           -- True <=> source unchanged
 591               -> ModIface       -- Old interface
 592               -> TcRn m RecompileRequired
 593 checkVersions source_unchanged iface
 594   | not source_unchanged
 595   = returnM outOfDate
 596   | otherwise
 597   = traceHiDiffs (text "Considering whether compilation is required for" <+>
 598                   ppr (mi_module iface) <> colon)       `thenM_`
 599
 600         -- Source code unchanged and no errors yet... carry on
 601         -- First put the dependent-module info in the envt, just temporarily,
 602         -- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
 603         -- It's just temporary because either the usage check will succeed
 604         -- (in which case we are done with this module) or it'll fail (in which
 605         -- case we'll compile the module from scratch anyhow).
 606     updGblEnv (\ gbl -> gbl { tcg_imports = mod_deps }) (
 607         checkList [checkModUsage u | u <- mi_usages iface]
 608     )
 609
 610   where
 611         -- This is a bit of a hack really
 612     mod_deps = emptyImportAvails { imp_dep_mods = mkModDeps (dep_mods (mi_deps iface)) }
 613
 614 checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired
 615 checkList []             = returnM upToDate
 616 checkList (check:checks) = check        `thenM` \ recompile ->
 617                            if recompile then
 618                                 returnM outOfDate
 619                            else
 620                                 checkList checks
 621 \end{code}
 622
 623 \begin{code}
 624 checkModUsage :: Usage Name -> TcRn m RecompileRequired
 625 -- Given the usage information extracted from the old
 626 -- M.hi file for the module being compiled, figure out
 627 -- whether M needs to be recompiled.
 628
 629 checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
 630                        usg_rules = old_rule_vers,
 631                        usg_exports = maybe_old_export_vers,
 632                        usg_entities = old_decl_vers })
 633   =     -- Load the imported interface is possible
 634     let
 635         doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
 636     in
 637     traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
 638
 639     tryM (loadInterface doc_str mod_name ImportBySystem)        `thenM` \ mb_iface ->
 640
 641     case mb_iface of {
 642         Left exn ->  (out_of_date (sep [ptext SLIT("Can't find version number for module"),
 643                                        ppr mod_name]));
 644                 -- Couldn't find or parse a module mentioned in the
 645                 -- old interface file.  Don't complain -- it might just be that
 646                 -- the current module doesn't need that import and it's been deleted
 647
 648         Right iface ->
 649     let
 650         new_vers        = mi_version iface
 651         new_mod_vers    = vers_module  new_vers
 652         new_decl_vers   = vers_decls   new_vers
 653         new_export_vers = vers_exports new_vers
 654         new_rule_vers   = vers_rules   new_vers
 655     in
 656         -- CHECK MODULE
 657     checkModuleVersion old_mod_vers new_mod_vers        `thenM` \ recompile ->
 658     if not recompile then
 659         returnM upToDate
 660     else
 661
 662         -- CHECK EXPORT LIST
 663     if checkExportList maybe_old_export_vers new_export_vers then
 664         out_of_date_vers (ptext SLIT("  Export list changed"))
 665                          (fromJust maybe_old_export_vers)
 666                          new_export_vers
 667     else
 668
 669         -- CHECK RULES
 670     if old_rule_vers /= new_rule_vers then
 671         out_of_date_vers (ptext SLIT("  Rules changed"))
 672                          old_rule_vers new_rule_vers
 673     else
 674
 675         -- CHECK ITEMS ONE BY ONE
 676     checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers]   `thenM` \ recompile ->
 677     if recompile then
 678         returnM outOfDate       -- This one failed, so just bail out now
 679     else
 680         up_to_date (ptext SLIT("  Great!  The bits I use are up to date"))
 681
 682     }
 683
 684 ------------------------
 685 checkModuleVersion old_mod_vers new_mod_vers
 686   | new_mod_vers == old_mod_vers
 687   = up_to_date (ptext SLIT("Module version unchanged"))
 688
 689   | otherwise
 690   = out_of_date_vers (ptext SLIT("  Module version has changed"))
 691                      old_mod_vers new_mod_vers
 692
 693 ------------------------
 694 checkExportList Nothing  new_vers = upToDate
 695 checkExportList (Just v) new_vers = v /= new_vers
 696
 697 ------------------------
 698 checkEntityUsage new_vers (name,old_vers)
 699   = case lookupNameEnv new_vers name of
 700
 701         Nothing       ->        -- We used it before, but it ain't there now
 702                           out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
 703
 704         Just new_vers   -- It's there, but is it up to date?
 705           | new_vers == old_vers -> traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
 706                                     returnM upToDate
 707           | otherwise            -> out_of_date_vers (ptext SLIT("  Out of date:") <+> ppr name)
 708                                                      old_vers new_vers
 709
 710 up_to_date  msg = traceHiDiffs msg `thenM_` returnM upToDate
 711 out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
 712 out_of_date_vers msg old_vers new_vers
 713   = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
 714 \end{code}
 715
 716
 717 %*********************************************************
 718 %*                                                       *
 719 \subsection{Errors}
 720 %*                                                       *
 721 %*********************************************************
 722
 723 \begin{code}
 724 getDeclErr name
 725   = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
 726           ptext SLIT("from module") <+> quotes (ppr (nameModule name))
 727          ]
 728 \end{code}