RnIfaces.lhs 23.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
	findHiFiles,
11
	cachedIface,
12
	cachedDecl,
13
14
	readIface,
	rnIfaces,
15
16
	finalIfaceInfo,
	IfaceCache(..),
17
	VersionInfo(..)
18
19
20
21
    ) where

import Ubiq

22
import LibDirectory
23
import PreludeGlaST	( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
24

25
import HsSyn
26
import HsPragmas	( noGenPragmas )
27
28
29
30
import RdrHsSyn
import RnHsSyn

import RnMonad
31
import RnSource		( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
32
import RnUtils		( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
33
34
import ParseIface	( parseIface )
import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
35

36
import Bag		( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
37
import CmdLineOpts	( opt_HiSuffix, opt_SysHiSuffix )
38
import ErrUtils		( Error(..), Warning(..) )
39
40
import FiniteMap	( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
			  fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} )
41
42
43
44
45
46
47
import Maybes		( maybeToBool )
import Name		( moduleNamePair, origName, isRdrLexCon,
			  RdrName(..){-instance NamedThing-}
			)
import PprStyle		-- ToDo:rm
import Outputable	-- ToDo:rm
import PrelInfo		( builtinNameInfo )
48
49
import Pretty
import Maybes		( MaybeErr(..) )
50
51
import UniqFM		( emptyUFM )
import UniqSupply	( splitUniqSupply )
52
53
import Util		( sortLt, removeDups, cmpPString, startsWith,
			  panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
54
55
56
\end{code}

\begin{code}
57
58
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
59

60
61
62
type IfaceCache
  = MutableVar _RealWorld (ModuleToIfaceContents,
			   ModuleToIfaceFilePath)
63
64
65
66
67
68
69
70
\end{code}

*********************************************************
*							*
\subsection{Looking for interface files}
*							*
*********************************************************

71
72
Return a mapping from module-name to
absolute-filename-for-that-interface.
73
\begin{code}
74
75
76
77
78
79
80
81
82
83
84
85
86
87
findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)

findHiFiles dirs sysdirs
  = do_dirs emptyFM (dirs ++ sysdirs)
  where
    do_dirs env [] = return env
    do_dirs env (dir:dirs)
      = do_dir  env     dir	>>= \ new_env ->
	do_dirs new_env dirs
    -------
    do_dir env dir
      = --trace ("Having a go on..."++dir) $
	getDirectoryContents dir    >>= \ entries ->
	do_entries env entries
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
      where
	do_entries env [] = return env
	do_entries env (e:es)
	  = do_entry   env     e    >>= \ new_env ->
	    do_entries new_env es
	-------
	do_entry env e
	  = case (acceptable_hi (reverse e)) of
	      Nothing  -> --trace ("Deemed uncool:"++e) $
			  return env
	      Just mod ->
		let
		      pmod = _PK_ mod
		in
		case (lookupFM env pmod) of
		  Nothing -> --trace ("Adding "++mod++" -> "++e) $
			     return (addToFM env pmod (dir ++ '/':e))
			     -- ToDo: use DIR_SEP, not /

		  Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
			     return env
109
110
111
112
113
114
    -------
    acceptable_hi rev_e -- looking at pathname *backwards*
      = case (startsWith (reverse opt_HiSuffix) rev_e) of
	  Nothing -> Nothing
	  Just xs -> plausible_modname xs{-reversed-}

115
116
117
118
    -------
    de_dot ('.' : '/' : xs) = xs
    de_dot xs		    = xs

119
120
121
122
123
124
125
126
127
128
    -------
    plausible_modname rev_e
      = let
	    cand = reverse (takeWhile is_modname_char rev_e)
	in
	if null cand || not (isUpper (head cand))
	then Nothing
	else Just cand
      where
	is_modname_char c = isAlphanum c || c == '_'
129
\end{code}
130

131
132
133
134
135
*********************************************************
*							*
\subsection{Reading interface files}
*							*
*********************************************************
136

137
138
139
140
Return cached info about a Module's interface; otherwise,
read the interface (using our @ModuleToIfaceFilePath@ map
to decide where to look).

141
\begin{code}
142
143
144
cachedIface :: IfaceCache
	    -> Module
	    -> IO (MaybeErr ParsedIface Error)
145

146
147
cachedIface iface_cache mod
  = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) ->
148
149
150

    case (lookupFM iface_fm mod) of
      Just iface -> return (Succeeded iface)
151
      Nothing    ->
152
153
      	case (lookupFM file_fm mod) of
	  Nothing   -> return (Failed (noIfaceErr mod))
154
	  Just file ->
155
	    readIface file mod >>= \ read_iface ->
156
	    case read_iface of
157
158
	      Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
				 return (Failed err)
159
160
161
162
	      Succeeded iface ->
		let
		    iface_fm' = addToFM iface_fm mod iface
		in
163
		writeVar iface_cache (iface_fm', file_fm) `seqPrimIO`
164
		return (Succeeded iface)
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

----------
cachedDecl :: IfaceCache
	   -> Bool	-- True <=> tycon or class name
	   -> RdrName
	   -> IO (MaybeErr RdrIfaceDecl Error)

-- ToDo: this is where the check for Prelude.map being
--       located in PreludeList.map should be done ...

cachedDecl iface_cache class_or_tycon orig 
  = cachedIface iface_cache mod 	>>= \ maybe_iface ->
    case maybe_iface of
      Failed err -> return (Failed err)
      Succeeded (ParsedIface _ _ _ _ exps _ _ tdefs vdefs _ _) -> 
	case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
	  Just decl -> return (Succeeded decl)
	  Nothing   -> return (Failed (noDeclInIfaceErr mod str))
  where
    (mod, str) = moduleNamePair orig

----------
cachedDeclByType :: IfaceCache
		 -> RnName{-NB: diff type than cachedDecl -}
		 -> IO (MaybeErr RdrIfaceDecl Error)

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)
  = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn)  >>= \ maybe_decl ->
    let
	return_maybe_decl = return maybe_decl
	return_failed msg = return (Failed msg)
    in
    case maybe_decl of
      Failed _ -> return_maybe_decl
      Succeeded if_decl ->
	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
209
	  RnData _ _ _	    -> return_maybe_decl
210
211
212
213
214
215
216
217
218
	  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)
	  
219
220
221
222
223
224
225
	  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)
226
227
228
  where
    is_tycon_decl (TypeSig _ _ _)	= True
    is_tycon_decl (NewTypeSig _ _ _ _)	= True
229
    is_tycon_decl (DataSig _ _ _ _ _)	= True
230
231
232
233
234
235
    is_tycon_decl _			= False

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

    is_val_decl (ValSig _ _ _)		= True
236
237
238
    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
239
    is_val_decl _			= False
240
\end{code}
241

242
243
244
245
246
247
248
\begin{code}
readIface :: FilePath -> Module
	      -> IO (MaybeErr ParsedIface Error)

readIface file mod
  = readFile file   `thenPrimIO` \ read_result ->
    case read_result of
249
250
      Left  err      -> return (Failed (cannaeReadErr file err))
      Right contents -> return (parseIface contents)
251
252
253
254
\end{code}


\begin{code}
255
rnIfaces :: IfaceCache			-- iface cache (mutvar)
256
	 -> [Module]			-- directly imported modules
257
	 -> UniqSupply
258
259
260
261
262
263
264
265
	 -> 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
266
		RnEnv,			-- final env (for renaming derivings)
267
		ImplicitEnv,		-- implicit names used (for usage info)
268
		(Bag Error, Bag Warning))
269

270
rnIfaces iface_cache imp_mods us
271
272
273
274
275
276
	 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
277
278
  = {-
    pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
279
280
281
282
283
284
285
286
287
288
289
290

    pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $
    pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
    pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $
    pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $

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

291
    -- do transitive closure to bring in all needed names/defns and insts:
292

293
294
295
296
297
    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) ->
298

299
    return (HsModule modname iface_version exports imports fixities
300
301
302
303
304
305
306
		 (typedecls ++ if_typedecls)
		 typesigs
		 (classdecls ++ if_classdecls)
		 (instdecls  ++ if_instdecls)
		 instsigs defdecls binds
		 (sigs ++ if_sigs)
		 src_loc,
307
308
309
	    if_final_env,
	    if_implicits,
	    if_errs_warns)
310
  where
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    decls_and_insts todo def_env occ_env to_return us
      =	do_decls todo	     		 -- initial batch of names to process
	 	 (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
      where
	(us1,us2) = splitUniqSupply us

    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
351
352


353
354
355
356
357
358
359
360
361
362
363
364
365
366
    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
367
368
	  Just  _ -> -- previous processing must've found the stuff for this name;
		     -- continue with the rest:
369
370
		     -- pprTrace "do_decls:done:" (ppr PprDebug n) $
		     do_decls ns down to_return
371
372
373
374
375
376

	  Nothing -> -- OK, see what the cache has for us...

	    cachedDeclByType iface_cache n >>= \ maybe_ans ->
	    case maybe_ans of
	      Failed err -> -- add the error, but keep going:
377
378
			    -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
			    do_decls ns down (add_err err to_return)
379
380
381
382
383
384

	      Succeeded iface_decl -> -- something needing renaming!
		let
		    (us1, us2) = splitUniqSupply (uniqsupply down)
		in
		case (initRn False{-iface-} modname (occenv down) us1 (
385
			setExtraRn emptyUFM{-no fixities-} $
386
387
388
389
390
			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
391
392
393
394
395
396
397
398
399
400
401
402
403
404
		    {-
		    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)
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
	        }

-----------
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
422
423
424
425
  | isRnTyConOrClass n 
  = lookupTcRnEnv def_env (origName n)
  | otherwise 
  = lookupRnEnv def_env (origName n)
426

427
defenv	   (def_env, _, _) = def_env
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
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) ->
    ASSERT(isEmptyBag def_dups)
    let
	val_occs = val_defds ++ fmToList val_imps
	tc_occs  = tc_defds  ++ fmToList tc_imps
    in
    case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->

--  ASSERT(isEmptyBag occ_dups)
443
--  False because we may get a dup on the name we just shoved in
444
445
446
447

    (new_def_env, new_occ_env, us) }}

----------------
448
type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
449
450
451
452
453
		  ImplicitEnv,	-- new names used implicitly
		  (Bag Error, Bag Warning)
		 )

empty_return :: To_Return
454
empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
455

456
add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
457
  = case decl of
458
459
460
461
462
463
      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)
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
  = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM`  tc_imps), msgs)

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))
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)

510
rnIfaceDecl (DataSig tc dcs fcs _ decl)
511
512
513
  = rnTyDecl    decl		`thenRn` \ rn_decl   ->
    lookupTyCon tc		`thenRn` \ rn_tc     ->
    mapRn lookupValue dcs	`thenRn` \ rn_dcs    ->
514
    mapRn lookupValue fcs	`thenRn` \ rn_fcs    ->
515
516
    getImplicitUpRn		`thenRn` \ mentioned ->
    let
517
	defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
	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)
  = (delListFromFM val_ment (map fst val_defds),
     delListFromFM tc_ment  (map fst tc_defds))
551
552
\end{code}

553
554
% ------------------------------

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
584
585
586
@cacheInstModules@: cache instance modules specified in imports

\begin{code}
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
cacheInstModules iface_cache imp_mods
  = readVar iface_cache		`thenPrimIO` \ (iface_fm, _) ->
    let
	imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
	(imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
        get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims
    in
    accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces ->

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

    readVar iface_cache		`thenPrimIO` \ (all_iface_fm, _) ->
    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}


587
588
589
@rnIfaceInstStuff@: Deal with instance declarations from interface files.

\begin{code}
590
591
type InstanceEnv = FiniteMap (RdrName, RdrName) Int

592
rnIfaceInstStuff
593
	:: IfaceCache		-- all about ifaces we've read
594
595
	-> Module
	-> UniqSupply
596
597
598
599
600
601
602
603
604
605
606
	-> 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

rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
  = -- all the instance decls we might even want to consider
    -- are in the ParsedIfaces that are in our cache
607
608
609

    readVar iface_cache	`thenPrimIO` \ (iface_fm, _) ->
    let
610
611
612
	all_ifaces	  = eltsFM iface_fm
	all_insts	  = unionManyBags (map get_insts all_ifaces)
	interesting_insts = filter want_inst (bagToList all_insts)
613

614
615
	-- Sanity Check:
	-- Assert that there are no more instances for the done instances
616

617
618
619
	claim_done       = filter is_done_inst (bagToList all_insts)
	claim_done_env   = foldr add_done_inst emptyFM claim_done
	has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
620
    in
621
622
623
624
625
626
    {-
      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))
627

628
629
630
631
632
633
634
635
636
637
638
639
640
641
    case (initRn False{-iface-} modname occ_env us (
	    setExtraRn emptyUFM{-no fixities-}	$
	    mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
	    getImplicitUpRn 			`thenRn` \ implicits ->
	    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))
642
643
    }
  where
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
    get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts

    add_done_inst (InstSig clas tycon _ _) inst_env
      = addToFM_C (+) inst_env (tycon,clas) 1

    is_done_inst (InstSig clas tycon _ _)
      = maybeToBool (lookupFM done_inst_env (tycon,clas))

    add_imp_occs (val_imps, tc_imps) occ_env
      = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
     	  (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
				     ext_occ_env

    want_inst i@(InstSig clas tycon _ _)
      = -- it's a "good instance" (one to hang onto) if we have a
	-- chance of referring to *both* the class and tycon later on ...

	mentionable tycon && mentionable clas && not (is_done_inst i)
662
663
      where
	mentionable nm
664
	  = case lookupTcRnEnv occ_env nm of
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
	      Just  _ -> True
	      Nothing -> -- maybe it's builtin
		case nm of
		  Qual _ _ -> False
		  Unqual n ->
		    case (lookupFM b_tc_names n) of
		      Just  _ -> True
		      Nothing -> maybeToBool (lookupFM b_keys n)

    (b_tc_names, b_keys) -- pretty UGLY ...
      = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)

    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]
\end{code}

\begin{code}
rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl

rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
\end{code}
689
690
691

\begin{code}
finalIfaceInfo ::
692
693
694
695
696
	   IfaceCache			-- iface cache
	-> [RnName]			-- all imported names required
	-> [Module]			-- directly imported modules
	-> IO (VersionInfo,		-- info about version numbers
	       [Module])		-- special instance modules
697
698
699

type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])]

700
701
finalIfaceInfo iface_cache imps_reqd imp_mods
  = return ([], [])
702
703
704
705
706
\end{code}


\begin{code}
noIfaceErr mod sty
707
708
  = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]

709
710
711
712
713
714
715
716
717
718
719
720
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: ???")]
721
\end{code}