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

\begin{code}
#include "HsVersions.h"

module RnIfaces (
10
	cachedIface,
11
	cachedDecl, CachingResult(..),
12
	rnIfaces,
13
	IfaceCache, initIfaceCache
14
15
    ) where

16
IMP_Ubiq()
17

18
19
20
21
22
23
24
25
26
import PreludeGlaST	( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
#if __GLASGOW_HASKELL__ >= 200
# define ST_THEN `stThen`
# define TRY_IO  tryIO
IMPORT_1_3(GHCio(stThen,tryIO))
#else
# define ST_THEN `thenPrimIO`
# define TRY_IO	 try
#endif
27

28
import HsSyn
29
import HsPragmas	( noGenPragmas )
30
31
32
33
import RdrHsSyn
import RnHsSyn

import RnMonad
34
import RnSource		( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
35
import RnUtils		( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
36
import ParseIface	( parseIface )
37
38
39
import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
			  VersionsMap(..), UsagesMap(..)
			)
40

41
42
import Bag		( emptyBag, unitBag, consBag, snocBag,
			  unionBags, unionManyBags, isEmptyBag, bagToList )
43
import ErrUtils		( SYN_IE(Error), SYN_IE(Warning) )
44
45
import FiniteMap	( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
			  fmToList, delListFromFM, sizeFM, foldFM, unitFM,
46
			  plusFM_C, addListToFM, keysFM{-ToDo:rm-}, FiniteMap
47
			)
48
import Maybes		( maybeToBool, MaybeErr(..) )
49
50
import Name		( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
			  isLexCon, RdrName(..), Name{-instance NamedThing-} )
51
52
import PprStyle		-- ToDo:rm
import Outputable	-- ToDo:rm
53
import PrelInfo		( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
54
import Pretty
55
56
import UniqFM		( emptyUFM )
import UniqSupply	( splitUniqSupply )
57
58
import Util		( sortLt, removeDups, cmpPString, startsWith,
			  panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
59
60
61
\end{code}

\begin{code}
62
63
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
64

65
66
67
68
69
70
#if __GLASGOW_HASKELL__ >= 200
# define REAL_WORLD RealWorld
#else
# define REAL_WORLD _RealWorld
#endif

71
72
73
74
75
data IfaceCache
  = IfaceCache
	Module			 -- the name of the module being compiled
	BuiltinNames		 -- so we can avoid going after things
				 -- the compiler already knows about
76
        (MutableVar REAL_WORLD
77
78
79
80
81
82
	 (ModuleToIfaceContents, -- interfaces for individual interface files
	  ModuleToIfaceContents, -- merged interfaces based on module name
				 -- used for extracting info about original names
	  ModuleToIfaceFilePath))

initIfaceCache mod hi_files
83
  = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
84
    return (IfaceCache mod builtinNameMaps iface_var)
85
86
87
88
89
90
91
\end{code}

*********************************************************
*							*
\subsection{Reading interface files}
*							*
*********************************************************
92

93
94
95
96
Return cached info about a Module's interface; otherwise,
read the interface (using our @ModuleToIfaceFilePath@ map
to decide where to look).

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Note: we have two notions of interface
 * the interface for a particular file name
 * the (combined) interface for a particular module name

The idea is that two source files may declare a module
with the same name with the declarations being merged.

This allows us to have file PreludeList.hs producing
PreludeList.hi but defining part of module Prelude.
When PreludeList is imported its contents will be
added to Prelude. In this way all the original names 
for a particular module will be available the imported
decls are renamed.

ToDo: Check duplicate definitons are the same.
ToDo: Check/Merge duplicate pragmas.


115
\begin{code}
116
117
118
119
cachedIface :: IfaceCache
	    -> Bool		-- True  => want merged interface for original name
				-- False => want file interface only
	    -> FAST_STRING	-- item that prompted search (debugging only!)
120
121
	    -> Module
	    -> IO (MaybeErr ParsedIface Error)
122

123
cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
124
  = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
125

126
    case (lookupFM iface_fm modname) of
127
      Just iface -> return (want_iface iface orig_fm)
128
      Nothing    ->
129
130
      	case (lookupFM file_fm modname) of
	  Nothing   -> return (Failed (noIfaceErr modname))
131
	  Just file ->
132
	    readIface file modname item >>= \ read_iface ->
133
	    case read_iface of
134
135
	      Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
				 return (Failed err)
136
137
	      Succeeded iface ->
		let
138
		    iface_fm' = addToFM iface_fm modname iface
139
		    orig_fm'  = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
140
		in
141
		writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
142
143
144
145
		return (want_iface iface orig_fm')
  where
    want_iface iface orig_fm 
      | want_orig_iface
146
147
      = case lookupFM orig_fm modname of
	  Nothing         -> Failed (noOrigIfaceErr modname)
148
149
150
151
152
153
154
155
156
157
158
159
160
          Just orig_iface -> Succeeded orig_iface
      | otherwise
      = Succeeded iface

    iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod

----------
mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
	    (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
  = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
				    ppStr "merged with", ppPStr mod1]) $
    ASSERT(mod1 == mod2)
    ParsedIface mod1
161
	(True, unionBags files2 files1)
162
163
164
165
166
167
168
169
170
171
172
173
174
175
	(panic "mergeIface: module version numbers")
	(panic "mergeIface: source version numbers")	-- Version numbers etc must be extracted from
	(panic "mergeIface: usage version numbers")	-- the merged file interfaces named above
	(panic "mergeIface: decl version numbers")
	(panic "mergeIface: exports")
	(panic "mergeIface: instance modules")
 	(plusFM_C (dup_merge "fixity"      (ppr PprDebug . fixDeclName)) fixes1 fixes2)
	(plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm))    tdefs1 tdefs2)
	(plusFM_C (dup_merge "value"       (ppr PprDebug . idecl_nm))    vdefs1 vdefs2)
	(unionBags idefs1 idefs2)
	(plusFM_C (dup_merge "pragma"      ppStr)			 prags1 prags2)
  where
    dup_merge str ppr_dup dup1 dup2
      = pprTrace "mergeIfaces:"
176
	   	 (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
177
178
179
180
181
182
183
184
			 ppr_dup dup1, ppr_dup dup2]) $
        dup2

    idecl_nm (TypeSig    n _ _)     = n
    idecl_nm (NewTypeSig n _ _ _)   = n
    idecl_nm (DataSig    n _ _ _ _) = n
    idecl_nm (ClassSig   n _ _ _)   = n
    idecl_nm (ValSig     n _ _)	    = n
185
186

----------
187
188
189
190
191
192
193
194
195
196
data CachingResult
  = CachingFail	    Error	  -- tried to find a decl, something went wrong
  | CachingHit	    RdrIfaceDecl  -- got it
  | CachingAvoided  (Maybe (Either RnName RnName))
				  -- didn't look in the interface
				  -- file(s); Nothing => the thing
				  -- *should* be in the source module;
				  -- Just (Left ...) => builtin val name;
				  -- Just (Right ..) => builtin tc name

197
198
cachedDecl :: IfaceCache
	   -> Bool	-- True <=> tycon or class name
199
	   -> OrigName
200
201
202
203
	   -> IO CachingResult

cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _)
	   class_or_tycon name@(OrigName mod str)
204

205
  = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
    if mod == this_mod then 	        -- some i/face has made a reference
	return (CachingAvoided Nothing) -- to something from this module
    else
    let
	b_env	    = if class_or_tycon then b_tc_names else b_val_names
    in
    case (lookupFM b_env name) of
      Just rn -> -- in builtins!
	return (CachingAvoided (Just ((if class_or_tycon then Right else Left) rn)))

      Nothing ->
	cachedIface iface_cache True str mod >>= \ maybe_iface ->
	case maybe_iface of
	  Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
			return (CachingFail err)
	  Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> 
	    case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
	      Just decl -> return (CachingHit  decl)
	      Nothing   -> return (CachingFail (noDeclInIfaceErr mod str))
225
226
227
228

----------
cachedDeclByType :: IfaceCache
		 -> RnName{-NB: diff type than cachedDecl -}
229
		 -> IO CachingResult
230
231
232
233
234

cachedDeclByType iface_cache rn
    -- the idea is: check that, e.g., if we're given an
    -- RnClass, then we really get back a ClassDecl from
    -- the cache (not an RnData, or something silly)
235
  = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn)  >>= \ maybe_decl ->
236
237
    let
	return_maybe_decl = return maybe_decl
238
	return_failed msg = return (CachingFail msg)
239
240
    in
    case maybe_decl of
241
242
243
      CachingAvoided _	  -> return_maybe_decl
      CachingFail io_msg  -> return_failed (ifaceIoErr io_msg rn)
      CachingHit  if_decl ->
244
245
246
247
248
249
	case rn of
	  WiredInId _       -> return_failed (ifaceLookupWiredErr "value" rn)
	  WiredInTyCon _    -> return_failed (ifaceLookupWiredErr "type constructor" rn)
	  RnUnbound _       -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
	  
	  RnSyn _	    -> return_maybe_decl
250
	  RnData _ _ _	    -> return_maybe_decl
251
252
253
254
255
256
257
258
259
	  RnImplicitTyCon _ -> if is_tycon_decl if_decl
			       then return_maybe_decl
			       else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
	  
	  RnClass _ _	    -> return_maybe_decl
	  RnImplicitClass _ -> if is_class_decl if_decl
			       then return_maybe_decl
			       else return_failed (badIfaceLookupErr "class" rn if_decl)
	  
260
261
262
263
264
265
266
	  RnName _	    -> return_maybe_decl
	  RnConstr _ _      -> return_maybe_decl
	  RnField _ _ 	    -> return_maybe_decl
	  RnClassOp _ _	    -> return_maybe_decl
	  RnImplicit _	    -> if is_val_decl if_decl
			       then return_maybe_decl
			       else return_failed (badIfaceLookupErr "value" rn if_decl)
267
268
269
  where
    is_tycon_decl (TypeSig _ _ _)	= True
    is_tycon_decl (NewTypeSig _ _ _ _)	= True
270
    is_tycon_decl (DataSig _ _ _ _ _)	= True
271
272
273
274
275
276
    is_tycon_decl _			= False

    is_class_decl (ClassSig _ _ _ _)	= True
    is_class_decl _			= False

    is_val_decl (ValSig _ _ _)		= True
277
278
279
    is_val_decl (DataSig _ _ _ _ _)	= True	-- may be a constr or field
    is_val_decl (NewTypeSig _ _ _ _)	= True  -- may be a constr
    is_val_decl (ClassSig _ _ _ _)	= True	-- may be a method
280
    is_val_decl _			= False
281
\end{code}
282

283
\begin{code}
284
readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error)
285

286
287
readIface file modname item
  = --hPutStr stderr ("  reading "++file++" ("++ _UNPK_ item ++")") >>
288
    TRY_IO (readFile file)  >>= \ read_result ->
289
    case read_result of
290
      Left  err      -> return (Failed (cannaeReadErr file err))
291
      Right contents -> --hPutStr stderr ".."   >>
292
			let parsed = parseIface contents in
293
			--hPutStr stderr "..\n" >>
294
295
296
			return (
			case parsed of
			  Failed _    -> parsed
297
			  Succeeded p -> Succeeded (init_merge modname p)
298
			)
299
300
301
  where
    init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
      =	ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
302
303
304
305
\end{code}


\begin{code}
306
rnIfaces :: IfaceCache			-- iface cache (mutvar)
307
	 -> [Module]			-- directly imported modules
308
	 -> UniqSupply
309
310
311
312
313
314
315
316
	 -> RnEnv			-- defined (in the source) name env
	 -> RnEnv			-- mentioned (in the source) name env 
	 -> RenamedHsModule		-- module to extend with iface decls
	 -> [RnName]			-- imported names required (really the
					-- same info as in mentioned name env)
					-- Also, all the things we may look up
					-- later by key (Unique).
	 -> IO (RenamedHsModule,	-- extended module
317
		RnEnv,			-- final env (for renaming derivings)
318
		ImplicitEnv,		-- implicit names used (for usage info)
319
		(UsagesMap,VersionsMap,[Module]),	-- usage info
320
		(Bag Error, Bag Warning))
321

322
rnIfaces iface_cache imp_mods us
323
324
325
326
327
328
	 def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
	 occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
	 rn_module@(HsModule modname iface_version exports imports fixities
		      typedecls typesigs classdecls instdecls instsigs
		      defdecls binds sigs src_loc)
	 todo
329
330
  = {-
    pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
331
    pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
332
    pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
333
    pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
334
335
    pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $

336
    pprTrace "rnIfaces:dqual:"     (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
337
    pprTrace "rnIfaces:dunqual:"   (ppCat (map ppPStr (keysFM dunqual))) $
338
    pprTrace "rnIfaces:dtc_qual:"  (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
339
340
341
    pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
    -}

342
    -- do transitive closure to bring in all needed names/defns and insts:
343

344
345
346
347
348
    decls_and_insts todo def_env occ_env empty_return us 
	>>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
	        if_implicits,
	        if_errs_warns),
	       if_final_env) ->
349

350
351
    -- finalize what we want to say we learned about the
    -- things we used
352
    finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
353
354
	\ usage_stuff@(usage_info, version_info, instance_mods) ->

355
    return (HsModule modname iface_version exports imports fixities
356
357
358
359
360
361
362
		 (typedecls ++ if_typedecls)
		 typesigs
		 (classdecls ++ if_classdecls)
		 (instdecls  ++ if_instdecls)
		 instsigs defdecls binds
		 (sigs ++ if_sigs)
		 src_loc,
363
364
	    if_final_env,
	    if_implicits,
365
	    usage_stuff,
366
	    if_errs_warns)
367
  where
368
    decls_and_insts todo def_env occ_env to_return us
369
370
371
372
      =	let
	    (us1,us2) = splitUniqSupply us
	in
	do_decls todo	     		 -- initial batch of names to process
373
374
375
376
377
378
379
380
381
382
383
	 	 (def_env, occ_env, us1) -- init stuff down
	 	 to_return		 -- acc results
	   >>= \ (decls_return,
		  decls_def_env,
		  decls_occ_env) ->

	cacheInstModules iface_cache imp_mods >>= \ errs ->

	do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
		 (add_errs errs decls_return) us2

384
    --------
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
    do_insts def_env occ_env prev_env done_insts to_return us
      | size_tc_env occ_env == size_tc_env prev_env
      = return (to_return, occ_env)

      | otherwise
      = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
	   >>= \ (insts_return,
		  new_insts,
		  insts_occ_env,
		  new_unknowns) ->

	do_decls new_unknowns	  		-- new batch of names to process
	 	 (def_env, insts_occ_env, us2) 	-- init stuff down
	 	 insts_return		 	-- acc results
	   >>= \ (decls_return,
		  decls_def_env,
		  decls_occ_env) ->

	do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
      where
	(us1,us') = splitUniqSupply us
	(us2,us3) = splitUniqSupply us'

	size_tc_env ((_, _, qual, unqual), _)
	  = sizeFM qual + sizeFM unqual
410
411


412
413
414
415
416
417
418
419
420
421
422
423
424
425
    do_decls :: [RnName]	-- Names we're looking for; we keep adding/deleting
			  	-- from this list; we're done when empty (nothing
			  	-- more needs to be looked for)
	     -> Go_Down	 	-- see defn below
	     -> To_Return	-- accumulated result
	     -> IO (To_Return,
		    RnEnv,	-- extended decl env
		    RnEnv)	-- extended occ env

    do_decls to_find@[] down to_return
      = return (to_return, defenv down, occenv down)

    do_decls to_find@(n:ns) down to_return 
      = case (lookup_defd down n) of
426
427
	  Just  _ -> -- previous processing must've found the stuff for this name;
		     -- continue with the rest:
428
429
		     -- pprTrace "do_decls:done:" (ppr PprDebug n) $
		     do_decls ns down to_return
430

431
	  Nothing
432
	   | moduleOf (origName "do_decls" n) == modname ->
433
		     -- avoid looking in interface for the module being compiled
434
435
		     --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
		     do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
436

437
438
	   | otherwise ->
		     -- OK, see what the cache has for us...
439

440
441
	     cachedDeclByType iface_cache n >>= \ maybe_ans ->
	     case maybe_ans of
442
443
444
445
446
447
448
	       CachingAvoided _ ->
		 pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
		 do_decls ns down to_return

	       CachingFail err -> -- add the error, but keep going:
		 --pprTrace "do_decls:cache error:" (ppr PprDebug n) $
		 do_decls ns down (add_err err to_return)
449

450
	       CachingHit iface_decl -> -- something needing renaming!
451
		 let
452
		    (us1, us2) = splitUniqSupply (uniqsupply down)
453
454
		 in
		 case (initRn False{-iface-} modname (occenv down) us1 (
455
			setExtraRn emptyUFM{-no fixities-} $
456
457
458
459
460
			rnIfaceDecl iface_decl)) of {
		  ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
		    let
			new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
		    in
461
462
463
464
465
466
467
468
469
470
471
472
473
474
		    {-
		    pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
			, ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
			, ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
			, ppCat [ppStr "defd  tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
			]) $
		    -}
		    do_decls (new_unknowns ++ ns)
			     (add_occs       if_defd if_implicits $
			       new_uniqsupply us2 down)
			     (add_decl	     if_decl		$
			       add_implicits if_implicits	$
			        add_errs     if_errs		$
			         add_warns   if_warns to_return)
475
	         }
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491

-----------
type Go_Down   = (RnEnv,	-- stuff we already have defns for;
				-- to check quickly if we've already
				-- found something for the name under consideration,
			  	-- due to previous processing.
				-- It starts off just w/ the defns for
				-- the things in this module.
		  RnEnv,	-- occurrence env; this gets added to as
				-- we process new iface decls.  It includes
				-- entries for *all* occurrences, including those
				-- for which we have definitions.
		  UniqSupply	-- the obvious
		 )

lookup_defd (def_env, _, _) n
492
493
494
  = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env
	(case (origName "lookup_defd" n) of { OrigName m s -> Qual m s })
	-- this is hack because we are reusing the RnEnv technology
495

496
defenv	   (def_env, _, _) = def_env
497
498
499
500
501
502
503
occenv	   (_, occ_env, _) = occ_env
uniqsupply (_, _,      us) = us

new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)

add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
  = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
504
505
    (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
--  ASSERT(isEmptyBag def_dups)
506
    let
507
508
509
510
511
	de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
	-- again, this hackery because we are reusing the RnEnv technology

	val_occs = val_defds ++ de_orig val_imps
	tc_occs  = tc_defds  ++ de_orig tc_imps
512
513
514
515
    in
    case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->

--  ASSERT(isEmptyBag occ_dups)
516
--  False because we may get a dup on the name we just shoved in
517
518
519
520

    (new_def_env, new_occ_env, us) }}

----------------
521
type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
522
523
524
525
526
		  ImplicitEnv,	-- new names used implicitly
		  (Bag Error, Bag Warning)
		 )

empty_return :: To_Return
527
empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
528

529
add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
530
  = case decl of
531
532
533
534
535
536
      AddedTy	 t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
      AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
      AddedSig	 s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)

add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
  = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
537
538

add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
539
  = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
540
541
542

add_err  err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag`   err,warns))
add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
543
add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
544
545
546
547
548
549
550
551
552
553
add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
\end{code}

\begin{code}
data AddedDecl -- purely local
  = AddedTy	RenamedTyDecl
  | AddedClass	RenamedClassDecl
  | AddedSig	RenamedSig

rnIfaceDecl :: RdrIfaceDecl
554
	    -> RnM_Fixes REAL_WORLD
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
		   (AddedDecl,	-- the resulting decl to add to the pot
		    ([(RdrName,RnName)], [(RdrName,RnName)]),
				-- new val/tycon-class names that have
				-- *been defined* while processing this decl
		    ImplicitEnv -- new implicit val/tycon-class names that we
				-- stumbled into
		   )

rnIfaceDecl (TypeSig tc _ decl)
  = rnTyDecl    decl	`thenRn` \ rn_decl   ->
    lookupTyCon tc	`thenRn` \ rn_tc     ->
    getImplicitUpRn	`thenRn` \ mentioned ->
    let
	defds = ([], [(tc, rn_tc)])
	implicits = mentioned `sub` defds
    in
    returnRn (AddedTy rn_decl, defds, implicits)

rnIfaceDecl (NewTypeSig tc dc _ decl)
  = rnTyDecl    decl	`thenRn` \ rn_decl   ->
    lookupTyCon tc	`thenRn` \ rn_tc     ->
    lookupValue dc	`thenRn` \ rn_dc     ->
    getImplicitUpRn	`thenRn` \ mentioned ->
    let
	defds = ([(dc, rn_dc)], [(tc, rn_tc)])
	implicits = mentioned `sub` defds
    in
    returnRn (AddedTy rn_decl, defds, implicits)

584
rnIfaceDecl (DataSig tc dcs fcs _ decl)
585
586
587
  = rnTyDecl    decl		`thenRn` \ rn_decl   ->
    lookupTyCon tc		`thenRn` \ rn_tc     ->
    mapRn lookupValue dcs	`thenRn` \ rn_dcs    ->
588
    mapRn lookupValue fcs	`thenRn` \ rn_fcs    ->
589
590
    getImplicitUpRn		`thenRn` \ mentioned ->
    let
591
	defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
	implicits = mentioned `sub` defds
    in
    returnRn (AddedTy rn_decl, defds, implicits)

rnIfaceDecl (ClassSig clas ops _ decl)
  = rnClassDecl decl			`thenRn` \ rn_decl   ->
    lookupClass clas			`thenRn` \ rn_clas   ->
    mapRn (lookupClassOp rn_clas) ops	`thenRn` \ rn_ops    ->
    getImplicitUpRn			`thenRn` \ mentioned ->
    let
	defds = (ops `zip` rn_ops, [(clas, rn_clas)])
	implicits = mentioned `sub` defds
    in
    returnRn (AddedClass rn_decl, defds, implicits)

rnIfaceDecl (ValSig f src_loc ty)
    -- should rename_sig in RnBinds be used here? ToDo
  = lookupValue f			`thenRn` \ rn_f  ->
    -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
    rnPolyType nullTyVarNamesEnv ty	`thenRn` \ rn_ty ->
    getImplicitUpRn			`thenRn` \ mentioned ->
    let
	defds = ([(f, rn_f)], [])
	implicits = mentioned `sub` defds
    in
    returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)

----
sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv

sub (val_ment, tc_ment) (val_defds, tc_defds)
623
624
  = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
     delListFromFM tc_ment  (map (qualToOrigName . fst) tc_defds))
625
626
\end{code}

627
628
% ------------------------------

629
630
631
632
@cacheInstModules@: cache instance modules specified in imports

\begin{code}
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
633
634

cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
635
  = readVar iface_var		ST_THEN \ (iface_fm, _, _) ->
636
637
638
    let
	imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
	(imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
639
        get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
640
    in
641
    --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
642
    accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) imp_imods) >>= \ err_or_ifaces ->
643
644
645
646
647

    -- Sanity Check:
    -- Assert that instance modules given by direct imports contains
    -- instance modules extracted from all visited modules

648
    readVar iface_var		ST_THEN \ (all_iface_fm, _, _) ->
649
650
651
652
653
654
655
656
657
658
659
660
661
662
    let
	all_ifaces     = eltsFM all_iface_fm
	(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
    in
    ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)

    return (bag_errs err_or_ifaces)
  where
    bag_errs [] = emptyBag
    bag_errs (Failed err :rest) = err `consBag` bag_errs rest
    bag_errs (Succeeded _:rest) = bag_errs rest
\end{code}


663
664
665
@rnIfaceInstStuff@: Deal with instance declarations from interface files.

\begin{code}
666
type InstanceEnv = FiniteMap (OrigName, OrigName) Int
667

668
rnIfaceInstStuff
669
	:: IfaceCache		-- all about ifaces we've read
670
671
	-> Module
	-> UniqSupply
672
673
674
675
676
677
678
679
	-> RnEnv		-- current occ env
	-> InstanceEnv  	-- instances for these tycon/class pairs done
	-> To_Return
	-> IO (To_Return,
	       InstanceEnv,	-- extended instance env
	       RnEnv,		-- final occ env
	       [RnName])	-- new unknown names

680
rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_inst_env to_return
681
682
  = -- all the instance decls we might even want to consider
    -- are in the ParsedIfaces that are in our cache
683

684
    readVar iface_var	ST_THEN \ (_, orig_iface_fm, _) ->
685
    let
686
	all_ifaces	  = eltsFM orig_iface_fm
687
688
	all_insts	  = concat (map get_insts all_ifaces)
	interesting_insts = filter want_inst all_insts
689

690
691
	-- Sanity Check:
	-- Assert that there are no more instances for the done instances
692

693
	claim_done       = filter is_done_inst all_insts
694
	claim_done_env   = foldr add_done_inst emptyFM claim_done
695

696
	has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
697
    in
698
699
700
701
702
703
    {-
      pprTrace "all_insts:\n"         (ppr_insts (bagToList all_insts)) $
      pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
    -}
    ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
    ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
704

705
706
    case (initRn False{-iface-} modname occ_env us (
	    setExtraRn emptyUFM{-no fixities-}	$
707
708
	    mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
	    getImplicitUpRn			`thenRn` \ implicits ->
709
710
711
712
713
714
715
716
717
718
	    returnRn (insts, implicits))) of {
      ((if_insts, if_implicits), if_errs, if_warns) ->

	return (add_insts      if_insts		$
		 add_implicits if_implicits	$
		  add_errs     if_errs		$
		   add_warns   if_warns to_return,
		foldr add_done_inst done_inst_env interesting_insts,
		add_imp_occs if_implicits occ_env,
		eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
719
720
    }
  where
721
    get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts]
722

723
724
    tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon)

725
    add_done_inst (_, InstSig clas tycon _ _) inst_env
726
      = addToFM_C (+) inst_env (tycon_class clas tycon) 1
727

728
    is_done_inst (_, InstSig clas tycon _ _)
729
      = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
730
731

    add_imp_occs (val_imps, tc_imps) occ_env
732
      = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of
733
734
     	  (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
				     ext_occ_env
735
736
737
      where
	de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
	-- again, this hackery because we are reusing the RnEnv technology
738

739
    want_inst i@(imod, InstSig clas tycon _ _)
740
741
      = -- it's a "good instance" (one to hang onto) if we have a
	-- chance of referring to *both* the class and tycon later on ...
742
	--pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
743
	mentionable tycon && mentionable clas && not (is_done_inst i)
744
745
      where
	mentionable nm
746
	  = case lookupTcRnEnv occ_env nm of
747
748
	      Just  _ -> True
	      Nothing -> -- maybe it's builtin
749
		let orig = qualToOrigName nm in
750
		case (lookupFM builtinTcNamesMap orig) of
751
		  Just  _ -> True
752
		  Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
753
754
755
\end{code}

\begin{code}
756
rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
757

758
rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
759
\end{code}
760
761

\begin{code}
762
763
764
type BigMaps = (FiniteMap Module Version, -- module-version map
		FiniteMap (FAST_STRING,Module) Version) -- ordinary version map

765
finalIfaceInfo ::
766
	   IfaceCache			-- iface cache
767
	-> Module			-- this module's name
768
769
770
771
772
773
	-> RnEnv
	-> [RenamedInstDecl]
--	-> [RnName]			-- all imported names required
--	-> [Module]			-- directly imported modules
	-> IO (UsagesMap,
	       VersionsMap,		-- info about version numbers
774
	       [Module])		-- special instance modules
775

776
finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
777
  =
778
--  pprTrace "usageIf:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
779
--  pprTrace "usageIf:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
780
--  pprTrace "usageIf:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
781
--  pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
782
    readVar iface_var	ST_THEN \ (_, orig_iface_fm, _) ->
783
    let
784
785
786
787
788
789
790
791
792
	all_ifaces = eltsFM orig_iface_fm
	-- all the interfaces we have looked at

	big_maps
	  -- combine all the version maps we have seen into maps to
	  -- (a) lookup a module-version number, lookup an entity's
	  -- individual version number
	  = foldr mk_map (emptyFM,emptyFM) all_ifaces

793
	val_stuff@(val_usages, val_versions)
794
	  = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
795

796
	(all_usages, all_versions)
797
	  = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
798
799
800
    in
    return (all_usages, all_versions, [])
  where
801
802
803
804
805
806
807
    mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
      = (addToFM     mv_map  m mv, -- add this module
	 addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])

    -----------------------
    process_item :: BigMaps
		 -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
808
809
810
		 -> (UsagesMap, VersionsMap)	   -- input
		 -> (UsagesMap, VersionsMap)	   -- output

811
    process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
812
813
814
815
816
      | irrelevant rn
      = as_before
      | m == modname -- this module => add to "versions"
      =	(usages, addToFM versions n 1{-stub-})
      | otherwise  -- from another module => add to "usages"
817
818
819
      = case (add_to_usages usages key) of
	  Nothing	  -> as_before
	  Just new_usages -> (new_usages, versions)
820
821
      where
	add_to_usages usages key@(n,m)
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
	  = case (lookupFM big_mv_map m) of
	      Nothing -> Nothing
	      Just mv ->
	        case (lookupFM big_version_map key) of
		  Nothing -> Nothing
		  Just kv ->
		    Just $ addToFM usages m (
			case (lookupFM usages m) of
			  Nothing -> -- nothing for this module yet...
			    (mv, unitFM n kv)

			  Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
			    ASSERT(mversion == mv)
			    (mversion, addToFM mstuff n kv)
		    )
837
838
839
840

    irrelevant (RnConstr  _ _) = True	-- We don't report these in their
    irrelevant (RnField   _ _) = True	-- own right in usages/etc.
    irrelevant (RnClassOp _ _) = True
841
    irrelevant (RnImplicit  n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr
842
843
    irrelevant _	       = False

844
845
846
847
\end{code}


\begin{code}
848
thisModImplicitWarn mod n sty
849
  = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
850

851
noIfaceErr mod sty
852
853
  = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]

854
855
856
noOrigIfaceErr mod sty
  = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]

857
858
859
860
861
862
863
864
865
866
867
noDeclInIfaceErr mod str sty
  = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
	       ppPStr mod, ppStr ".", ppPStr str]

cannaeReadErr file err sty
  = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]

ifaceLookupWiredErr msg n sty
  = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]

badIfaceLookupErr msg name decl sty
868
  = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
869
870
871

ifaceIoErr io_msg rn sty
  = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
872
\end{code}