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