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