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