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