ghc/compiler/rename/Rename.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1996
   3 %
   4 \section[Rename]{Renaming and dependency analysis passes}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Rename ( renameModule ) where
  10
  11 import PreludeGlaST     ( thenPrimIO, newVar, MutableVar(..) )
  12
  13 IMP_Ubiq()
  14
  15 import HsSyn
  16 import RdrHsSyn         ( RdrNameHsModule(..), RdrNameImportDecl(..) )
  17 import RnHsSyn          ( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
  18
  19 --ToDo:rm: all for debugging only
  20 import Maybes
  21 import Name
  22 import Outputable
  23 import RnIfaces
  24 import PprStyle
  25 import Pretty
  26 import FiniteMap
  27 import Util (pprPanic, pprTrace)
  28
  29 import ParseUtils       ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
  30                           UsagesMap(..), VersionsMap(..)
  31                         )
  32 import RnMonad
  33 import RnNames          ( getGlobalNames, GlobalNameInfo(..) )
  34 import RnSource         ( rnSource )
  35 import RnIfaces         ( rnIfaces )
  36 import RnUtils          ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv )
  37
  38 import Bag              ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
  39 import CmdLineOpts      ( opt_HiMap, opt_NoImplicitPrelude )
  40 import ErrUtils         ( Error(..), Warning(..) )
  41 import FiniteMap        ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
  42 import Maybes           ( catMaybes )
  43 import Name             ( isLocallyDefined, mkWiredInName, Name, RdrName(..) )
  44 import PrelInfo         ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
  45 import Unique           ( ixClassKey )
  46 import UniqFM           ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
  47 import UniqSupply       ( splitUniqSupply )
  48 import Util             ( panic, assertPanic )
  49 \end{code}
  50
  51 \begin{code}
  52 renameModule :: UniqSupply
  53              -> RdrNameHsModule
  54
  55              -> IO (RenamedHsModule,    -- output, after renaming
  56                     RnEnv,              -- final env (for renaming derivings)
  57                     [Module],           -- imported modules; for profiling
  58
  59                     (UsagesMap,
  60                     VersionsMap,        -- version info; for usage
  61                     [Module]),          -- instance modules; for iface
  62
  63                     Bag Error,
  64                     Bag Warning)
  65 \end{code}
  66
  67 ToDo: May want to arrange to return old interface for this module!
  68 ToDo: Deal with instances (instance version, this module on instance list ???)
  69
  70 \begin{code}
  71 renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
  72
  73   = let
  74         (b_names, b_keys, _) = builtinNameInfo
  75         pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
  76     in
  77     {-
  78     pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
  79                             ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
  80                                      , ppCat (map pp_pair (keysFM builtin_tcs))
  81                                      , ppCat (map pp_pair (keysFM b_keys))
  82                                      ]}) $
  83     -}
  84     makeHiMap opt_HiMap     >>=          \ hi_files ->
  85 --  pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
  86     newVar (emptyFM,emptyFM,hi_files){-init iface cache-}  `thenPrimIO` \ iface_cache ->
  87
  88     fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
  89     let
  90         rec_occ_fn :: Name -> [RdrName]
  91         rec_occ_fn n = case lookupUFM rec_occ_fm n of
  92                          Nothing        -> []
  93                          Just (rn,occs) -> occs
  94
  95         global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
  96     in
  97     getGlobalNames iface_cache global_name_info us1 input >>=
  98         \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
  99
 100     if not (isEmptyBag top_errs) then
 101         return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
 102     else
 103
 104     -- No top-level name errors so rename source ...
 105     case initRn True modname occ_env us2
 106                 (rnSource imp_mods unqual_imps imp_fixes input) of {
 107         ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
 108
 109     --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
 110
 111     let
 112         occ_fm :: UniqFM (RnName, [RdrName])
 113
 114         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
 115         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
 116
 117         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
 118
 119         insert new []         = [new]
 120         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
 121                                                   EQ_  -> xxs
 122                                                   GT__ -> x : insert new xs
 123
 124         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 125         multiple_occs (rn, (o1:o2:_)) = True
 126         multiple_occs _               = False
 127     in
 128     return (rn_module, imp_mods,
 129             top_errs  `unionBags` src_errs,
 130             top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 131             occ_fm, export_fn)
 132
 133     }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
 134
 135     if not (isEmptyBag errs_so_far) then
 136         return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
 137     else
 138
 139     -- No errors renaming source so rename the interfaces ...
 140     let
 141         -- split up all names that occurred in the source; between
 142         -- those that are defined therein and those merely mentioned.
 143         -- We also divide by tycon/class and value names (as usual).
 144
 145         occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
 146                 -- all occurrence names, from this module and imported
 147
 148         (defined_here, defined_elsewhere)
 149           = partition isLocallyDefined occ_rns
 150
 151         (_, imports_used)
 152           = partition isRnWired defined_elsewhere
 153
 154         (def_tcs, def_vals) = partition isRnTyConOrClass defined_here
 155         (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
 156                 -- the occ stuff includes *all* occurrences,
 157                 -- including those for which we have definitions
 158
 159         (orig_def_env, orig_def_dups)
 160           = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals)
 161                                          (map pairify_rn def_tcs)
 162         (orig_occ_env, orig_occ_dups)
 163           = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals)
 164                                          (map pairify_rn occ_tcs)
 165
 166         -- This stuff is pretty dodgy right now: I think original
 167         -- names and occurrence names may be getting entangled
 168         -- when they shouldn't be... WDP 96/06
 169
 170         pairify_rn rn -- ToDo: move to Name?
 171           = let
 172                 name = getName rn
 173             in
 174             (if isLocalName name
 175              then Unqual (getLocalName name)
 176              else case (origName "pairify_rn" name) of { OrigName m n ->
 177                   Qual m n }
 178              , rn)
 179
 180         must_haves
 181           | opt_NoImplicitPrelude
 182           = [{-no Prelude.hi, no point looking-}]
 183           | otherwise
 184           = [ name_fn (mkWiredInName u orig)
 185             | (orig@(OrigName mod str), (u, name_fn)) <- fmToList b_keys,
 186               str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
 187     in
 188 --  ASSERT (isEmptyBag orig_occ_dups)
 189     (if (isEmptyBag orig_occ_dups) then \x->x
 190      else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
 191     ASSERT (isEmptyBag orig_def_dups)
 192
 193     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
 194              rn_module (must_haves ++ imports_used) >>=
 195         \ (rn_module_with_imports, final_env,
 196            (implicit_val_fm, implicit_tc_fm),
 197            usage_stuff,
 198            (iface_errs, iface_warns)) ->
 199
 200     return (rn_module_with_imports,
 201             final_env,
 202             imp_mods,
 203             usage_stuff,
 204             errs_so_far  `unionBags` iface_errs,
 205             warns_so_far `unionBags` iface_warns)
 206   where
 207     rn_panic = panic "renameModule: aborted with errors"
 208
 209     (us1, us') = splitUniqSupply us
 210     (us2, us3) = splitUniqSupply us'
 211 \end{code}
 212
 213 \begin{code}
 214 makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
 215
 216 makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
 217 makeHiMap (Just f)
 218   = readFile f  >>= \ cts ->
 219     return (snag_mod emptyFM cts [])
 220   where
 221     -- we alternate between "snag"ging mod(ule names) and path(names),
 222     -- accumulating names (reversed) and the final resulting map
 223     -- as we move along.
 224
 225     snag_mod map  []       []   = map
 226     snag_mod map  (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
 227     snag_mod map  (c:cs)   rmod = snag_mod  map cs (c:rmod)
 228
 229     snag_path map mod []        rpath = addToFM map mod (reverse rpath)
 230     snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
 231     snag_path map mod (c:cs)    rpath = snag_path map mod cs (c:rpath)
 232 \end{code}
 233
 234 Warning message used herein:
 235 \begin{code}
 236 multipleOccWarn (name, occs) sty
 237   = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
 238                ppInterleave ppComma (map (ppr sty) occs)]
 239 \end{code}