RnIfaces.lhs 28.2 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
	IfaceCache(..)
16 17 18 19
    ) where

import Ubiq

20
import LibDirectory
21
import PreludeGlaST	( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
22

23
import HsSyn
24
import HsPragmas	( noGenPragmas )
25 26 27 28
import RdrHsSyn
import RnHsSyn

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

36 37
import Bag		( emptyBag, unitBag, consBag, snocBag,
			  unionBags, unionManyBags, isEmptyBag, bagToList )
38
import CmdLineOpts	( opt_HiSuffix, opt_SysHiSuffix )
39
import ErrUtils		( Error(..), Warning(..) )
40
import FiniteMap	( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, plusFM_C, eltsFM,
41 42
			  fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-}
			)
43
import Maybes		( maybeToBool )
44
import Name		( moduleNamePair, origName, isRdrLexCon, RdrName(..) )
45 46 47
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
type IfaceCache
61 62 63 64 65
  = MutableVar _RealWorld
	(ModuleToIfaceContents,	-- interfaces for individual interface files
	 ModuleToIfaceContents, -- merged interfaces based on module name
				-- used for extracting info about original names
	 ModuleToIfaceFilePath)
66 67 68 69 70 71 72 73
\end{code}

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

74 75
Return a mapping from module-name to
absolute-filename-for-that-interface.
76
\begin{code}
77 78 79
findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)

findHiFiles dirs sysdirs
80 81 82 83
  = hPutStr stderr "  findHiFiles "	>>
    do_dirs emptyFM (dirs ++ sysdirs)	>>= \ result ->
    hPutStr stderr " done\n"		>>
    return result
84 85 86 87 88 89 90
  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
91
      = hPutStr stderr "D" >>
92 93
	getDirectoryContents dir    >>= \ entries ->
	do_entries env entries
94 95 96 97 98 99 100 101 102
      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) $
103
			  hPutStr stderr "." >>
104 105 106 107 108 109 110
			  return env
	      Just mod ->
		let
		      pmod = _PK_ mod
		in
		case (lookupFM env pmod) of
		  Nothing -> --trace ("Adding "++mod++" -> "++e) $
111
			     hPutStr stderr "!" >>
112 113 114 115
			     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) $
116
			     hPutStr stderr "." >>
117
			     return env
118 119 120 121 122 123
    -------
    acceptable_hi rev_e -- looking at pathname *backwards*
      = case (startsWith (reverse opt_HiSuffix) rev_e) of
	  Nothing -> Nothing
	  Just xs -> plausible_modname xs{-reversed-}

124 125 126 127
    -------
    de_dot ('.' : '/' : xs) = xs
    de_dot xs		    = xs

128 129 130 131 132 133 134 135 136 137
    -------
    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 == '_'
138
\end{code}
139

140 141 142 143 144
*********************************************************
*							*
\subsection{Reading interface files}
*							*
*********************************************************
145

146 147 148 149
Return cached info about a Module's interface; otherwise,
read the interface (using our @ModuleToIfaceFilePath@ map
to decide where to look).

150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
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.


168
\begin{code}
169 170
cachedIface :: Bool		-- True  => want merged interface for original name
	    -> IfaceCache	-- False => want file interface only
171 172
	    -> Module
	    -> IO (MaybeErr ParsedIface Error)
173

174 175
cachedIface want_orig_iface iface_cache mod
  = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
176 177

    case (lookupFM iface_fm mod) of
178
      Just iface -> return (want_iface iface orig_fm)
179
      Nothing    ->
180 181
      	case (lookupFM file_fm mod) of
	  Nothing   -> return (Failed (noIfaceErr mod))
182
	  Just file ->
183
	    readIface file mod >>= \ read_iface ->
184
	    case read_iface of
185 186
	      Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
				 return (Failed err)
187 188 189
	      Succeeded iface ->
		let
		    iface_fm' = addToFM iface_fm mod iface
190
		    orig_fm'  = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
191
		in
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
		writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO`
		return (want_iface iface orig_fm')
  where
    want_iface iface orig_fm 
      | want_orig_iface
      = case lookupFM orig_fm of
	  Nothing         -> Failed (noOrigIfaceErr mod)
          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
	(True, unionBags files1 files2)
	(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:"
	   	 (ppCat [ppPStr mod, ppPStr mod1, ppStr ": dup", ppStr str, ppStr "decl",
			 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
236 237 238 239 240 241 242 243

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

cachedDecl iface_cache class_or_tycon orig 
244
  = cachedIface True iface_cache mod 	>>= \ maybe_iface ->
245 246
    case maybe_iface of
      Failed err -> return (Failed err)
247
      Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> 
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276
	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
277
	  RnData _ _ _	    -> return_maybe_decl
278 279 280 281 282 283 284 285 286
	  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)
	  
287 288 289 290 291 292 293
	  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)
294 295 296
  where
    is_tycon_decl (TypeSig _ _ _)	= True
    is_tycon_decl (NewTypeSig _ _ _ _)	= True
297
    is_tycon_decl (DataSig _ _ _ _ _)	= True
298 299 300 301 302 303
    is_tycon_decl _			= False

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

    is_val_decl (ValSig _ _ _)		= True
304 305 306
    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
307
    is_val_decl _			= False
308
\end{code}
309

310 311 312 313 314
\begin{code}
readIface :: FilePath -> Module
	      -> IO (MaybeErr ParsedIface Error)

readIface file mod
315 316
  = hPutStr stderr ("  reading "++file)	>>
    readFile file		`thenPrimIO` \ read_result ->
317
    case read_result of
318
      Left  err      -> return (Failed (cannaeReadErr file err))
319 320 321
      Right contents -> hPutStr stderr " parsing"   >>
			let parsed = parseIface contents in
			hPutStr stderr " done\n"    >>
322 323 324 325
			return (Succeeded (init_merge mod parsed))
  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
326 327 328 329
\end{code}


\begin{code}
330
rnIfaces :: IfaceCache			-- iface cache (mutvar)
331
	 -> [Module]			-- directly imported modules
332
	 -> UniqSupply
333 334 335 336 337 338 339 340
	 -> 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
341
		RnEnv,			-- final env (for renaming derivings)
342
		ImplicitEnv,		-- implicit names used (for usage info)
343
		(UsagesMap,VersionsMap,[Module]),	-- usage info
344
		(Bag Error, Bag Warning))
345

346
rnIfaces iface_cache imp_mods us
347 348 349 350 351 352
	 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
353 354
  = {-
    pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
355

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

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

367
    -- do transitive closure to bring in all needed names/defns and insts:
368

369 370 371 372 373
    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) ->
374

375 376 377 378 379
    -- finalize what we want to say we learned about the
    -- things we used
    finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
	\ usage_stuff@(usage_info, version_info, instance_mods) ->

380
    return (HsModule modname iface_version exports imports fixities
381 382 383 384 385 386 387
		 (typedecls ++ if_typedecls)
		 typesigs
		 (classdecls ++ if_classdecls)
		 (instdecls  ++ if_instdecls)
		 instsigs defdecls binds
		 (sigs ++ if_sigs)
		 src_loc,
388 389
	    if_final_env,
	    if_implicits,
390
	    usage_stuff,
391
	    if_errs_warns)
392
  where
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
    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
433 434


435 436 437 438 439 440 441 442 443 444 445 446 447 448
    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
449 450
	  Just  _ -> -- previous processing must've found the stuff for this name;
		     -- continue with the rest:
451 452
		     -- pprTrace "do_decls:done:" (ppr PprDebug n) $
		     do_decls ns down to_return
453

454 455 456 457 458
	  Nothing
	   | fst (moduleNamePair n) == modname ->
		     -- avoid looking in interface for the module being compiled
		     -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $
		     do_decls ns down (add_err (thisModImplicitErr modname n) to_return)
459

460 461
	   | otherwise ->
		     -- OK, see what the cache has for us...
462

463 464 465 466 467 468 469 470
	     cachedDeclByType iface_cache n >>= \ maybe_ans ->
	     case maybe_ans of
	       Failed err -> -- add the error, but keep going:
			     -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
			     do_decls ns down (add_err err to_return)

	       Succeeded iface_decl -> -- something needing renaming!
		 let
471
		    (us1, us2) = splitUniqSupply (uniqsupply down)
472 473
		 in
		 case (initRn False{-iface-} modname (occenv down) us1 (
474
			setExtraRn emptyUFM{-no fixities-} $
475 476 477 478 479
			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
480 481 482 483 484 485 486 487 488 489 490 491 492 493
		    {-
		    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)
494
	         }
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510

-----------
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
511 512 513 514
  | isRnTyConOrClass n 
  = lookupTcRnEnv def_env (origName n)
  | otherwise 
  = lookupRnEnv def_env (origName n)
515

516
defenv	   (def_env, _, _) = def_env
517 518 519 520 521 522 523 524 525 526 527 528 529 530 531
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)
532
--  False because we may get a dup on the name we just shoved in
533 534 535 536

    (new_def_env, new_occ_env, us) }}

----------------
537
type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
538 539 540 541 542
		  ImplicitEnv,	-- new names used implicitly
		  (Bag Error, Bag Warning)
		 )

empty_return :: To_Return
543
empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
544

545
add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
546
  = case decl of
547 548 549 550 551 552
      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)
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 587 588 589 590 591 592 593 594 595 596 597 598

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)

599
rnIfaceDecl (DataSig tc dcs fcs _ decl)
600 601 602
  = rnTyDecl    decl		`thenRn` \ rn_decl   ->
    lookupTyCon tc		`thenRn` \ rn_tc     ->
    mapRn lookupValue dcs	`thenRn` \ rn_dcs    ->
603
    mapRn lookupValue fcs	`thenRn` \ rn_fcs    ->
604 605
    getImplicitUpRn		`thenRn` \ mentioned ->
    let
606
	defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639
	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))
640 641
\end{code}

642 643
% ------------------------------

644 645 646 647 648
@cacheInstModules@: cache instance modules specified in imports

\begin{code}
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
cacheInstModules iface_cache imp_mods
649
  = readVar iface_cache		`thenPrimIO` \ (iface_fm, _, _) ->
650 651 652
    let
	imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
	(imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
653
        get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
654
    in
655
    accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
656 657 658 659 660

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

661
    readVar iface_cache		`thenPrimIO` \ (all_iface_fm, _, _) ->
662 663 664 665 666 667 668 669 670 671 672 673 674 675
    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}


676 677 678
@rnIfaceInstStuff@: Deal with instance declarations from interface files.

\begin{code}
679 680
type InstanceEnv = FiniteMap (RdrName, RdrName) Int

681
rnIfaceInstStuff
682
	:: IfaceCache		-- all about ifaces we've read
683 684
	-> Module
	-> UniqSupply
685 686 687 688 689 690 691 692 693 694 695
	-> 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
696

697
    readVar iface_cache	`thenPrimIO` \ (_, orig_iface_fm, _) ->
698
    let
699
	all_ifaces	  = eltsFM orig_iface_fm
700 701
	all_insts	  = unionManyBags (map get_insts all_ifaces)
	interesting_insts = filter want_inst (bagToList all_insts)
702

703 704
	-- Sanity Check:
	-- Assert that there are no more instances for the done instances
705

706 707 708
	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 }
709
    in
710 711 712 713 714 715
    {-
      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))
716

717 718 719 720 721 722 723 724 725 726 727 728 729 730
    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))
731 732
    }
  where
733
    get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts
734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750

    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)
751 752
      where
	mentionable nm
753
	  = case lookupTcRnEnv occ_env nm of
754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777
	      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}
778 779 780

\begin{code}
finalIfaceInfo ::
781
	   IfaceCache			-- iface cache
782 783 784 785 786 787
	-> RnEnv
	-> [RenamedInstDecl]
--	-> [RnName]			-- all imported names required
--	-> [Module]			-- directly imported modules
	-> IO (UsagesMap,
	       VersionsMap,		-- info about version numbers
788
	       [Module])		-- special instance modules
789

790 791 792 793 794 795
finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
  =
    pprTrace "usageIf:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
--  pprTrace "usageIf:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
    pprTrace "usageIf:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
--  pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
796

797
    return (emptyFM, emptyFM, [])
798 799 800 801
\end{code}


\begin{code}
802 803 804
thisModImplicitErr mod n sty
  = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod]

805
noIfaceErr mod sty
806 807
  = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]

808 809 810
noOrigIfaceErr mod sty
  = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]

811 812 813 814 815 816 817 818 819 820 821 822
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: ???")]
823
\end{code}