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 IMP_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, unitBag, consBag, snocBag,
  37                           unionBags, unionManyBags, isEmptyBag, bagToList )
  38 import ErrUtils         ( Error(..), Warning(..) )
  39 import FiniteMap        ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
  40                           fmToList, delListFromFM, sizeFM, foldFM, unitFM,
  41                           plusFM_C, addListToFM, keysFM{-ToDo:rm-}
  42                         )
  43 import Maybes           ( maybeToBool )
  44 import Name             ( moduleNamePair, origName, isRdrLexCon, RdrName(..), Name{-instance NamedThing-} )
  45 import PprStyle         -- ToDo:rm
  46 import Outputable       -- ToDo:rm
  47 import PrelInfo         ( builtinNameInfo )
  48 import PrelMods         ( pRELUDE )
  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
  63         (ModuleToIfaceContents, -- interfaces for individual interface files
  64          ModuleToIfaceContents, -- merged interfaces based on module name
  65                                 -- used for extracting info about original names
  66          ModuleToIfaceFilePath)
  67 \end{code}
  68
  69 *********************************************************
  70 *                                                       *
  71 \subsection{Looking for interface files}
  72 *                                                       *
  73 *********************************************************
  74
  75 Return a mapping from module-name to
  76 absolute-filename-for-that-interface.
  77 \begin{code}
  78 {- OLD:
  79 findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
  80
  81 findHiFiles dirs sysdirs
  82   = --hPutStr stderr "  findHiFiles "   >>
  83     do_dirs emptyFM (dirs ++ sysdirs)   >>= \ result ->
  84     --hPutStr stderr " done\n"          >>
  85     return result
  86   where
  87     do_dirs env [] = return env
  88     do_dirs env (dir:dirs)
  89       = do_dir  env     dir     >>= \ new_env ->
  90         do_dirs new_env dirs
  91     -------
  92     do_dir env dir
  93       = --hPutStr stderr "D" >>
  94         getDirectoryContents dir    >>= \ entries ->
  95         do_entries env entries
  96       where
  97         do_entries env [] = return env
  98         do_entries env (e:es)
  99           = do_entry   env     e    >>= \ new_env ->
 100             do_entries new_env es
 101         -------
 102         do_entry env e
 103           = case (acceptable_hi (reverse e)) of
 104               Nothing  -> --trace ("Deemed uncool:"++e) $
 105                           --hPutStr stderr "." >>
 106                           return env
 107               Just mod ->
 108                 let
 109                       pmod = _PK_ mod
 110                 in
 111                 case (lookupFM env pmod) of
 112                   Nothing -> --trace ("Adding "++mod++" -> "++e) $
 113                              --hPutStr stderr "!" >>
 114                              return (addToFM env pmod (dir ++ '/':e))
 115                              -- ToDo: use DIR_SEP, not /
 116
 117                   Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
 118                              --hPutStr stderr "." >>
 119                              return env
 120     -------
 121     acceptable_hi rev_e -- looking at pathname *backwards*
 122       = case (startsWith (reverse opt_HiSuffix) rev_e) of
 123           Nothing -> Nothing
 124           Just xs -> plausible_modname xs{-reversed-}
 125
 126     -------
 127     de_dot ('.' : '/' : xs) = xs
 128     de_dot xs               = xs
 129
 130     -------
 131     plausible_modname rev_e
 132       = let
 133             cand = reverse (takeWhile is_modname_char rev_e)
 134         in
 135         if null cand || not (isUpper (head cand))
 136         then Nothing
 137         else Just cand
 138       where
 139         is_modname_char c = isAlphanum c || c == '_'
 140 -}
 141 \end{code}
 142
 143 *********************************************************
 144 *                                                       *
 145 \subsection{Reading interface files}
 146 *                                                       *
 147 *********************************************************
 148
 149 Return cached info about a Module's interface; otherwise,
 150 read the interface (using our @ModuleToIfaceFilePath@ map
 151 to decide where to look).
 152
 153 Note: we have two notions of interface
 154  * the interface for a particular file name
 155  * the (combined) interface for a particular module name
 156
 157 The idea is that two source files may declare a module
 158 with the same name with the declarations being merged.
 159
 160 This allows us to have file PreludeList.hs producing
 161 PreludeList.hi but defining part of module Prelude.
 162 When PreludeList is imported its contents will be
 163 added to Prelude. In this way all the original names
 164 for a particular module will be available the imported
 165 decls are renamed.
 166
 167 ToDo: Check duplicate definitons are the same.
 168 ToDo: Check/Merge duplicate pragmas.
 169
 170
 171 \begin{code}
 172 cachedIface :: Bool             -- True  => want merged interface for original name
 173             -> IfaceCache       -- False => want file interface only
 174             -> Module
 175             -> IO (MaybeErr ParsedIface Error)
 176
 177 cachedIface want_orig_iface iface_cache mod
 178   = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
 179
 180     case (lookupFM iface_fm mod) of
 181       Just iface -> return (want_iface iface orig_fm)
 182       Nothing    ->
 183         case (lookupFM file_fm mod) of
 184           Nothing   -> return (Failed (noIfaceErr mod))
 185           Just file ->
 186             readIface file mod >>= \ read_iface ->
 187             case read_iface of
 188               Failed err      -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
 189                                  return (Failed err)
 190               Succeeded iface ->
 191                 let
 192                     iface_fm' = addToFM iface_fm mod iface
 193                     orig_fm'  = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
 194                 in
 195                 writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO`
 196                 return (want_iface iface orig_fm')
 197   where
 198     want_iface iface orig_fm
 199       | want_orig_iface
 200       = case lookupFM orig_fm mod of
 201           Nothing         -> Failed (noOrigIfaceErr mod)
 202           Just orig_iface -> Succeeded orig_iface
 203       | otherwise
 204       = Succeeded iface
 205
 206     iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod
 207
 208 ----------
 209 mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
 210             (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
 211   = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
 212                                     ppStr "merged with", ppPStr mod1]) $
 213     ASSERT(mod1 == mod2)
 214     ParsedIface mod1
 215         (True, unionBags files2 files1)
 216         (panic "mergeIface: module version numbers")
 217         (panic "mergeIface: source version numbers")    -- Version numbers etc must be extracted from
 218         (panic "mergeIface: usage version numbers")     -- the merged file interfaces named above
 219         (panic "mergeIface: decl version numbers")
 220         (panic "mergeIface: exports")
 221         (panic "mergeIface: instance modules")
 222         (plusFM_C (dup_merge "fixity"      (ppr PprDebug . fixDeclName)) fixes1 fixes2)
 223         (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm))    tdefs1 tdefs2)
 224         (plusFM_C (dup_merge "value"       (ppr PprDebug . idecl_nm))    vdefs1 vdefs2)
 225         (unionBags idefs1 idefs2)
 226         (plusFM_C (dup_merge "pragma"      ppStr)                        prags1 prags2)
 227   where
 228     dup_merge str ppr_dup dup1 dup2
 229       = pprTrace "mergeIfaces:"
 230                  (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
 231                          ppr_dup dup1, ppr_dup dup2]) $
 232         dup2
 233
 234     idecl_nm (TypeSig    n _ _)     = n
 235     idecl_nm (NewTypeSig n _ _ _)   = n
 236     idecl_nm (DataSig    n _ _ _ _) = n
 237     idecl_nm (ClassSig   n _ _ _)   = n
 238     idecl_nm (ValSig     n _ _)     = n
 239
 240 ----------
 241 cachedDecl :: IfaceCache
 242            -> Bool      -- True <=> tycon or class name
 243            -> RdrName
 244            -> IO (MaybeErr RdrIfaceDecl Error)
 245
 246 cachedDecl iface_cache class_or_tycon orig
 247   = -- pprTrace "cachedDecl:" (ppr PprDebug orig) $
 248     cachedIface True iface_cache mod    >>= \ maybe_iface ->
 249     case maybe_iface of
 250       Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
 251                     return (Failed err)
 252       Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
 253         case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
 254           Just decl -> return (Succeeded decl)
 255           Nothing   -> return (Failed (noDeclInIfaceErr mod str))
 256   where
 257     (mod, str) = moduleNamePair orig
 258
 259 ----------
 260 cachedDeclByType :: IfaceCache
 261                  -> RnName{-NB: diff type than cachedDecl -}
 262                  -> IO (MaybeErr RdrIfaceDecl Error)
 263
 264 cachedDeclByType iface_cache rn
 265     -- the idea is: check that, e.g., if we're given an
 266     -- RnClass, then we really get back a ClassDecl from
 267     -- the cache (not an RnData, or something silly)
 268   = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn)  >>= \ maybe_decl ->
 269     let
 270         return_maybe_decl = return maybe_decl
 271         return_failed msg = return (Failed msg)
 272     in
 273     case maybe_decl of
 274       Failed io_msg -> return_failed (ifaceIoErr io_msg rn)
 275       Succeeded if_decl ->
 276         case rn of
 277           WiredInId _       -> return_failed (ifaceLookupWiredErr "value" rn)
 278           WiredInTyCon _    -> return_failed (ifaceLookupWiredErr "type constructor" rn)
 279           RnUnbound _       -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
 280
 281           RnSyn _           -> return_maybe_decl
 282           RnData _ _ _      -> return_maybe_decl
 283           RnImplicitTyCon _ -> if is_tycon_decl if_decl
 284                                then return_maybe_decl
 285                                else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
 286
 287           RnClass _ _       -> return_maybe_decl
 288           RnImplicitClass _ -> if is_class_decl if_decl
 289                                then return_maybe_decl
 290                                else return_failed (badIfaceLookupErr "class" rn if_decl)
 291
 292           RnName _          -> return_maybe_decl
 293           RnConstr _ _      -> return_maybe_decl
 294           RnField _ _       -> return_maybe_decl
 295           RnClassOp _ _     -> return_maybe_decl
 296           RnImplicit _      -> if is_val_decl if_decl
 297                                then return_maybe_decl
 298                                else return_failed (badIfaceLookupErr "value" rn if_decl)
 299   where
 300     is_tycon_decl (TypeSig _ _ _)       = True
 301     is_tycon_decl (NewTypeSig _ _ _ _)  = True
 302     is_tycon_decl (DataSig _ _ _ _ _)   = True
 303     is_tycon_decl _                     = False
 304
 305     is_class_decl (ClassSig _ _ _ _)    = True
 306     is_class_decl _                     = False
 307
 308     is_val_decl (ValSig _ _ _)          = True
 309     is_val_decl (DataSig _ _ _ _ _)     = True  -- may be a constr or field
 310     is_val_decl (NewTypeSig _ _ _ _)    = True  -- may be a constr
 311     is_val_decl (ClassSig _ _ _ _)      = True  -- may be a method
 312     is_val_decl _                       = False
 313 \end{code}
 314
 315 \begin{code}
 316 readIface :: FilePath -> Module
 317               -> IO (MaybeErr ParsedIface Error)
 318
 319 readIface file mod
 320   = hPutStr stderr ("  reading "++file) >>
 321     readFile file               `thenPrimIO` \ read_result ->
 322     case read_result of
 323       Left  err      -> return (Failed (cannaeReadErr file err))
 324       Right contents -> hPutStr stderr ".."   >>
 325                         let parsed = parseIface contents in
 326                         hPutStr stderr "..\n" >>
 327                         return (
 328                         case parsed of
 329                           Failed _    -> parsed
 330                           Succeeded p -> Succeeded (init_merge mod p)
 331                         )
 332   where
 333     init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
 334       = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
 335 \end{code}
 336
 337
 338 \begin{code}
 339 rnIfaces :: IfaceCache                  -- iface cache (mutvar)
 340          -> [Module]                    -- directly imported modules
 341          -> UniqSupply
 342          -> RnEnv                       -- defined (in the source) name env
 343          -> RnEnv                       -- mentioned (in the source) name env
 344          -> RenamedHsModule             -- module to extend with iface decls
 345          -> [RnName]                    -- imported names required (really the
 346                                         -- same info as in mentioned name env)
 347                                         -- Also, all the things we may look up
 348                                         -- later by key (Unique).
 349          -> IO (RenamedHsModule,        -- extended module
 350                 RnEnv,                  -- final env (for renaming derivings)
 351                 ImplicitEnv,            -- implicit names used (for usage info)
 352                 (UsagesMap,VersionsMap,[Module]),       -- usage info
 353                 (Bag Error, Bag Warning))
 354
 355 rnIfaces iface_cache imp_mods us
 356          def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
 357          occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
 358          rn_module@(HsModule modname iface_version exports imports fixities
 359                       typedecls typesigs classdecls instdecls instsigs
 360                       defdecls binds sigs src_loc)
 361          todo
 362   = {-
 363     pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
 364     pprTrace "rnIfaces:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
 365     pprTrace "rnIfaces:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
 366     pprTrace "rnIfaces:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
 367     pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
 368
 369     pprTrace "rnIfaces:dqual:"     (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
 370     pprTrace "rnIfaces:dunqual:"   (ppCat (map ppPStr (keysFM dunqual))) $
 371     pprTrace "rnIfaces:dtc_qual:"  (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
 372     pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
 373     -}
 374
 375     -- do transitive closure to bring in all needed names/defns and insts:
 376
 377     decls_and_insts todo def_env occ_env empty_return us
 378         >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
 379                 if_implicits,
 380                 if_errs_warns),
 381                if_final_env) ->
 382
 383     -- finalize what we want to say we learned about the
 384     -- things we used
 385     finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
 386         \ usage_stuff@(usage_info, version_info, instance_mods) ->
 387
 388     return (HsModule modname iface_version exports imports fixities
 389                  (typedecls ++ if_typedecls)
 390                  typesigs
 391                  (classdecls ++ if_classdecls)
 392                  (instdecls  ++ if_instdecls)
 393                  instsigs defdecls binds
 394                  (sigs ++ if_sigs)
 395                  src_loc,
 396             if_final_env,
 397             if_implicits,
 398             usage_stuff,
 399             if_errs_warns)
 400   where
 401     decls_and_insts todo def_env occ_env to_return us
 402       = do_decls todo                    -- initial batch of names to process
 403                  (def_env, occ_env, us1) -- init stuff down
 404                  to_return               -- acc results
 405            >>= \ (decls_return,
 406                   decls_def_env,
 407                   decls_occ_env) ->
 408
 409         cacheInstModules iface_cache imp_mods >>= \ errs ->
 410
 411         do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
 412                  (add_errs errs decls_return) us2
 413       where
 414         (us1,us2) = splitUniqSupply us
 415
 416     do_insts def_env occ_env prev_env done_insts to_return us
 417       | size_tc_env occ_env == size_tc_env prev_env
 418       = return (to_return, occ_env)
 419
 420       | otherwise
 421       = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
 422            >>= \ (insts_return,
 423                   new_insts,
 424                   insts_occ_env,
 425                   new_unknowns) ->
 426
 427         do_decls new_unknowns                   -- new batch of names to process
 428                  (def_env, insts_occ_env, us2)  -- init stuff down
 429                  insts_return                   -- acc results
 430            >>= \ (decls_return,
 431                   decls_def_env,
 432                   decls_occ_env) ->
 433
 434         do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
 435       where
 436         (us1,us') = splitUniqSupply us
 437         (us2,us3) = splitUniqSupply us'
 438
 439         size_tc_env ((_, _, qual, unqual), _)
 440           = sizeFM qual + sizeFM unqual
 441
 442
 443     do_decls :: [RnName]        -- Names we're looking for; we keep adding/deleting
 444                                 -- from this list; we're done when empty (nothing
 445                                 -- more needs to be looked for)
 446              -> Go_Down         -- see defn below
 447              -> To_Return       -- accumulated result
 448              -> IO (To_Return,
 449                     RnEnv,      -- extended decl env
 450                     RnEnv)      -- extended occ env
 451
 452     do_decls to_find@[] down to_return
 453       = return (to_return, defenv down, occenv down)
 454
 455     do_decls to_find@(n:ns) down to_return
 456       = case (lookup_defd down n) of
 457           Just  _ -> -- previous processing must've found the stuff for this name;
 458                      -- continue with the rest:
 459                      -- pprTrace "do_decls:done:" (ppr PprDebug n) $
 460                      do_decls ns down to_return
 461
 462           Nothing
 463            | fst (moduleNamePair n) == modname ->
 464                      -- avoid looking in interface for the module being compiled
 465                      --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
 466                      do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
 467
 468            | otherwise ->
 469                      -- OK, see what the cache has for us...
 470
 471              cachedDeclByType iface_cache n >>= \ maybe_ans ->
 472              case maybe_ans of
 473                Failed err -> -- add the error, but keep going:
 474                              --pprTrace "do_decls:cache error:" (ppr PprDebug n) $
 475                              do_decls ns down (add_err err to_return)
 476
 477                Succeeded iface_decl -> -- something needing renaming!
 478                  let
 479                     (us1, us2) = splitUniqSupply (uniqsupply down)
 480                  in
 481                  case (initRn False{-iface-} modname (occenv down) us1 (
 482                         setExtraRn emptyUFM{-no fixities-} $
 483                         rnIfaceDecl iface_decl)) of {
 484                   ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
 485                     let
 486                         new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
 487                     in
 488                     {-
 489                     pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
 490                         , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
 491                         , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
 492                         , ppCat [ppStr "defd  tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
 493                         ]) $
 494                     -}
 495                     do_decls (new_unknowns ++ ns)
 496                              (add_occs       if_defd if_implicits $
 497                                new_uniqsupply us2 down)
 498                              (add_decl       if_decl            $
 499                                add_implicits if_implicits       $
 500                                 add_errs     if_errs            $
 501                                  add_warns   if_warns to_return)
 502                  }
 503
 504 -----------
 505 type Go_Down   = (RnEnv,        -- stuff we already have defns for;
 506                                 -- to check quickly if we've already
 507                                 -- found something for the name under consideration,
 508                                 -- due to previous processing.
 509                                 -- It starts off just w/ the defns for
 510                                 -- the things in this module.
 511                   RnEnv,        -- occurrence env; this gets added to as
 512                                 -- we process new iface decls.  It includes
 513                                 -- entries for *all* occurrences, including those
 514                                 -- for which we have definitions.
 515                   UniqSupply    -- the obvious
 516                  )
 517
 518 lookup_defd (def_env, _, _) n
 519   | isRnTyConOrClass n
 520   = lookupTcRnEnv def_env (origName n)
 521   | otherwise
 522   = lookupRnEnv def_env (origName n)
 523
 524 defenv     (def_env, _, _) = def_env
 525 occenv     (_, occ_env, _) = occ_env
 526 uniqsupply (_, _,      us) = us
 527
 528 new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
 529
 530 add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
 531   = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
 532     (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
 533 --  ASSERT(isEmptyBag def_dups)
 534     let
 535         val_occs = val_defds ++ fmToList val_imps
 536         tc_occs  = tc_defds  ++ fmToList tc_imps
 537     in
 538     case (extendGlobalRnEnv occ_env val_occs tc_occs)   of { (new_occ_env, occ_dups) ->
 539
 540 --  ASSERT(isEmptyBag occ_dups)
 541 --  False because we may get a dup on the name we just shoved in
 542
 543     (new_def_env, new_occ_env, us) }}
 544
 545 ----------------
 546 type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
 547                   ImplicitEnv,  -- new names used implicitly
 548                   (Bag Error, Bag Warning)
 549                  )
 550
 551 empty_return :: To_Return
 552 empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
 553
 554 add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
 555   = case decl of
 556       AddedTy    t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
 557       AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
 558       AddedSig   s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
 559
 560 add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
 561   = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
 562
 563 add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
 564   = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM`  tc_imps), msgs)
 565
 566 add_err  err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag`   err,warns))
 567 add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
 568 add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
 569 add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
 570 \end{code}
 571
 572 \begin{code}
 573 data AddedDecl -- purely local
 574   = AddedTy     RenamedTyDecl
 575   | AddedClass  RenamedClassDecl
 576   | AddedSig    RenamedSig
 577
 578 rnIfaceDecl :: RdrIfaceDecl
 579             -> RnM_Fixes _RealWorld
 580                    (AddedDecl,  -- the resulting decl to add to the pot
 581                     ([(RdrName,RnName)], [(RdrName,RnName)]),
 582                                 -- new val/tycon-class names that have
 583                                 -- *been defined* while processing this decl
 584                     ImplicitEnv -- new implicit val/tycon-class names that we
 585                                 -- stumbled into
 586                    )
 587
 588 rnIfaceDecl (TypeSig tc _ decl)
 589   = rnTyDecl    decl    `thenRn` \ rn_decl   ->
 590     lookupTyCon tc      `thenRn` \ rn_tc     ->
 591     getImplicitUpRn     `thenRn` \ mentioned ->
 592     let
 593         defds = ([], [(tc, rn_tc)])
 594         implicits = mentioned `sub` defds
 595     in
 596     returnRn (AddedTy rn_decl, defds, implicits)
 597
 598 rnIfaceDecl (NewTypeSig tc dc _ decl)
 599   = rnTyDecl    decl    `thenRn` \ rn_decl   ->
 600     lookupTyCon tc      `thenRn` \ rn_tc     ->
 601     lookupValue dc      `thenRn` \ rn_dc     ->
 602     getImplicitUpRn     `thenRn` \ mentioned ->
 603     let
 604         defds = ([(dc, rn_dc)], [(tc, rn_tc)])
 605         implicits = mentioned `sub` defds
 606     in
 607     returnRn (AddedTy rn_decl, defds, implicits)
 608
 609 rnIfaceDecl (DataSig tc dcs fcs _ decl)
 610   = rnTyDecl    decl            `thenRn` \ rn_decl   ->
 611     lookupTyCon tc              `thenRn` \ rn_tc     ->
 612     mapRn lookupValue dcs       `thenRn` \ rn_dcs    ->
 613     mapRn lookupValue fcs       `thenRn` \ rn_fcs    ->
 614     getImplicitUpRn             `thenRn` \ mentioned ->
 615     let
 616         defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
 617         implicits = mentioned `sub` defds
 618     in
 619     returnRn (AddedTy rn_decl, defds, implicits)
 620
 621 rnIfaceDecl (ClassSig clas ops _ decl)
 622   = rnClassDecl decl                    `thenRn` \ rn_decl   ->
 623     lookupClass clas                    `thenRn` \ rn_clas   ->
 624     mapRn (lookupClassOp rn_clas) ops   `thenRn` \ rn_ops    ->
 625     getImplicitUpRn                     `thenRn` \ mentioned ->
 626     let
 627         defds = (ops `zip` rn_ops, [(clas, rn_clas)])
 628         implicits = mentioned `sub` defds
 629     in
 630     returnRn (AddedClass rn_decl, defds, implicits)
 631
 632 rnIfaceDecl (ValSig f src_loc ty)
 633     -- should rename_sig in RnBinds be used here? ToDo
 634   = lookupValue f                       `thenRn` \ rn_f  ->
 635     -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
 636     rnPolyType nullTyVarNamesEnv ty     `thenRn` \ rn_ty ->
 637     getImplicitUpRn                     `thenRn` \ mentioned ->
 638     let
 639         defds = ([(f, rn_f)], [])
 640         implicits = mentioned `sub` defds
 641     in
 642     returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
 643
 644 ----
 645 sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
 646
 647 sub (val_ment, tc_ment) (val_defds, tc_defds)
 648   = (delListFromFM val_ment (map fst val_defds),
 649      delListFromFM tc_ment  (map fst tc_defds))
 650 \end{code}
 651
 652 % ------------------------------
 653
 654 @cacheInstModules@: cache instance modules specified in imports
 655
 656 \begin{code}
 657 cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
 658 cacheInstModules iface_cache imp_mods
 659   = readVar iface_cache         `thenPrimIO` \ (iface_fm, _, _) ->
 660     let
 661         imp_ifaces      = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
 662         (imp_imods, _)  = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
 663         get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
 664     in
 665     --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
 666     accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
 667
 668     -- Sanity Check:
 669     -- Assert that instance modules given by direct imports contains
 670     -- instance modules extracted from all visited modules
 671
 672     readVar iface_cache         `thenPrimIO` \ (all_iface_fm, _, _) ->
 673     let
 674         all_ifaces     = eltsFM all_iface_fm
 675         (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
 676     in
 677     ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
 678
 679     return (bag_errs err_or_ifaces)
 680   where
 681     bag_errs [] = emptyBag
 682     bag_errs (Failed err :rest) = err `consBag` bag_errs rest
 683     bag_errs (Succeeded _:rest) = bag_errs rest
 684 \end{code}
 685
 686
 687 @rnIfaceInstStuff@: Deal with instance declarations from interface files.
 688
 689 \begin{code}
 690 type InstanceEnv = FiniteMap (RdrName, RdrName) Int
 691
 692 rnIfaceInstStuff
 693         :: IfaceCache           -- all about ifaces we've read
 694         -> Module
 695         -> UniqSupply
 696         -> RnEnv                -- current occ env
 697         -> InstanceEnv          -- instances for these tycon/class pairs done
 698         -> To_Return
 699         -> IO (To_Return,
 700                InstanceEnv,     -- extended instance env
 701                RnEnv,           -- final occ env
 702                [RnName])        -- new unknown names
 703
 704 rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
 705   = -- all the instance decls we might even want to consider
 706     -- are in the ParsedIfaces that are in our cache
 707
 708     readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) ->
 709     let
 710         all_ifaces        = eltsFM orig_iface_fm
 711         all_insts         = unionManyBags (map get_insts all_ifaces)
 712         interesting_insts = filter want_inst (bagToList all_insts)
 713
 714         -- Sanity Check:
 715         -- Assert that there are no more instances for the done instances
 716
 717         claim_done       = filter is_done_inst (bagToList all_insts)
 718         claim_done_env   = foldr add_done_inst emptyFM claim_done
 719         has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
 720     in
 721     {-
 722       pprTrace "all_insts:\n"         (ppr_insts (bagToList all_insts)) $
 723       pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
 724     -}
 725     ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
 726     ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
 727
 728     case (initRn False{-iface-} modname occ_env us (
 729             setExtraRn emptyUFM{-no fixities-}  $
 730             mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
 731             getImplicitUpRn                     `thenRn` \ implicits ->
 732             returnRn (insts, implicits))) of {
 733       ((if_insts, if_implicits), if_errs, if_warns) ->
 734
 735         return (add_insts      if_insts         $
 736                  add_implicits if_implicits     $
 737                   add_errs     if_errs          $
 738                    add_warns   if_warns to_return,
 739                 foldr add_done_inst done_inst_env interesting_insts,
 740                 add_imp_occs if_implicits occ_env,
 741                 eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
 742     }
 743   where
 744     get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts
 745
 746     add_done_inst (InstSig clas tycon _ _) inst_env
 747       = addToFM_C (+) inst_env (tycon,clas) 1
 748
 749     is_done_inst (InstSig clas tycon _ _)
 750       = maybeToBool (lookupFM done_inst_env (tycon,clas))
 751
 752     add_imp_occs (val_imps, tc_imps) occ_env
 753       = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
 754           (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
 755                                      ext_occ_env
 756
 757     want_inst i@(InstSig clas tycon _ _)
 758       = -- it's a "good instance" (one to hang onto) if we have a
 759         -- chance of referring to *both* the class and tycon later on ...
 760         --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
 761         mentionable tycon && mentionable clas && not (is_done_inst i)
 762       where
 763         mentionable nm
 764           = case lookupTcRnEnv occ_env nm of
 765               Just  _ -> True
 766               Nothing -> -- maybe it's builtin
 767                 let str_mod = case nm of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
 768                 in case (lookupFM b_tc_names str_mod) of
 769                       Just  _ -> True
 770                       Nothing -> maybeToBool (lookupFM b_keys str_mod)
 771
 772     (b_tc_names, b_keys) -- pretty UGLY ...
 773       = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
 774
 775     ppr_insts insts
 776       = ppAboves (map ppr_inst insts)
 777       where
 778         ppr_inst (InstSig c t _ inst_decl)
 779           = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
 780 \end{code}
 781
 782 \begin{code}
 783 rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
 784
 785 rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
 786 \end{code}
 787
 788 \begin{code}
 789 type BigMaps = (FiniteMap Module Version, -- module-version map
 790                 FiniteMap (FAST_STRING,Module) Version) -- ordinary version map
 791
 792 finalIfaceInfo ::
 793            IfaceCache                   -- iface cache
 794         -> Module                       -- this module's name
 795         -> RnEnv
 796         -> [RenamedInstDecl]
 797 --      -> [RnName]                     -- all imported names required
 798 --      -> [Module]                     -- directly imported modules
 799         -> IO (UsagesMap,
 800                VersionsMap,             -- info about version numbers
 801                [Module])                -- special instance modules
 802
 803 finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
 804   =
 805 --  pprTrace "usageIf:qual:"      (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
 806 --  pprTrace "usageIf:unqual:"    (ppCat (map ppPStr (keysFM unqual))) $
 807 --  pprTrace "usageIf:tc_qual:"   (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
 808 --  pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
 809     readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) ->
 810     let
 811         all_ifaces = eltsFM orig_iface_fm
 812         -- all the interfaces we have looked at
 813
 814         big_maps
 815           -- combine all the version maps we have seen into maps to
 816           -- (a) lookup a module-version number, lookup an entity's
 817           -- individual version number
 818           = foldr mk_map (emptyFM,emptyFM) all_ifaces
 819
 820         val_stuff@(val_usages, val_versions)
 821           = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
 822
 823         (all_usages, all_versions)
 824           = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
 825     in
 826     return (all_usages, all_versions, [])
 827   where
 828     mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
 829       = (addToFM     mv_map  m mv, -- add this module
 830          addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])
 831
 832     -----------------------
 833     process_item :: BigMaps
 834                  -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
 835                  -> (UsagesMap, VersionsMap)       -- input
 836                  -> (UsagesMap, VersionsMap)       -- output
 837
 838     process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
 839       | irrelevant rn
 840       = as_before
 841       | m == modname -- this module => add to "versions"
 842       = (usages, addToFM versions n 1{-stub-})
 843       | otherwise  -- from another module => add to "usages"
 844       = (add_to_usages usages key, versions)
 845       where
 846         add_to_usages usages key@(n,m)
 847           = let
 848                 mod_v = case (lookupFM big_mv_map m) of
 849                           Nothing -> pprTrace "big_mv_map:miss? " (ppPStr m) $
 850                                      1
 851                           Just nv -> nv
 852                 key_v = case (lookupFM big_version_map key) of
 853                           Nothing -> pprTrace "big_version_map:miss? " (ppCat [ppPStr n, ppPStr m]) $
 854                                      1
 855                           Just nv -> nv
 856             in
 857             addToFM usages m (
 858                 case (lookupFM usages m) of
 859                   Nothing -> -- nothing for this module yet...
 860                     (mod_v, unitFM n key_v)
 861
 862                   Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
 863                     ASSERT(mversion == mod_v)
 864                     (mversion, addToFM mstuff n key_v)
 865             )
 866
 867     irrelevant (RnConstr  _ _) = True   -- We don't report these in their
 868     irrelevant (RnField   _ _) = True   -- own right in usages/etc.
 869     irrelevant (RnClassOp _ _) = True
 870     irrelevant (RnImplicit  n) = isRdrLexCon (origName n) -- really a RnConstr
 871     irrelevant _               = False
 872
 873 \end{code}
 874
 875
 876 \begin{code}
 877 thisModImplicitWarn mod n sty
 878   = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppPStr mod, ppChar '.', ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
 879
 880 noIfaceErr mod sty
 881   = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
 882
 883 noOrigIfaceErr mod sty
 884   = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]
 885
 886 noDeclInIfaceErr mod str sty
 887   = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
 888                ppPStr mod, ppStr ".", ppPStr str]
 889
 890 cannaeReadErr file err sty
 891   = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
 892
 893 ifaceLookupWiredErr msg n sty
 894   = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
 895
 896 badIfaceLookupErr msg name decl sty
 897   = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
 898
 899 ifaceIoErr io_msg rn sty
 900   = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
 901 \end{code}