ghc/compiler/rename/RnIfaces.lhs

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