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