RnIfaces.lhs 27.6 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6
%
\section[RnIfaces]{Cacheing and Renaming of Interfaces}

\begin{code}
7
module RnIfaces
8
     (
9
	getInterfaceExports,
10 11 12
	recordLocalSlurps, 
	mkImportInfo, 

13
	slurpImpDecls, closeDecls,
14

15
	RecompileRequired, outOfDate, upToDate, recompileRequired
16 17
       )
where
18

19
#include "HsVersions.h"
20

21
import CmdLineOpts	( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
22
import HscTypes
23 24 25
import HsSyn		( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
			  InstDecl(..), HsType(..), hsTyVarNames, getBangType
			)
26
import HsImpExp		( ImportDecl(..) )
27 28 29 30 31
import RdrHsSyn		( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn		( RenamedHsDecl, RenamedTyClDecl,
			  extractHsTyNames, extractHsCtxtTyNames, 
			  tyClDeclFVs, ruleDeclFVs, instDeclFVs
			)
32 33 34
import RnHiFiles	( tryLoadInterface, loadHomeInterface, loadInterface, 
			  loadOrphanModules
			)
35
import RnSource		( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl )
36
import RnEnv
37
import RnMonad
38 39 40
import Id		( idType )
import Type		( namesOfType )
import TyCon		( isSynTyCon, getSynTyConDefn )
41
import Name		( Name {-instance NamedThing-}, nameOccName,
42
			  nameModule, isLocalName, nameUnique,
43
			  NamedThing(..)
44
			 )
45
import Name 		( elemNameEnv, delFromNameEnv )
46
import Module		( Module, ModuleEnv, 
47
			  moduleName, isModuleInThisPackage,
48
			  ModuleName, WhereFrom(..),
49 50 51
			  emptyModuleEnv, 
			  extendModuleEnv_C, foldModuleEnv, lookupModuleEnv,
			  elemModuleSet, extendModuleSet
52
			)
53
import NameSet
54 55
import PrelInfo		( wiredInThingEnv, fractionalClassKeys )
import TysWiredIn	( doubleTyCon )
56
import Maybes		( orElse )
57
import FiniteMap
sof's avatar
sof committed
58
import Outputable
59
import Bag
60
import Util		( sortLt )
61 62
\end{code}

63

64 65
%*********************************************************
%*							*
sof's avatar
sof committed
66
\subsection{Getting what a module exports}
67 68
%*							*
%*********************************************************
69

70
@getInterfaceExports@ is called only for directly-imported modules.
71

72
\begin{code}
73
getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, [(ModuleName,Avails)])
74
getInterfaceExports mod_name from
75 76 77
  = loadInterface doc_str mod_name from	`thenRn` \ iface ->
    returnRn (mi_module iface, mi_exports iface)
  where
78
      doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")]
sof's avatar
sof committed
79 80 81 82 83 84 85 86 87
\end{code}


%*********************************************************
%*							*
\subsection{Keeping track of what we've slurped, and version numbers}
%*							*
%*********************************************************

88
mkImportInof figures out what the ``usage information'' for this
89
moudule is; that is, what it must record in its interface file as the
90 91 92 93 94 95
things it uses.  

We produce a line for every module B below the module, A, currently being
compiled:
	import B <n> ;
to record the fact that A does import B indireclty.  This is used to decide
96 97 98
to look to look for B.hi rather than B.hi-boot when compiling a module that
imports A.  This line says that A imports B, but uses nothing in it.
So we'll get an early bale-out when compiling A if B's version changes.
99

100
\begin{code}
101 102 103 104 105
mkImportInfo :: ModuleName			-- Name of this module
	     -> [ImportDecl n]			-- The import decls
	     -> RnMG [ImportVersion Name]

mkImportInfo this_mod imports
106
  = getIfacesRn					`thenRn` \ ifaces ->
107
    getHomeIfaceTableRn				`thenRn` \ hit -> 
108
    let
109 110 111
	(imp_pkg_mods, imp_home_names) = iVSlurp ifaces
	pit	 		       = iPIT 	 ifaces

112 113 114
	import_all_mods :: [ModuleName]
		-- Modules where we imported all the names
		-- (apart from hiding some, perhaps)
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
	import_all_mods = [ m | ImportDecl m _ _ _ imp_list _ <- imports,
			        import_all imp_list ]
		 	where
			  import_all (Just (False, _)) = False	-- Imports are specified explicitly
			  import_all other	       = True	-- Everything is imported

	-- mv_map groups together all the things imported and used
	-- from a particular module in this package
	-- We use a finite map because we want the domain
	mv_map :: ModuleEnv [Name]
	mv_map  = foldNameSet add_mv emptyModuleEnv imp_home_names
        add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
			   where
			     mod = nameModule name
			     add_item names _ = name:names

	-- In our usage list we record
	--	a) Specifically: Detailed version info for imports from modules in this package
	--			 Gotten from iVSlurp plus import_all_mods
	--
	--	b) Everything:   Just the module version for imports from modules in other packages
	--			 Gotten from iVSlurp plus import_all_mods
	--
	--	c) NothingAtAll: The name only of modules, Baz, in this package that are 'below' us, 
	--			 but which we didn't need at all (this is needed only to decide whether
	--			 to open Baz.hi or Baz.hi-boot higher up the tree).
	--			 This happens when a module, Foo, that we explicitly imported has 
	--			 'import Baz' in its interface file, recording that Baz is below
	--			 Foo in the module dependency hierarchy.  We want to propagate this info.
	--			 These modules are in a combination of HIT/PIT and iImpModInfo
	--
	--	d) NothingAtAll: The name only of all orphan modules we know of (this is needed
	--	   		 so that anyone who imports us can find the orphan modules)
	--			 These modules are in a combination of HIT/PIT and iImpModInfo

	import_info0 = foldModuleEnv mk_imp_info  []	       pit
	import_info1 = foldModuleEnv mk_imp_info  import_info0 hit
	import_info  = [ (mod_name, orphans, is_boot, NothingAtAll) 
		       | (mod_name, (orphans, is_boot)) <- fmToList (iImpModInfo ifaces) ] ++ 
		       import_info1
	
	mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name]
	mk_imp_info iface so_far
158

159 160 161
	  | Just ns <- lookupModuleEnv mv_map mod 	-- Case (a)
	  = go_for_it (Specifically mod_vers maybe_export_vers 
				    (mk_import_items ns) rules_vers)
162

163 164
	  | mod `elemModuleSet` imp_pkg_mods		-- Case (b)
	  = go_for_it (Everything mod_vers)
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
	  | import_all_mod				-- Case (a) and (b); the import-all part
	  = if is_home_pkg_mod then
		go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers)
	    else
		go_for_it (Everything mod_vers)
		
	  | is_home_pkg_mod || has_orphans		-- Case (c) or (d)
	  = go_for_it NothingAtAll

	  | otherwise = so_far
	  where
	    go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far

	    mod		    = mi_module iface
	    mod_name	    = moduleName mod
	    is_home_pkg_mod = isModuleInThisPackage mod
	    version_info    = mi_version iface
	    version_env     = vers_decls   version_info
	    mod_vers	    = vers_module  version_info
	    rules_vers	    = vers_rules   version_info
	    export_vers	    = vers_exports version_info
	    import_all_mod  = mod_name `elem` import_all_mods
	    has_orphans	    = mi_orphan iface
	    
		-- The sort is to put them into canonical order
	    mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns, 
	    		                  let v = lookupNameEnv version_env n `orElse` 
	    			                  pprPanic "mk_whats_imported" (ppr n)
		                 ]
			 where
			   lt_occ n1 n2 = nameOccName n1 < nameOccName n2

	    maybe_export_vers | import_all_mod = Just (vers_exports version_info)
			      | otherwise      = Nothing
sof's avatar
sof committed
200
    in
201
    returnRn import_info
202
\end{code}
203

204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
%*********************************************************
%*						 	 *
\subsection{Slurping declarations}
%*							 *
%*********************************************************

\begin{code}
-------------------------------------------------------
slurpImpDecls source_fvs
  = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`

	-- The current slurped-set records all local things
    getSlurped					`thenRn` \ source_binders ->
    slurpSourceRefs source_binders source_fvs	`thenRn` \ (decls, needed) ->

	-- Then get everything else
220
    closeDecls decls needed
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


-------------------------------------------------------
slurpSourceRefs :: NameSet			-- Variables defined in source
		-> FreeVars			-- Variables referenced in source
		-> RnMG ([RenamedHsDecl],
			 FreeVars)		-- Un-satisfied needs
-- The declaration (and hence home module) of each gate has
-- already been loaded

slurpSourceRefs source_binders source_fvs
  = go_outer [] 			-- Accumulating decls
	     emptyFVs 			-- Unsatisfied needs
	     emptyFVs			-- Accumulating gates
  	     (nameSetToList source_fvs)	-- Things whose defn hasn't been loaded yet
  where
	-- The outer loop repeatedly slurps the decls for the current gates
	-- and the instance decls 

	-- The outer loop is needed because consider

    go_outer decls fvs all_gates []	
	= returnRn (decls, fvs)

    go_outer decls fvs all_gates refs	-- refs are not necessarily slurped yet
	= traceRn (text "go_outer" <+> ppr refs)		`thenRn_`
247
	  getImportedInstDecls all_gates			`thenRn` \ inst_decls ->
248
	  foldlRn go_inner (decls, fvs, emptyFVs) refs		`thenRn` \ (decls1, fvs1, gates1) ->
249
	  rnIfaceInstDecls decls1 fvs1 gates1 inst_decls	`thenRn` \ (decls2, fvs2, gates2) ->
250 251 252 253 254 255 256 257
	  go_outer decls2 fvs2 (all_gates `plusFV` gates2)
			       (nameSetToList (gates2 `minusNameSet` all_gates))
		-- Knock out the all_gates because even if we don't slurp any new
		-- decls we can get some apparently-new gates from wired-in names

    go_inner (decls, fvs, gates) wanted_name
	= importDecl wanted_name 		`thenRn` \ import_result ->
	  case import_result of
258 259
	    AlreadySlurped     -> returnRn (decls, fvs, gates)
	    InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing)
260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279
			
	    HereItIs decl -> rnIfaceTyClDecl decl		`thenRn` \ (new_decl, fvs1) ->
			     returnRn (TyClD new_decl : decls, 
				       fvs1 `plusFV` fvs,
			   	       gates `plusFV` getGates source_fvs new_decl)
\end{code}


\begin{code}
-------------------------------------------------------
-- closeDecls keeps going until the free-var set is empty
closeDecls decls needed
  | not (isEmptyFVs needed)
  = slurpDecls decls needed	`thenRn` \ (decls1, needed1) ->
    closeDecls decls1 needed1

  | otherwise
  = getImportedRules 			`thenRn` \ rule_decls ->
    case rule_decls of
	[]    -> returnRn decls	-- No new rules, so we are done
280
	other -> rnIfaceDecls rnIfaceRuleDecl rule_decls	`thenRn` \ rule_decls' ->
281 282 283 284 285 286
		 let
			rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
		 in
		 traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs)))	`thenRn_`
		 closeDecls (map RuleD rule_decls' ++ decls) rule_fvs

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
		 

-------------------------------------------------------
-- Augment decls with any decls needed by needed.
-- Return also free vars of the new decls (only)
slurpDecls decls needed
  = go decls emptyFVs (nameSetToList needed) 
  where
    go decls fvs []         = returnRn (decls, fvs)
    go decls fvs (ref:refs) = slurpDecl decls fvs ref	`thenRn` \ (decls1, fvs1) ->
			      go decls1 fvs1 refs

-------------------------------------------------------
slurpDecl decls fvs wanted_name
  = importDecl wanted_name 		`thenRn` \ import_result ->
    case import_result of
	-- Found a declaration... rename it
	HereItIs decl -> rnIfaceTyClDecl decl		`thenRn` \ (new_decl, fvs1) ->
			 returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)

	-- No declaration... (wired in thing, or deferred, or already slurped)
	other -> returnRn (decls, fvs)


-------------------------------------------------------
312 313 314 315 316 317 318 319 320
rnIfaceDecls rn decls	   = mapRn (rnIfaceDecl rn) decls
rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl)	

rnIfaceInstDecls decls fvs gates inst_decls
  = rnIfaceDecls rnInstDecl inst_decls	`thenRn` \ inst_decls' ->
    returnRn (map InstD inst_decls' ++ decls,
	      fvs `plusFV` plusFVs (map instDeclFVs inst_decls'),
	      gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))

321 322
rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)	`thenRn` \ decl' ->
			      returnRn (decl', tyClDeclFVs decl')
323 324 325
\end{code}


sof's avatar
sof committed
326
\begin{code}
327
getSlurped
sof's avatar
sof committed
328
  = getIfacesRn 	`thenRn` \ ifaces ->
329
    returnRn (iSlurp ifaces)
sof's avatar
sof committed
330

331 332 333
recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
			     iSlurp = slurped_names, 
			     iVSlurp = (imp_mods, imp_names) })
334
	    avail
335
  = ASSERT2( not (isLocalName (availName avail)), ppr avail )
336 337 338
    ifaces { iDecls = (decls_map', n_slurped+1),
	     iSlurp  = new_slurped_names, 
	     iVSlurp = new_vslurp }
339
  where
340 341 342
    decls_map' = foldl delFromNameEnv decls_map (availNames avail)
    main_name  = availName avail
    mod	       = nameModule main_name
343 344 345
    new_slurped_names = addAvailToNameSet slurped_names avail
    new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name)
    	       | otherwise		   = (extendModuleSet imp_mods mod, imp_names)
sof's avatar
sof committed
346

347 348 349 350
recordLocalSlurps local_avails
  = getIfacesRn 	`thenRn` \ ifaces ->
    let
	new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails
sof's avatar
sof committed
351
    in
352
    setIfacesRn (ifaces { iSlurp  = new_slurped_names })
sof's avatar
sof committed
353 354 355
\end{code}


356 357 358 359 360 361 362

%*********************************************************
%*						 	 *
\subsection{Extracting the `gates'}
%*							 *
%*********************************************************

363 364 365 366 367 368 369 370
The gating story
~~~~~~~~~~~~~~~~~
We want to avoid sucking in too many instance declarations.
An instance decl is only useful if the types and classes mentioned in
its 'head' are all available in the program being compiled.  E.g.

	instance (..) => C (T1 a) (T2 b) where ...

371
is only useful if C, T1 and T2 are all "available".  So we keep
372 373 374 375
instance decls that have been parsed from .hi files, but not yet
slurped in, in a pool called the 'gated instance pool'.
Each has its set of 'gates': {C, T1, T2} in the above example.

376 377 378 379 380 381 382 383 384 385 386 387 388 389
More precisely, the gates of a module are the types and classes 
that are mentioned in:

	a) the source code
	b) the type of an Id that's mentioned in the source code
	   [includes constructors and selectors]
	c) the RHS of a type synonym that is a gate
	d) the superclasses of a class that is a gate
	e) the context of an instance decl that is slurped in

We slurp in an instance decl from the gated instance pool iff
	
	all its gates are either in the gates of the module, 
	or are a previously-loaded class.  
390

391 392
The latter constraint is because there might have been an instance
decl slurped in during an earlier compilation, like this:
393

394
	instance Foo a => Baz (Maybe a) where ...
395

396 397 398 399 400 401 402
In the module being compiled we might need (Baz (Maybe T)), where T
is defined in this module, and hence we need (Foo T).  So @Foo@ becomes
a gate.  But there's no way to 'see' that, so we simply treat all 
previously-loaded classes as gates.

Consructors and class operations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
403
When we import a declaration like
404

405
	data T = T1 Wibble | T2 Wobble
406

407
we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless}
408
@T1@, @T2@ respectively are mentioned by the user program. If only
409 410 411 412
@T@ is mentioned we want only @T@ to be a gate; that way we don't suck
in useless instance decls for (say) @Eq Wibble@, when they can't
possibly be useful.

413 414 415 416
And that's just what (b) says: we only treat T1's type as a gate if
T1 is mentioned.  getGates, which deals with decls we are slurping in,
has to be a bit careful, because a mention of T1 will slurp in T's whole
declaration.
417

418
-----------------------------
419 420 421 422
@getGates@ takes a newly imported (and renamed) decl, and the free
vars of the source program, and extracts from the decl the gate names.

\begin{code}
423
getGates :: FreeVars		-- Things mentioned in the source program
424
	 -> RenamedTyClDecl
425 426
	 -> FreeVars

427 428
getGates source_fvs decl 
  = get_gates (\n -> n `elemNameSet` source_fvs) decl
429 430

get_gates is_used (IfaceSig _ ty _ _)
431 432
  = extractHsTyNames ty

433
get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ )
434 435 436 437 438 439
  = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
		        (hsTyVarNames tvs)
     `addOneToNameSet` cls)
    `plusFV` maybe_double
  where
    get (ClassOpSig n _ ty _) 
440 441
	| is_used n = extractHsTyNames ty
	| otherwise = emptyFVs
442 443 444 445 446 447 448 449 450 451 452

	-- If we load any numeric class that doesn't have
	-- Int as an instance, add Double to the gates. 
	-- This takes account of the fact that Double might be needed for
	-- defaulting, but we don't want to load Double (and all its baggage)
	-- if the more exotic classes aren't used at all.
    maybe_double | nameUnique cls `elem` fractionalClassKeys 
		 = unitFV (getName doubleTyCon)
		 | otherwise
		 = emptyFVs

453 454
get_gates is_used (TySynonym tycon tvs ty _)
  = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
455 456
	-- A type synonym type constructor isn't a "gate" for instance decls

457
get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _)
458 459 460 461 462
  = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
		       (hsTyVarNames tvs)
    `addOneToNameSet` tycon
  where
    get (ConDecl n _ tvs ctxt details _)
463
	| is_used n
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
		-- If the constructor is method, get fvs from all its fields
	= delListFromNameSet (get_details details `plusFV` 
		  	      extractHsCtxtTyNames ctxt)
			     (hsTyVarNames tvs)
    get (ConDecl n _ tvs ctxt (RecCon fields) _)
		-- Even if the constructor isn't mentioned, the fields
		-- might be, as selectors.  They can't mention existentially
		-- bound tyvars (typechecker checks for that) so no need for 
		-- the deleteListFromNameSet part
	= foldr (plusFV . get_field) emptyFVs fields
	
    get other_con = emptyFVs

    get_details (VanillaCon tys) = plusFVs (map get_bang tys)
    get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
    get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]

481 482
    get_field (fs,t) | any is_used fs = get_bang t
		     | otherwise      = emptyFVs
483 484 485 486

    get_bang bty = extractHsTyNames (getBangType bty)
\end{code}

487 488
@getWiredInGates@ is just like @getGates@, but it sees a previously-loaded
thing rather than a declaration.
489 490

\begin{code}
491 492 493 494
getWiredInGates :: TyThing -> FreeVars
-- The TyThing is one that we already have in our type environment, either
--	a) because the TyCon or Id is wired in, or
--	b) from a previous compile
495
-- Either way, we might have instance decls in the (persistent) collection
496 497 498 499 500
-- of parsed-but-not-slurped instance decls that should be slurped in.
-- This might be the first module that mentions both the type and the class
-- for that instance decl, even though both the type and the class were
-- mentioned in other modules, and hence are in the type environment

501 502 503
getWiredInGates (AnId the_id) = namesOfType (idType the_id)
getWiredInGates (AClass cl)   = emptyFVs	-- The superclasses must also be previously
						-- loaded, and hence are automatically gates
504
getWiredInGates (ATyCon tc)
505
  | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars)
506 507 508
  | otherwise	  = unitFV (getName tc)
  where
    (tyvars,ty)  = getSynTyConDefn tc
509

510
getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty
511 512 513
\end{code}

\begin{code}
514
getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)]
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542
getImportedInstDecls gates
  =    	-- First, load any orphan-instance modules that aren't aready loaded
	-- Orphan-instance modules are recorded in the module dependecnies
    getIfacesRn 					`thenRn` \ ifaces ->
    let
	orphan_mods =
	  [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
    in
    loadOrphanModules orphan_mods			`thenRn_` 

	-- Now we're ready to grab the instance declarations
	-- Find the un-gated ones and return them, 
	-- removing them from the bag kept in Ifaces
    getIfacesRn 					`thenRn` \ ifaces ->
    getTypeEnvRn					`thenRn` \ lookup ->
    let
	(decls, new_insts) = selectGated gates lookup (iInsts ifaces)
    in
    setIfacesRn (ifaces { iInsts = new_insts })		`thenRn_`

    traceRn (sep [text "getImportedInstDecls:", 
		  nest 4 (fsep (map ppr gate_list)),
		  text "Slurped" <+> int (length decls) <+> text "instance declarations",
		  nest 4 (vcat (map ppr_brief_inst_decl decls))])	`thenRn_`
    returnRn decls
  where
    gate_list      = nameSetToList gates

543
ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _)
544 545 546 547
  = case inst_ty of
	HsForAllTy _ _ tau -> ppr tau
	other		   -> ppr inst_ty

548
getImportedRules :: RnMG [(Module,RdrNameRuleDecl)]
549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
getImportedRules 
  | opt_IgnoreIfacePragmas = returnRn []
  | otherwise
  = getIfacesRn 	`thenRn` \ ifaces ->
    getTypeEnvRn	`thenRn` \ lookup ->
    let
	gates		   = iSlurp ifaces	-- Anything at all that's been slurped
	rules		   = iRules ifaces
	(decls, new_rules) = selectGated gates lookup rules
    in
    if null decls then
	returnRn []
    else
    setIfacesRn (ifaces { iRules = new_rules })		     `thenRn_`
    traceRn (sep [text "getImportedRules:", 
		  text "Slurped" <+> int (length decls) <+> text "rules"])   `thenRn_`
    returnRn decls

567
selectGated gates lookup (decl_bag, n_slurped)
568
	-- Select only those decls whose gates are *all* in 'gates'
569
	-- or are a class in 'lookup'
570 571
#ifdef DEBUG
  | opt_NoPruneDecls	-- Just to try the effect of not gating at all
572 573 574 575
  = let
	decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag	-- Grab them all
    in
    (decls, (emptyBag, n_slurped + length decls))
576 577 578

  | otherwise
#endif
579 580
  = case foldrBag select ([], emptyBag) decl_bag of
	(decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
581
  where
582 583 584
    available n = n `elemNameSet` gates 
		|| case lookup n of { Just (AClass c) -> True; other -> False }

585 586 587 588 589
    select (reqd, decl) (yes, no)
	| all available reqd = (decl:yes, no)
	| otherwise	     = (yes,      (reqd,decl) `consBag` no)
\end{code}

590

591 592
%*********************************************************
%*							*
593
\subsection{Getting in a declaration}
594 595 596
%*							*
%*********************************************************

597 598
\begin{code}
importDecl :: Name -> RnMG ImportDeclResult
599

600 601
data ImportDeclResult
  = AlreadySlurped
602
  | InTypeEnv TyThing
603
  | HereItIs (Module, RdrNameTyClDecl)
604

605
importDecl name
606
  = 	-- STEP 1: Check if it was loaded before beginning this module
607
    if isLocalName name then
608
	traceRn (text "Already (local)" <+> ppr name) `thenRn_`
609 610
	returnRn AlreadySlurped
    else
611

612 613 614 615 616 617 618
	-- STEP 2: Check if we've slurped it in while compiling this module
    getIfacesRn				`thenRn` \ ifaces ->
    if name `elemNameSet` iSlurp ifaces then	
	returnRn AlreadySlurped	
    else

	-- STEP 3: Check if it's already in the type environment
619 620 621 622 623 624
    getTypeEnvRn 			`thenRn` \ lookup ->
    case lookup name of {
	Just ty_thing | name `elemNameEnv` wiredInThingEnv
		      -> 	-- When we find a wired-in name we must load its home
				-- module so that we find any instance decls lurking therein
			 loadHomeInterface wi_doc name	`thenRn_`
625
			 returnRn (InTypeEnv ty_thing)
626 627

		      | otherwise
628
		      -> returnRn (InTypeEnv ty_thing) ;
629 630 631 632 633 634 635 636 637 638

	Nothing -> 

	-- STEP 4: OK, we have to slurp it in from an interface file
	--	   First load the interface file
    traceRn nd_doc			`thenRn_`
    loadHomeInterface nd_doc name	`thenRn_`
    getIfacesRn				`thenRn` \ ifaces ->

	-- STEP 5: Get the declaration out
639 640 641 642
    let
	(decls_map, _) = iDecls ifaces
    in
    case lookupNameEnv decls_map name of
643 644 645
      Just (avail,_,decl)
	-> setIfacesRn (recordSlurp ifaces avail)	`thenRn_`
	   returnRn (HereItIs decl)
646

647 648 649 650
      Nothing 
	-> addErrRn (getDeclErr name)	`thenRn_` 
	   returnRn AlreadySlurped
    }
651
  where
652 653
    wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
    nd_doc = ptext SLIT("need decl for") <+> ppr name
654

655
\end{code}
656

657 658

%********************************************************
659
%*							*
660
\subsection{Checking usage information}
661
%*							*
662
%********************************************************
663

664 665 666 667 668
@recompileRequired@ is called from the HscMain.   It checks whether
a recompilation is required.  It needs access to the persistent state,
finder, etc, because it may have to load lots of interface files to
check their versions.

669
\begin{code}
670 671 672 673
type RecompileRequired = Bool
upToDate  = False	-- Recompile not required
outOfDate = True	-- Recompile required

674
recompileRequired :: FilePath		-- Only needed for debug msgs
675
		  -> Bool 		-- Source unchanged
676
		  -> ModIface 		-- Old interface
677
		  -> RnMG RecompileRequired
678
recompileRequired iface_path source_unchanged iface
679
  = traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon)	`thenRn_`
680 681 682

	-- CHECK WHETHER THE SOURCE HAS CHANGED
    if not source_unchanged then
683
	traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off"))	`thenRn_` 
684 685
	returnRn outOfDate
    else
686

687
	-- Source code unchanged and no errors yet... carry on 
688
    checkList [checkModUsage u | u <- mi_usages iface]
689 690 691 692 693 694 695 696

checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
checkList []		 = returnRn upToDate
checkList (check:checks) = check	`thenRn` \ recompile ->
			   if recompile then 
				returnRn outOfDate
			   else
				checkList checks
697
\end{code}
698 699
	
\begin{code}
700
checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
701 702 703 704
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.

705
checkModUsage (mod_name, _, _, NothingAtAll)
706 707 708 709 710 711 712
	-- If CurrentModule.hi contains 
	--	import Foo :: ;
	-- then that simply records that Foo lies below CurrentModule in the
	-- hierarchy, but CurrentModule doesn't depend in any way on Foo.
	-- In this case we don't even want to open Foo's interface.
  = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)

713
checkModUsage (mod_name, _, _, whats_imported)
714
  = tryLoadInterface doc_str mod_name ImportBySystem	`thenRn` \ (iface, maybe_err) ->
715 716 717 718 719 720 721 722 723
    case maybe_err of {
	Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), 
				      ppr mod_name]) ;
		-- Couldn't find or parse a module mentioned in the
		-- old interface file.  Don't complain -- it might just be that
		-- the current module doesn't need that import and it's been deleted

	Nothing -> 
    let
724
	new_vers      = mi_version iface
725 726 727
	new_decl_vers = vers_decls new_vers
    in
    case whats_imported of {	-- NothingAtAll dealt with earlier
728

729 730 731 732 733
      Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers	`thenRn` \ recompile ->
				 if recompile then
					out_of_date (ptext SLIT("...and I needed the whole module"))
				 else
					returnRn upToDate ;
734

735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760
      Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers ->

	-- CHECK MODULE
    checkModuleVersion old_mod_vers new_vers	`thenRn` \ recompile ->
    if not recompile then
	returnRn upToDate
    else
				 
	-- CHECK EXPORT LIST
    if checkExportList maybe_old_export_vers new_vers then
	out_of_date (ptext SLIT("Export list changed"))
    else

	-- CHECK RULES
    if old_rule_vers /= vers_rules new_vers then
	out_of_date (ptext SLIT("Rules changed"))
    else

	-- CHECK ITEMS ONE BY ONE
    checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers]	`thenRn` \ recompile ->
    if recompile then
	returnRn outOfDate	-- This one failed, so just bail out now
    else
	up_to_date (ptext SLIT("...but the bits I use haven't."))

    }}
761
  where
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786
    doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]

------------------------
checkModuleVersion old_mod_vers new_vers
  | vers_module new_vers == old_mod_vers
  = up_to_date (ptext SLIT("Module version unchanged"))

  | otherwise
  = out_of_date (ptext SLIT("Module version has changed"))

------------------------
checkExportList Nothing  new_vers = upToDate
checkExportList (Just v) new_vers = v /= vers_exports new_vers

------------------------
checkEntityUsage new_vers (name,old_vers)
  = case lookupNameEnv new_vers name of

	Nothing       -> 	-- We used it before, but it ain't there now
			  out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])

	Just new_vers 	-- It's there, but is it up to date?
	  | new_vers == old_vers -> returnRn upToDate
	  | otherwise	 	 -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])

787 788
up_to_date  msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate
789
\end{code}
790

791

792
%*********************************************************
sof's avatar
sof committed
793
%*						 	 *
794
\subsection{Errors}
sof's avatar
sof committed
795
%*							 *
796
%*********************************************************
797

798
\begin{code}
799
getDeclErr name
800 801 802
  = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
	  ptext SLIT("from module") <+> quotes (ppr (nameModule name))
	 ]
803
\end{code}