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