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