ghc/compiler/rename/RnIfaces.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnIfaces]{Cacheing and Renaming of Interfaces}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnIfaces (
  10         findHiFiles,
  11         cachedIface,
  12         cachedDecl,
  13         readIface,
  14         rnIfaces,
  15         finalIfaceInfo,
  16         IfaceCache(..),
  17         VersionInfo(..)
  18     ) where
  19
  20 import Ubiq
  21
  22 import LibDirectory
  23 import PreludeGlaST     ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
  24
  25 import HsSyn
  26 import HsPragmas        ( noGenPragmas )
  27 import RdrHsSyn
  28 import RnHsSyn
  29
  30 import RnMonad
  31 import RnSource         ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
  32 import RnUtils          ( RnEnv(..), lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
  33 import ParseIface       ( parseIface )
  34 import ParseUtils       ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
  35
  36 import Bag              ( emptyBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
  37 import CmdLineOpts      ( opt_HiSuffix, opt_SysHiSuffix )
  38 import ErrUtils         ( Error(..), Warning(..) )
  39 import FiniteMap        ( emptyFM, lookupFM, addToFM, plusFM, eltsFM,
  40                           fmToList, delListFromFM, keysFM{-ToDo:rm-}
  41                         )
  42 import Maybes           ( maybeToBool )
  43 import Name             ( moduleNamePair, origName, isRdrLexCon,
  44                           RdrName(..){-instance NamedThing-}
  45                         )
  46 import PprStyle         -- ToDo:rm
  47 import Outputable       -- ToDo:rm
  48 import PrelInfo         ( builtinNameInfo )
  49 import Pretty
  50 import Maybes           ( MaybeErr(..) )
  51 import UniqFM           ( emptyUFM )
  52 import UniqSupply       ( splitUniqSupply )
  53 import Util             ( startsWith, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
  54 \end{code}
  55
  56 \begin{code}
  57 type ModuleToIfaceContents = FiniteMap Module ParsedIface
  58 type ModuleToIfaceFilePath = FiniteMap Module FilePath
  59
  60 type IfaceCache
  61   = MutableVar _RealWorld (ModuleToIfaceContents,
  62                            ModuleToIfaceFilePath)
  63 \end{code}
  64
  65 *********************************************************
  66 *                                                       *
  67 \subsection{Looking for interface files}
  68 *                                                       *
  69 *********************************************************
  70
  71 Return a mapping from module-name to
  72 absolute-filename-for-that-interface.
  73 \begin{code}
  74 findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
  75
  76 findHiFiles dirs sysdirs
  77   = do_dirs emptyFM (dirs ++ sysdirs)
  78   where
  79     do_dirs env [] = return env
  80     do_dirs env (dir:dirs)
  81       = do_dir  env     dir     >>= \ new_env ->
  82         do_dirs new_env dirs
  83     -------
  84     do_dir env dir
  85       = --trace ("Having a go on..."++dir) $
  86         getDirectoryContents dir    >>= \ entries ->
  87         do_entries env entries
  88       where
  89         do_entries env [] = return env
  90         do_entries env (e:es)
  91           = do_entry   env     e    >>= \ new_env ->
  92             do_entries new_env es
  93         -------
  94         do_entry env e
  95           = case (acceptable_hi (reverse e)) of
  96               Nothing  -> --trace ("Deemed uncool:"++e) $
  97                           return env
  98               Just mod ->
  99                 let
 100                       pmod = _PK_ mod
 101                 in
 102                 case (lookupFM env pmod) of
 103                   Nothing -> --trace ("Adding "++mod++" -> "++e) $
 104                              return (addToFM env pmod (dir ++ '/':e))
 105                              -- ToDo: use DIR_SEP, not /
 106
 107                   Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
 108                              return env
 109     -------
 110     acceptable_hi rev_e -- looking at pathname *backwards*
 111       = case (startsWith (reverse opt_HiSuffix) rev_e) of
 112           Nothing -> Nothing
 113           Just xs -> plausible_modname xs{-reversed-}
 114
 115     -------
 116     de_dot ('.' : '/' : xs) = xs
 117     de_dot xs               = xs
 118
 119     -------
 120     plausible_modname rev_e
 121       = let
 122             cand = reverse (takeWhile is_modname_char rev_e)
 123         in
 124         if null cand || not (isUpper (head cand))
 125         then Nothing
 126         else Just cand
 127       where
 128         is_modname_char c = isAlphanum c || c == '_'
 129 \end{code}
 130
 131 *********************************************************
 132 *                                                       *
 133 \subsection{Reading interface files}
 134 *                                                       *
 135 *********************************************************
 136
 137 Return cached info about a Module's interface; otherwise,
 138 read the interface (using our @ModuleToIfaceFilePath@ map
 139 to decide where to look).
 140
 141 \begin{code}
 142 cachedIface :: IfaceCache
 143             -> Module
 144             -> IO (MaybeErr ParsedIface Error)
 145
 146 cachedIface iface_cache mod
 147   = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) ->
 148
 149     case (lookupFM iface_fm mod) of
 150       Just iface -> return (Succeeded iface)
 151       Nothing    ->
 152         case (lookupFM file_fm mod) of
 153           Nothing   -> return (Failed (noIfaceErr mod))
 154           Just file ->
 155             readIface file mod >>= \ read_iface ->
 156             case read_iface of
 157               Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
 158                                  return (Failed err)
 159               Succeeded iface ->
 160                 let
 161                     iface_fm' = addToFM iface_fm mod iface
 162                 in
 163                 writeVar iface_cache (iface_fm', file_fm) `seqPrimIO`
 164                 return (Succeeded iface)
 165
 166 ----------
 167 cachedDecl :: IfaceCache
 168            -> Bool      -- True <=> tycon or class name
 169            -> RdrName
 170            -> IO (MaybeErr RdrIfaceDecl Error)
 171
 172 -- ToDo: this is where the check for Prelude.map being
 173 --       located in PreludeList.map should be done ...
 174
 175 cachedDecl iface_cache class_or_tycon orig
 176   = cachedIface iface_cache mod         >>= \ maybe_iface ->
 177     case maybe_iface of
 178       Failed err -> return (Failed err)
 179       Succeeded (ParsedIface _ _ _ _ exps _ _ tdefs vdefs _ _) ->
 180         case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
 181           Just decl -> return (Succeeded decl)
 182           Nothing   -> return (Failed (noDeclInIfaceErr mod str))
 183   where
 184     (mod, str) = moduleNamePair orig
 185
 186 ----------
 187 cachedDeclByType :: IfaceCache
 188                  -> RnName{-NB: diff type than cachedDecl -}
 189                  -> IO (MaybeErr RdrIfaceDecl Error)
 190
 191 cachedDeclByType iface_cache rn
 192     -- the idea is: check that, e.g., if we're given an
 193     -- RnClass, then we really get back a ClassDecl from
 194     -- the cache (not an RnData, or something silly)
 195   = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn)  >>= \ maybe_decl ->
 196     let
 197         return_maybe_decl = return maybe_decl
 198         return_failed msg = return (Failed msg)
 199     in
 200     case maybe_decl of
 201       Failed _ -> return_maybe_decl
 202       Succeeded if_decl ->
 203         case rn of
 204           WiredInId _       -> return_failed (ifaceLookupWiredErr "value" rn)
 205           WiredInTyCon _    -> return_failed (ifaceLookupWiredErr "type constructor" rn)
 206           RnUnbound _       -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
 207
 208           RnSyn _           -> return_maybe_decl
 209           RnData _ _        -> return_maybe_decl
 210           RnImplicitTyCon _ -> if is_tycon_decl if_decl
 211                                then return_maybe_decl
 212                                else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
 213
 214           RnClass _ _       -> return_maybe_decl
 215           RnImplicitClass _ -> if is_class_decl if_decl
 216                                then return_maybe_decl
 217                                else return_failed (badIfaceLookupErr "class" rn if_decl)
 218
 219           RnName _          ->  return_maybe_decl
 220           RnConstr _ _      ->  return_maybe_decl
 221           RnClassOp _ _     ->  return_maybe_decl
 222           RnImplicit _      ->  if is_val_decl if_decl
 223                                 then return_maybe_decl
 224                                 else return_failed (badIfaceLookupErr "value/method" rn if_decl)
 225   where
 226     is_tycon_decl (TypeSig _ _ _)       = True
 227     is_tycon_decl (NewTypeSig _ _ _ _)  = True
 228     is_tycon_decl (DataSig _ _ _ _)     = True
 229     is_tycon_decl _                     = False
 230
 231     is_class_decl (ClassSig _ _ _ _)    = True
 232     is_class_decl _                     = False
 233
 234     is_val_decl (ValSig _ _ _)          = True
 235     is_val_decl (ClassSig _ _ _ _)      = True  -- if the thing we were after *happens* to
 236                                                 -- be a class op; we will have fished a ClassSig
 237                                                 -- out of the interface for it.
 238     is_val_decl _                       = False
 239 \end{code}
 240
 241 \begin{code}
 242 readIface :: FilePath -> Module
 243               -> IO (MaybeErr ParsedIface Error)
 244
 245 readIface file mod
 246   = readFile file   `thenPrimIO` \ read_result ->
 247     case read_result of
 248       Left  err      -> return (Failed (cannaeReadErr file err))
 249       Right contents -> return (parseIface contents)
 250 \end{code}
 251
 252
 253 \begin{code}
 254 rnIfaces :: IfaceCache                  -- iface cache (mutvar)
 255          -> UniqSupply
 256          -> RnEnv                       -- defined (in the source) name env
 257          -> RnEnv                       -- mentioned (in the source) name env
 258          -> RenamedHsModule             -- module to extend with iface decls
 259          -> [RnName]                    -- imported names required (really the
 260                                         -- same info as in mentioned name env)
 261                                         -- Also, all the things we may look up
 262                                         -- later by key (Unique).
 263          -> IO (RenamedHsModule,        -- extended module
 264                 ImplicitEnv,            -- implicit names used (for usage info)
 265                 Bag Error,
 266                 Bag Warning)
 267
 268 rnIfaces iface_cache us
 269          def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
 270          occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
 271          rn_module@(HsModule modname iface_version exports imports fixities
 272                       typedecls typesigs classdecls instdecls instsigs
 273                       defdecls binds sigs src_loc)
 274          todo
 275   = {-pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
 276
 277     pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $
 278     pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
 279     pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $
 280     pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
 281
 282     pprTrace "rnIfaces:dqual:"     (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dqual]) $
 283     pprTrace "rnIfaces:dunqual:"   (ppCat (map ppPStr (keysFM dunqual))) $
 284     pprTrace "rnIfaces:dtc_qual:"  (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $
 285     pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
 286     -}
 287     let
 288         (us1,us2) = splitUniqSupply us
 289     in
 290
 291     -- do transitive closure to bring in all needed names/defns:
 292
 293     loop todo         -- initial batch of names to process
 294          (def_env, occ_env, us1) -- init stuff down
 295          empty_return -- init acc results
 296          >>= \ (((if_typedecls, if_classdecls, if_sigs),
 297                  if_implicits,
 298                  (if_errs, if_warns)),
 299                 new_occ_env) ->
 300
 301     -- go back and handle instance things:
 302
 303     rnIfaceInstStuff iface_cache modname us2 new_occ_env if_implicits
 304          >>= \ (if_instdecls, (ifi_errs, ifi_warns)) ->
 305
 306     return (
 307         HsModule modname iface_version exports imports fixities
 308                  (typedecls ++ if_typedecls)
 309                  typesigs
 310                  (classdecls ++ if_classdecls)
 311                  (instdecls  ++ if_instdecls)
 312                  instsigs defdecls binds
 313                  (sigs ++ if_sigs)
 314                  src_loc,
 315         if_implicits,
 316         if_errs  `unionBags` ifi_errs,
 317         if_warns `unionBags` ifi_warns
 318     )
 319   where
 320     loop :: [RnName]      -- Names we're looking for; we keep adding/deleting
 321                           -- from this list; we're done when empty (nothing
 322                           -- more needs to be looked for)
 323          -> Go_Down       -- see defn below
 324          -> To_Return     -- accumulated result
 325          -> IO (To_Return, RnEnv{-final occurrence env; to pass on for doing instances-})
 326
 327     loop to_find@[] down to_return = return (to_return, occenv down)
 328
 329     loop to_find@(n:ns) down to_return
 330       = case (lookup_defd down (origName n)) of
 331           Just  _ -> -- previous processing must've found the stuff for this name;
 332                      -- continue with the rest:
 333                      -- pprTrace "loop:done:" (ppr PprDebug n) $
 334                      loop ns down to_return
 335
 336           Nothing -> -- OK, see what the cache has for us...
 337
 338             cachedDeclByType iface_cache n >>= \ maybe_ans ->
 339             case maybe_ans of
 340               Failed err -> -- add the error, but keep going:
 341                             -- pprTrace "loop:cache error:" (ppr PprDebug n) $
 342                             loop ns down (add_err err to_return)
 343
 344               Succeeded iface_decl -> -- something needing renaming!
 345                 let
 346                     (us1, us2) = splitUniqSupply (uniqsupply down)
 347                 in
 348                 case (initRn False{-iface-} modname (occenv down) us1 (
 349                         setExtraRn emptyUFM{-ignore fixities-} $
 350                         rnIfaceDecl iface_decl)) of {
 351                   ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
 352                     let
 353                         new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
 354                     in
 355 --                  pprTrace "loop:renamed:" (ppAboves [ppr PprDebug n
 356 --                      , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
 357 --                      , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
 358 --                      , ppCat [ppStr "defd  tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
 359 --                      ]) $
 360                     loop (new_unknowns ++ ns)
 361                          (add_occs       if_defd if_implicits $
 362                           new_uniqsupply us2 down)
 363                          (add_decl       if_decl        $
 364                           add_implicits  if_implicits   $
 365                           add_errs       if_errs        $
 366                           add_warns      if_warns to_return)
 367                 }
 368
 369 -----------
 370 type Go_Down   = (RnEnv,        -- stuff we already have defns for;
 371                                 -- to check quickly if we've already
 372                                 -- found something for the name under consideration,
 373                                 -- due to previous processing.
 374                                 -- It starts off just w/ the defns for
 375                                 -- the things in this module.
 376                   RnEnv,        -- occurrence env; this gets added to as
 377                                 -- we process new iface decls.  It includes
 378                                 -- entries for *all* occurrences, including those
 379                                 -- for which we have definitions.
 380                   UniqSupply    -- the obvious
 381                  )
 382
 383 lookup_defd (def_env, _, _) n
 384   = (if isRdrLexCon n then lookupTcRnEnv else lookupRnEnv) def_env n
 385
 386 occenv     (_, occ_env, _) = occ_env
 387 uniqsupply (_, _,      us) = us
 388
 389 new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
 390
 391 add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
 392   = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
 393     ASSERT(isEmptyBag def_dups)
 394     let
 395         val_occs = val_defds ++ fmToList val_imps
 396         tc_occs  = tc_defds  ++ fmToList tc_imps
 397     in
 398     case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->
 399
 400 --  ASSERT(isEmptyBag occ_dups)
 401 -- False because we may get a dup on the name we just shoved in
 402
 403     (new_def_env, new_occ_env, us) }}
 404
 405 ----------------
 406 type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedSig]),
 407                   ImplicitEnv,  -- new names used implicitly
 408                   (Bag Error, Bag Warning)
 409                  )
 410
 411 empty_return :: To_Return
 412 empty_return = (([],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
 413
 414 add_decl decl ((tydecls, classdecls, sigs), implicit, msgs)
 415   = case decl of
 416       AddedTy    t -> ((t:tydecls, classdecls, sigs), implicit, msgs)
 417       AddedClass c -> ((tydecls, c:classdecls, sigs), implicit, msgs)
 418       AddedSig   s -> ((tydecls, classdecls, s:sigs), implicit, msgs)
 419
 420 add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
 421   = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM`  tc_imps), msgs)
 422   where
 423     pairify rn = (origName rn, rn)
 424
 425 add_err  err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag`   err,warns))
 426 add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
 427 add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
 428 \end{code}
 429
 430 \begin{code}
 431 data AddedDecl -- purely local
 432   = AddedTy     RenamedTyDecl
 433   | AddedClass  RenamedClassDecl
 434   | AddedSig    RenamedSig
 435
 436 rnIfaceDecl :: RdrIfaceDecl
 437             -> RnM_Fixes _RealWorld
 438                    (AddedDecl,  -- the resulting decl to add to the pot
 439                     ([(RdrName,RnName)], [(RdrName,RnName)]),
 440                                 -- new val/tycon-class names that have
 441                                 -- *been defined* while processing this decl
 442                     ImplicitEnv -- new implicit val/tycon-class names that we
 443                                 -- stumbled into
 444                    )
 445
 446 rnIfaceDecl (TypeSig tc _ decl)
 447   = rnTyDecl    decl    `thenRn` \ rn_decl   ->
 448     lookupTyCon tc      `thenRn` \ rn_tc     ->
 449     getImplicitUpRn     `thenRn` \ mentioned ->
 450     let
 451         defds = ([], [(tc, rn_tc)])
 452         implicits = mentioned `sub` defds
 453     in
 454     returnRn (AddedTy rn_decl, defds, implicits)
 455
 456 rnIfaceDecl (NewTypeSig tc dc _ decl)
 457   = rnTyDecl    decl    `thenRn` \ rn_decl   ->
 458     lookupTyCon tc      `thenRn` \ rn_tc     ->
 459     lookupValue dc      `thenRn` \ rn_dc     ->
 460     getImplicitUpRn     `thenRn` \ mentioned ->
 461     let
 462         defds = ([(dc, rn_dc)], [(tc, rn_tc)])
 463         implicits = mentioned `sub` defds
 464     in
 465     returnRn (AddedTy rn_decl, defds, implicits)
 466
 467 rnIfaceDecl (DataSig tc dcs _ decl)
 468   = rnTyDecl    decl            `thenRn` \ rn_decl   ->
 469     lookupTyCon tc              `thenRn` \ rn_tc     ->
 470     mapRn lookupValue dcs       `thenRn` \ rn_dcs    ->
 471     getImplicitUpRn             `thenRn` \ mentioned ->
 472     let
 473         defds = (dcs `zip` rn_dcs, [(tc, rn_tc)])
 474         implicits = mentioned `sub` defds
 475     in
 476     returnRn (AddedTy rn_decl, defds, implicits)
 477
 478 rnIfaceDecl (ClassSig clas ops _ decl)
 479   = rnClassDecl decl                    `thenRn` \ rn_decl   ->
 480     lookupClass clas                    `thenRn` \ rn_clas   ->
 481     mapRn (lookupClassOp rn_clas) ops   `thenRn` \ rn_ops    ->
 482     getImplicitUpRn                     `thenRn` \ mentioned ->
 483     let
 484         defds = (ops `zip` rn_ops, [(clas, rn_clas)])
 485         implicits = mentioned `sub` defds
 486     in
 487     returnRn (AddedClass rn_decl, defds, implicits)
 488
 489 rnIfaceDecl (ValSig f src_loc ty)
 490     -- should rename_sig in RnBinds be used here? ToDo
 491   = lookupValue f                       `thenRn` \ rn_f  ->
 492     -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
 493     rnPolyType nullTyVarNamesEnv ty     `thenRn` \ rn_ty ->
 494     getImplicitUpRn                     `thenRn` \ mentioned ->
 495     let
 496         defds = ([(f, rn_f)], [])
 497         implicits = mentioned `sub` defds
 498     in
 499     returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
 500
 501 ----
 502 sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
 503
 504 sub (val_ment, tc_ment) (val_defds, tc_defds)
 505   = (delListFromFM val_ment (map fst val_defds),
 506      delListFromFM tc_ment  (map fst tc_defds))
 507 \end{code}
 508
 509 % ------------------------------
 510
 511 @rnIfaceInstStuff@: Deal with instance declarations from interface files.
 512
 513 \begin{code}
 514 rnIfaceInstStuff
 515         :: IfaceCache   -- all about ifaces we've read
 516         -> Module
 517         -> UniqSupply
 518         -> RnEnv
 519         -> ImplicitEnv  -- info about all names we've used
 520         -> IO ([RenamedInstDecl],
 521                (Bag Error, Bag Warning))
 522
 523 rnIfaceInstStuff iface_cache modname us occ_env implicit_env
 524   = -- nearly all the instance decls we might even want
 525     -- to consider are in the ParsedIfaces that are in our
 526     -- cache; any *other* instances to consider are in any
 527     -- "instance modules" fields that we've encounted.
 528     -- Get both:
 529
 530     readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
 531     let
 532         ifaces_so_far   = eltsFM iface_fm
 533         all_iface_imods = unionManyBags (map get_ims   ifaces_so_far)
 534         insts_so_far    = unionManyBags (map get_insts ifaces_so_far)
 535     in
 536     -- OK, get all the instance decls out of the "instance module"
 537     -- modules:
 538
 539     read_iface_imods iface_fm (bagToList all_iface_imods) emptyBag emptyBag{-accumulators-}
 540                         >>= \ (more_insts, ims_errs) ->
 541     let
 542         all_insts = insts_so_far `unionBags` more_insts
 543
 544         -- an instance decl can only be of interest if *both*
 545         -- its class and tycon have made their way into our
 546         -- purview:
 547         interesting_insts = filter (good_inst implicit_env) (bagToList all_insts)
 548     in
 549 --    pprTrace "in implicit:\n"     (ppCat (map (ppr PprDebug) (keysFM (snd implicit_env)))) $
 550 --    pprTrace "insts_so_far:\n"      (ppr_insts (bagToList insts_so_far)) $
 551 --    pprTrace "more_insts:\n"        (ppr_insts (bagToList more_insts)) $
 552 --    pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
 553     -- Do the renaming for real:
 554     --
 555     case (initRn False{-iface-} modname occ_env us (
 556             setExtraRn emptyUFM{-ignore fixities-} $
 557             mapRn rnIfaceInst interesting_insts)) of {
 558       (if_inst_decls, if_errs, if_warns) ->
 559
 560         return (if_inst_decls, (ims_errs `unionBags` if_errs, if_warns))
 561     }
 562   where
 563     get_insts (ParsedIface _ _ _ _ _   _ _ _ _ insts _) = insts
 564     get_ims   (ParsedIface _ _ _ _ _ ims _ _ _     _ _) = ims
 565
 566     good_inst (_, tc_imp_env) i@(InstSig clas tycon _ _)
 567       = -- it's a "good instance" (one to hang onto) if we have
 568         -- some chance of referring to *both* the class and tycon
 569         -- later on.
 570         mentionable clas && mentionable tycon
 571       where
 572         mentionable nm
 573           = case (lookupFM tc_imp_env nm) of
 574               Just  _ -> True
 575               Nothing -> -- maybe it's builtin
 576                 case nm of
 577                   Qual _ _ -> False
 578                   Unqual n ->
 579                     case (lookupFM b_tc_names n) of
 580                       Just  _ -> True
 581                       Nothing -> maybeToBool (lookupFM b_keys n)
 582
 583     (b_tc_names, b_keys) -- pretty UGLY ...
 584       = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
 585
 586     ppr_insts insts
 587       = ppAboves (map ppr_inst insts)
 588       where
 589         ppr_inst (InstSig c t _ inst_decl)
 590           = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
 591
 592     read_iface_imods :: ModuleToIfaceContents
 593                      -> [Module]
 594                      -> Bag RdrIfaceInst -> Bag Error
 595                      -> IO (Bag RdrIfaceInst, Bag Error)
 596
 597     read_iface_imods iface_fm []     iacc eacc = return (iacc, eacc)
 598     read_iface_imods iface_fm (m:ms) iacc eacc
 599       = case (lookupFM iface_fm m) of
 600           Just  _ -> -- module's already in our cache; keep going
 601                      read_iface_imods iface_fm ms iacc eacc
 602
 603           Nothing -> -- bring it in
 604             cachedIface iface_cache m   >>= \ read_res ->
 605             case read_res of
 606               Failed msg -> -- oh well, keep going anyway (saving the error)
 607                 read_iface_imods iface_fm ms iacc (eacc `snocBag` msg)
 608
 609               Succeeded iface ->
 610                 read_iface_imods iface_fm ms (iacc `unionBags` get_insts iface) eacc
 611 \end{code}
 612
 613 \begin{code}
 614 rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
 615
 616 rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
 617 \end{code}
 618
 619 \begin{code}
 620 finalIfaceInfo ::
 621            IfaceCache                   -- iface cache
 622         -> [RnName]                     -- all imported names required
 623         -> [Module]                     -- directly imported modules
 624         -> IO (VersionInfo,             -- info about version numbers
 625                [Module])                -- special instance modules
 626
 627 type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])]
 628
 629 finalIfaceInfo iface_cache imps_reqd imp_mods
 630   = return ([], [])
 631 \end{code}
 632
 633
 634 \begin{code}
 635 noIfaceErr mod sty
 636   = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
 637
 638 noDeclInIfaceErr mod str sty
 639   = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
 640                ppPStr mod, ppStr ".", ppPStr str]
 641
 642 cannaeReadErr file err sty
 643   = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
 644
 645 ifaceLookupWiredErr msg n sty
 646   = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
 647
 648 badIfaceLookupErr msg name decl sty
 649   = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
 650 \end{code}