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