RnIfaces.lhs 31.8 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		( builtinNameInfo, 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
85
86
    return (IfaceCache mod b_names iface_var)
  where
    b_names = case builtinNameInfo of (b_names,_,_) -> b_names
87
88
89
90
91
92
93
\end{code}

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

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

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
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.


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

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

128
    case (lookupFM iface_fm modname) of
129
      Just iface -> return (want_iface iface orig_fm)
130
      Nothing    ->
131
132
      	case (lookupFM file_fm modname) of
	  Nothing   -> return (Failed (noIfaceErr modname))
133
	  Just file ->
134
	    readIface file modname item >>= \ read_iface ->
135
	    case read_iface of
136
137
	      Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
				 return (Failed err)
138
139
	      Succeeded iface ->
		let
140
		    iface_fm' = addToFM iface_fm modname iface
141
		    orig_fm'  = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
142
		in
143
		writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
144
145
146
147
		return (want_iface iface orig_fm')
  where
    want_iface iface orig_fm 
      | want_orig_iface
148
149
      = case lookupFM orig_fm modname of
	  Nothing         -> Failed (noOrigIfaceErr modname)
150
151
152
153
154
155
156
157
158
159
160
161
162
          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
163
	(True, unionBags files2 files1)
164
165
166
167
168
169
170
171
172
173
174
175
176
177
	(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:"
178
	   	 (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
179
180
181
182
183
184
185
186
			 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
187
188

----------
189
190
191
192
193
194
195
196
197
198
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

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

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

207
  = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
    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))
227
228
229
230

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

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)
237
  = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn)  >>= \ maybe_decl ->
238
239
    let
	return_maybe_decl = return maybe_decl
240
	return_failed msg = return (CachingFail msg)
241
242
    in
    case maybe_decl of
243
244
245
      CachingAvoided _	  -> return_maybe_decl
      CachingFail io_msg  -> return_failed (ifaceIoErr io_msg rn)
      CachingHit  if_decl ->
246
247
248
249
250
251
	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
252
	  RnData _ _ _	    -> return_maybe_decl
253
254
255
256
257
258
259
260
261
	  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)
	  
262
263
264
265
266
267
268
	  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)
269
270
271
  where
    is_tycon_decl (TypeSig _ _ _)	= True
    is_tycon_decl (NewTypeSig _ _ _ _)	= True
272
    is_tycon_decl (DataSig _ _ _ _ _)	= True
273
274
275
276
277
278
    is_tycon_decl _			= False

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

    is_val_decl (ValSig _ _ _)		= True
279
280
281
    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
282
    is_val_decl _			= False
283
\end{code}
284

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

288
289
readIface file modname item
  = --hPutStr stderr ("  reading "++file++" ("++ _UNPK_ item ++")") >>
290
    TRY_IO (readFile file)  >>= \ read_result ->
291
    case read_result of
292
      Left  err      -> return (Failed (cannaeReadErr file err))
293
      Right contents -> --hPutStr stderr ".."   >>
294
			let parsed = parseIface contents in
295
			--hPutStr stderr "..\n" >>
296
297
298
			return (
			case parsed of
			  Failed _    -> parsed
299
			  Succeeded p -> Succeeded (init_merge modname p)
300
			)
301
302
303
  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
304
305
306
307
\end{code}


\begin{code}
308
rnIfaces :: IfaceCache			-- iface cache (mutvar)
309
	 -> [Module]			-- directly imported modules
310
	 -> UniqSupply
311
312
313
314
315
316
317
318
	 -> 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
319
		RnEnv,			-- final env (for renaming derivings)
320
		ImplicitEnv,		-- implicit names used (for usage info)
321
		(UsagesMap,VersionsMap,[Module]),	-- usage info
322
		(Bag Error, Bag Warning))
323

324
rnIfaces iface_cache imp_mods us
325
326
327
328
329
330
	 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
331
332
  = {-
    pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
333
    pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
334
    pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
335
    pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
336
337
    pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $

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

344
    -- do transitive closure to bring in all needed names/defns and insts:
345

346
347
348
349
350
    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) ->
351

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

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

386
    --------
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
    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
412
413


414
415
416
417
418
419
420
421
422
423
424
425
426
427
    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
428
429
	  Just  _ -> -- previous processing must've found the stuff for this name;
		     -- continue with the rest:
430
431
		     -- pprTrace "do_decls:done:" (ppr PprDebug n) $
		     do_decls ns down to_return
432

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

439
440
	   | otherwise ->
		     -- OK, see what the cache has for us...
441

442
443
	     cachedDeclByType iface_cache n >>= \ maybe_ans ->
	     case maybe_ans of
444
445
446
447
448
449
450
	       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)
451

452
	       CachingHit iface_decl -> -- something needing renaming!
453
		 let
454
		    (us1, us2) = splitUniqSupply (uniqsupply down)
455
456
		 in
		 case (initRn False{-iface-} modname (occenv down) us1 (
457
			setExtraRn emptyUFM{-no fixities-} $
458
459
460
461
462
			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
463
464
465
466
467
468
469
470
471
472
473
474
475
476
		    {-
		    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)
477
	         }
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493

-----------
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
494
495
496
  = (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
497

498
defenv	   (def_env, _, _) = def_env
499
500
501
502
503
504
505
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) ->
506
507
    (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
--  ASSERT(isEmptyBag def_dups)
508
    let
509
510
511
512
513
	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
514
515
516
517
    in
    case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->

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

    (new_def_env, new_occ_env, us) }}

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

empty_return :: To_Return
529
empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
530

531
add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
532
  = case decl of
533
534
535
536
537
538
      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)
539
540

add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
541
  = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
542
543
544

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))
545
add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
546
547
548
549
550
551
552
553
554
555
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
556
	    -> RnM_Fixes REAL_WORLD
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
584
585
		   (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)

586
rnIfaceDecl (DataSig tc dcs fcs _ decl)
587
588
589
  = rnTyDecl    decl		`thenRn` \ rn_decl   ->
    lookupTyCon tc		`thenRn` \ rn_tc     ->
    mapRn lookupValue dcs	`thenRn` \ rn_dcs    ->
590
    mapRn lookupValue fcs	`thenRn` \ rn_fcs    ->
591
592
    getImplicitUpRn		`thenRn` \ mentioned ->
    let
593
	defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
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
623
624
	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)
625
626
  = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
     delListFromFM tc_ment  (map (qualToOrigName . fst) tc_defds))
627
628
\end{code}

629
630
% ------------------------------

631
632
633
634
@cacheInstModules@: cache instance modules specified in imports

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

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

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

650
    readVar iface_var		ST_THEN \ (all_iface_fm, _, _) ->
651
652
653
654
655
656
657
658
659
660
661
662
663
664
    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}


665
666
667
@rnIfaceInstStuff@: Deal with instance declarations from interface files.

\begin{code}
668
type InstanceEnv = FiniteMap (OrigName, OrigName) Int
669

670
rnIfaceInstStuff
671
	:: IfaceCache		-- all about ifaces we've read
672
673
	-> Module
	-> UniqSupply
674
675
676
677
678
679
680
681
	-> 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

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

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

692
693
	-- Sanity Check:
	-- Assert that there are no more instances for the done instances
694

695
	claim_done       = filter is_done_inst all_insts
696
	claim_done_env   = foldr add_done_inst emptyFM claim_done
697

698
	has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
699
    in
700
701
702
703
704
705
    {-
      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))
706

707
708
    case (initRn False{-iface-} modname occ_env us (
	    setExtraRn emptyUFM{-no fixities-}	$
709
710
	    mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
	    getImplicitUpRn			`thenRn` \ implicits ->
711
712
713
714
715
716
717
718
719
720
	    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))
721
722
    }
  where
723
    get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts]
724

725
726
    tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon)

727
    add_done_inst (_, InstSig clas tycon _ _) inst_env
728
      = addToFM_C (+) inst_env (tycon_class clas tycon) 1
729

730
    is_done_inst (_, InstSig clas tycon _ _)
731
      = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
732
733

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

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

    (b_tc_names, b_keys) -- pretty UGLY ...
      = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
758
{-
759
760
761
762
763
    ppr_insts insts
      = ppAboves (map ppr_inst insts)
      where
	ppr_inst (InstSig c t _ inst_decl)
	  = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
764
-}
765
766
767
\end{code}

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

770
rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
771
\end{code}
772
773

\begin{code}
774
775
776
type BigMaps = (FiniteMap Module Version, -- module-version map
		FiniteMap (FAST_STRING,Module) Version) -- ordinary version map

777
finalIfaceInfo ::
778
	   IfaceCache			-- iface cache
779
	-> Module			-- this module's name
780
781
782
783
784
785
	-> RnEnv
	-> [RenamedInstDecl]
--	-> [RnName]			-- all imported names required
--	-> [Module]			-- directly imported modules
	-> IO (UsagesMap,
	       VersionsMap,		-- info about version numbers
786
	       [Module])		-- special instance modules
787

788
finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
789
  =
790
--  pprTrace "usageIf:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
791
--  pprTrace "usageIf:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
792
--  pprTrace "usageIf:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
793
--  pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
794
    readVar iface_var	ST_THEN \ (_, orig_iface_fm, _) ->
795
    let
796
797
798
799
800
801
802
803
804
	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

805
	val_stuff@(val_usages, val_versions)
806
	  = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
807

808
	(all_usages, all_versions)
809
	  = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
810
811
812
    in
    return (all_usages, all_versions, [])
  where
813
814
815
816
817
818
819
    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
820
821
822
		 -> (UsagesMap, VersionsMap)	   -- input
		 -> (UsagesMap, VersionsMap)	   -- output

823
    process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
824
825
826
827
828
      | irrelevant rn
      = as_before
      | m == modname -- this module => add to "versions"
      =	(usages, addToFM versions n 1{-stub-})
      | otherwise  -- from another module => add to "usages"
829
830
831
      = case (add_to_usages usages key) of
	  Nothing	  -> as_before
	  Just new_usages -> (new_usages, versions)
832
833
      where
	add_to_usages usages key@(n,m)
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
	  = 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)
		    )
849
850
851
852

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

856
857
858
859
\end{code}


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

863
noIfaceErr mod sty
864
865
  = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]

866
867
868
noOrigIfaceErr mod sty
  = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]

869
870
871
872
873
874
875
876
877
878
879
880
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
  = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
881
882
883

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