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