RnIfaces.lhs 31.6 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
import PreludeGlaST	( thenPrimIO, seqPrimIO, newVar, readVar, writeVar, MutableVar(..) )
19

20
import HsSyn
21
import HsPragmas	( noGenPragmas )
22
23
24
25
import RdrHsSyn
import RnHsSyn

import RnMonad
26
import RnSource		( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
27
import RnUtils		( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
28
import ParseIface	( parseIface )
29
30
31
import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
			  VersionsMap(..), UsagesMap(..)
			)
32

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

\begin{code}
55
56
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
57

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
data IfaceCache
  = IfaceCache
	Module			 -- the name of the module being compiled
	BuiltinNames		 -- so we can avoid going after things
				 -- the compiler already knows about
        (MutableVar _RealWorld
	 (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
  = newVar (emptyFM,emptyFM,hi_files) `thenPrimIO` \ iface_var ->
    return (IfaceCache mod b_names iface_var)
  where
    b_names = case builtinNameInfo of (b_names,_,_) -> b_names
74
75
76
77
78
79
80
\end{code}

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

82
83
84
85
Return cached info about a Module's interface; otherwise,
read the interface (using our @ModuleToIfaceFilePath@ map
to decide where to look).

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
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.


104
\begin{code}
105
106
107
108
cachedIface :: IfaceCache
	    -> Bool		-- True  => want merged interface for original name
				-- False => want file interface only
	    -> FAST_STRING	-- item that prompted search (debugging only!)
109
110
	    -> Module
	    -> IO (MaybeErr ParsedIface Error)
111

112
113
cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
  = readVar iface_var `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
114

115
    case (lookupFM iface_fm modname) of
116
      Just iface -> return (want_iface iface orig_fm)
117
      Nothing    ->
118
119
      	case (lookupFM file_fm modname) of
	  Nothing   -> return (Failed (noIfaceErr modname))
120
	  Just file ->
121
	    readIface file modname item >>= \ read_iface ->
122
	    case read_iface of
123
124
	      Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
				 return (Failed err)
125
126
	      Succeeded iface ->
		let
127
		    iface_fm' = addToFM iface_fm modname iface
128
		    orig_fm'  = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
129
		in
130
		writeVar iface_var (iface_fm', orig_fm', file_fm) `seqPrimIO`
131
132
133
134
		return (want_iface iface orig_fm')
  where
    want_iface iface orig_fm 
      | want_orig_iface
135
136
      = case lookupFM orig_fm modname of
	  Nothing         -> Failed (noOrigIfaceErr modname)
137
138
139
140
141
142
143
144
145
146
147
148
149
          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
150
	(True, unionBags files2 files1)
151
152
153
154
155
156
157
158
159
160
161
162
163
164
	(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:"
165
	   	 (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
166
167
168
169
170
171
172
173
			 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
174
175

----------
176
177
178
179
180
181
182
183
184
185
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

186
187
cachedDecl :: IfaceCache
	   -> Bool	-- True <=> tycon or class name
188
	   -> OrigName
189
190
191
192
	   -> IO CachingResult

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

194
  = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
    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))
214
215
216
217

----------
cachedDeclByType :: IfaceCache
		 -> RnName{-NB: diff type than cachedDecl -}
218
		 -> IO CachingResult
219
220
221
222
223

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)
224
  = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn)  >>= \ maybe_decl ->
225
226
    let
	return_maybe_decl = return maybe_decl
227
	return_failed msg = return (CachingFail msg)
228
229
    in
    case maybe_decl of
230
231
232
      CachingAvoided _	  -> return_maybe_decl
      CachingFail io_msg  -> return_failed (ifaceIoErr io_msg rn)
      CachingHit  if_decl ->
233
234
235
236
237
238
	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
239
	  RnData _ _ _	    -> return_maybe_decl
240
241
242
243
244
245
246
247
248
	  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)
	  
249
250
251
252
253
254
255
	  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)
256
257
258
  where
    is_tycon_decl (TypeSig _ _ _)	= True
    is_tycon_decl (NewTypeSig _ _ _ _)	= True
259
    is_tycon_decl (DataSig _ _ _ _ _)	= True
260
261
262
263
264
265
    is_tycon_decl _			= False

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

    is_val_decl (ValSig _ _ _)		= True
266
267
268
    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
269
    is_val_decl _			= False
270
\end{code}
271

272
\begin{code}
273
readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error)
274

275
276
readIface file modname item
  = --hPutStr stderr ("  reading "++file++" ("++ _UNPK_ item ++")") >>
277
    readFile file		`thenPrimIO` \ read_result ->
278
    case read_result of
279
      Left  err      -> return (Failed (cannaeReadErr file err))
280
      Right contents -> --hPutStr stderr ".."   >>
281
			let parsed = parseIface contents in
282
			--hPutStr stderr "..\n" >>
283
284
285
			return (
			case parsed of
			  Failed _    -> parsed
286
			  Succeeded p -> Succeeded (init_merge modname p)
287
			)
288
289
290
  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
291
292
293
294
\end{code}


\begin{code}
295
rnIfaces :: IfaceCache			-- iface cache (mutvar)
296
	 -> [Module]			-- directly imported modules
297
	 -> UniqSupply
298
299
300
301
302
303
304
305
	 -> 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
306
		RnEnv,			-- final env (for renaming derivings)
307
		ImplicitEnv,		-- implicit names used (for usage info)
308
		(UsagesMap,VersionsMap,[Module]),	-- usage info
309
		(Bag Error, Bag Warning))
310

311
rnIfaces iface_cache imp_mods us
312
313
314
315
316
317
	 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
318
319
  = {-
    pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
320
    pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
321
    pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
322
    pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
323
324
    pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $

325
    pprTrace "rnIfaces:dqual:"     (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
326
    pprTrace "rnIfaces:dunqual:"   (ppCat (map ppPStr (keysFM dunqual))) $
327
    pprTrace "rnIfaces:dtc_qual:"  (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
328
329
330
    pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
    -}

331
    -- do transitive closure to bring in all needed names/defns and insts:
332

333
334
335
336
337
    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) ->
338

339
340
    -- finalize what we want to say we learned about the
    -- things we used
341
    finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
342
343
	\ usage_stuff@(usage_info, version_info, instance_mods) ->

344
    return (HsModule modname iface_version exports imports fixities
345
346
347
348
349
350
351
		 (typedecls ++ if_typedecls)
		 typesigs
		 (classdecls ++ if_classdecls)
		 (instdecls  ++ if_instdecls)
		 instsigs defdecls binds
		 (sigs ++ if_sigs)
		 src_loc,
352
353
	    if_final_env,
	    if_implicits,
354
	    usage_stuff,
355
	    if_errs_warns)
356
  where
357
    decls_and_insts todo def_env occ_env to_return us
358
359
360
361
      =	let
	    (us1,us2) = splitUniqSupply us
	in
	do_decls todo	     		 -- initial batch of names to process
362
363
364
365
366
367
368
369
370
371
372
	 	 (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

373
    --------
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    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
399
400


401
402
403
404
405
406
407
408
409
410
411
412
413
414
    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
415
416
	  Just  _ -> -- previous processing must've found the stuff for this name;
		     -- continue with the rest:
417
418
		     -- pprTrace "do_decls:done:" (ppr PprDebug n) $
		     do_decls ns down to_return
419

420
	  Nothing
421
	   | moduleOf (origName "do_decls" n) == modname ->
422
		     -- avoid looking in interface for the module being compiled
423
424
		     --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
		     do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
425

426
427
	   | otherwise ->
		     -- OK, see what the cache has for us...
428

429
430
	     cachedDeclByType iface_cache n >>= \ maybe_ans ->
	     case maybe_ans of
431
432
433
434
435
436
437
	       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)
438

439
	       CachingHit iface_decl -> -- something needing renaming!
440
		 let
441
		    (us1, us2) = splitUniqSupply (uniqsupply down)
442
443
		 in
		 case (initRn False{-iface-} modname (occenv down) us1 (
444
			setExtraRn emptyUFM{-no fixities-} $
445
446
447
448
449
			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
450
451
452
453
454
455
456
457
458
459
460
461
462
463
		    {-
		    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)
464
	         }
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

-----------
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
481
482
483
  = (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
484

485
defenv	   (def_env, _, _) = def_env
486
487
488
489
490
491
492
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) ->
493
494
    (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
--  ASSERT(isEmptyBag def_dups)
495
    let
496
497
498
499
500
	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
501
502
503
504
    in
    case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->

--  ASSERT(isEmptyBag occ_dups)
505
--  False because we may get a dup on the name we just shoved in
506
507
508
509

    (new_def_env, new_occ_env, us) }}

----------------
510
type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
511
512
513
514
515
		  ImplicitEnv,	-- new names used implicitly
		  (Bag Error, Bag Warning)
		 )

empty_return :: To_Return
516
empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
517

518
add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
519
  = case decl of
520
521
522
523
524
525
      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)
526
527

add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
528
  = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
529
530
531

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))
532
add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
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
	    -> RnM_Fixes _RealWorld
		   (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)

573
rnIfaceDecl (DataSig tc dcs fcs _ decl)
574
575
576
  = rnTyDecl    decl		`thenRn` \ rn_decl   ->
    lookupTyCon tc		`thenRn` \ rn_tc     ->
    mapRn lookupValue dcs	`thenRn` \ rn_dcs    ->
577
    mapRn lookupValue fcs	`thenRn` \ rn_fcs    ->
578
579
    getImplicitUpRn		`thenRn` \ mentioned ->
    let
580
	defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
	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)
612
613
  = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
     delListFromFM tc_ment  (map (qualToOrigName . fst) tc_defds))
614
615
\end{code}

616
617
% ------------------------------

618
619
620
621
@cacheInstModules@: cache instance modules specified in imports

\begin{code}
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
622
623
624

cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
  = readVar iface_var		`thenPrimIO` \ (iface_fm, _, _) ->
625
626
627
    let
	imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
	(imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
628
        get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
629
    in
630
    --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
631
    accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) imp_imods) >>= \ err_or_ifaces ->
632
633
634
635
636

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

637
    readVar iface_var		`thenPrimIO` \ (all_iface_fm, _, _) ->
638
639
640
641
642
643
644
645
646
647
648
649
650
651
    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}


652
653
654
@rnIfaceInstStuff@: Deal with instance declarations from interface files.

\begin{code}
655
type InstanceEnv = FiniteMap (OrigName, OrigName) Int
656

657
rnIfaceInstStuff
658
	:: IfaceCache		-- all about ifaces we've read
659
660
	-> Module
	-> UniqSupply
661
662
663
664
665
666
667
668
	-> 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

669
rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_inst_env to_return
670
671
  = -- all the instance decls we might even want to consider
    -- are in the ParsedIfaces that are in our cache
672

673
    readVar iface_var	`thenPrimIO` \ (_, orig_iface_fm, _) ->
674
    let
675
	all_ifaces	  = eltsFM orig_iface_fm
676
677
	all_insts	  = concat (map get_insts all_ifaces)
	interesting_insts = filter want_inst all_insts
678

679
680
	-- Sanity Check:
	-- Assert that there are no more instances for the done instances
681

682
	claim_done       = filter is_done_inst all_insts
683
	claim_done_env   = foldr add_done_inst emptyFM claim_done
684

685
	has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
686
    in
687
688
689
690
691
692
    {-
      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))
693

694
695
    case (initRn False{-iface-} modname occ_env us (
	    setExtraRn emptyUFM{-no fixities-}	$
696
697
	    mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
	    getImplicitUpRn			`thenRn` \ implicits ->
698
699
700
701
702
703
704
705
706
707
	    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))
708
709
    }
  where
710
    get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts]
711

712
713
    tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon)

714
    add_done_inst (_, InstSig clas tycon _ _) inst_env
715
      = addToFM_C (+) inst_env (tycon_class clas tycon) 1
716

717
    is_done_inst (_, InstSig clas tycon _ _)
718
      = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
719
720

    add_imp_occs (val_imps, tc_imps) occ_env
721
      = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of
722
723
     	  (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
				     ext_occ_env
724
725
726
      where
	de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
	-- again, this hackery because we are reusing the RnEnv technology
727

728
    want_inst i@(imod, InstSig clas tycon _ _)
729
730
      = -- it's a "good instance" (one to hang onto) if we have a
	-- chance of referring to *both* the class and tycon later on ...
731
	--pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
732
	mentionable tycon && mentionable clas && not (is_done_inst i)
733
734
      where
	mentionable nm
735
	  = case lookupTcRnEnv occ_env nm of
736
737
	      Just  _ -> True
	      Nothing -> -- maybe it's builtin
738
739
740
741
		let orig = qualToOrigName nm in
		case (lookupFM b_tc_names orig) of
		  Just  _ -> True
		  Nothing -> maybeToBool (lookupFM b_keys orig)
742
743
744

    (b_tc_names, b_keys) -- pretty UGLY ...
      = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
745
{-
746
747
748
749
750
    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]
751
-}
752
753
754
\end{code}

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

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

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

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

775
finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
776
  =
777
--  pprTrace "usageIf:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
778
--  pprTrace "usageIf:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
779
--  pprTrace "usageIf:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
780
--  pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
781
    readVar iface_var	`thenPrimIO` \ (_, orig_iface_fm, _) ->
782
    let
783
784
785
786
787
788
789
790
791
	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

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

795
	(all_usages, all_versions)
796
	  = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
797
798
799
    in
    return (all_usages, all_versions, [])
  where
800
801
802
803
804
805
806
    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
807
808
809
		 -> (UsagesMap, VersionsMap)	   -- input
		 -> (UsagesMap, VersionsMap)	   -- output

810
    process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
811
812
813
814
815
      | irrelevant rn
      = as_before
      | m == modname -- this module => add to "versions"
      =	(usages, addToFM versions n 1{-stub-})
      | otherwise  -- from another module => add to "usages"
816
817
818
      = case (add_to_usages usages key) of
	  Nothing	  -> as_before
	  Just new_usages -> (new_usages, versions)
819
820
      where
	add_to_usages usages key@(n,m)
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
	  = 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)
		    )
836
837
838
839

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

843
844
845
846
\end{code}


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

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

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

856
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
  = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
868
869
870

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