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