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