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, returnPrimIO, fixPrimIO, newVar, MutableVar(..) )
  12
  13 import Ubiq
  14
  15 import HsSyn
  16 import RdrHsSyn         ( RdrNameHsModule(..), RdrNameImportDecl(..) )
  17 import RnHsSyn          ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass )
  18
  19 import ParseIface       ( ParsedIface )
  20 import RnMonad
  21 import RnNames          ( getGlobalNames, GlobalNameInfo(..) )
  22 import RnSource         ( rnSource )
  23 import RnIfaces         ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) )
  24 import RnUtils          ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
  25 import MainMonad
  26
  27 import Bag              ( isEmptyBag, unionBags, bagToList, listToBag )
  28 import CmdLineOpts      ( opt_HiDirList, opt_SysHiDirList )
  29 import ErrUtils         ( Error(..), Warning(..) )
  30 import FiniteMap        ( emptyFM, eltsFM )
  31 import Name             ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) )
  32 import PrelInfo         ( BuiltinNames(..), BuiltinKeys(..) )
  33 import UniqFM           ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
  34 import UniqSupply       ( splitUniqSupply )
  35 import Util             ( panic, assertPanic )
  36 \end{code}
  37
  38 \begin{code}
  39 renameModule :: BuiltinNames
  40              -> BuiltinKeys
  41              -> UniqSupply
  42              -> RdrNameHsModule
  43
  44              -> MainIO
  45                 (
  46                  RenamedHsModule,  -- output, after renaming
  47                  [Module],         -- imported modules; for profiling
  48
  49                  VersionInfo,      -- version info; for usage
  50                  [Module],         -- instance modules; for iface
  51
  52                  Bag Error,
  53                  Bag Warning
  54                 )
  55 \end{code}
  56
  57 ToDo: May want to arrange to return old interface for this module!
  58 ToDo: Return OrigName RnEnv to rename derivings etc with.
  59 ToDo: Builtin names which must be read.
  60 ToDo: Deal with instances (instance version, this module on instance list ???)
  61
  62 \begin{code}
  63 renameModule b_names b_keys us
  64              input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
  65
  66   = findHiFiles opt_HiDirList opt_SysHiDirList  `thenMn`     \ hi_files ->
  67     newVar (emptyFM, hi_files)                  `thenPrimIO` \ iface_var ->
  68
  69     fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
  70     let
  71         rec_occ_fn :: Name -> [RdrName]
  72         rec_occ_fn n = case lookupUFM rec_occ_fm n of
  73                          Nothing        -> []
  74                          Just (rn,occs) -> occs
  75
  76         global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
  77     in
  78     getGlobalNames iface_var global_name_info us1 input
  79                 `thenPrimIO` \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
  80
  81     if not (isEmptyBag top_errs) then
  82         returnPrimIO (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
  83     else
  84
  85     -- No top-level name errors so rename source ...
  86     case initRn True mod occ_env us2
  87                 (rnSource imp_mods unqual_imps imp_fixes input) of {
  88         ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
  89
  90     let
  91         occ_fm :: UniqFM (RnName, [RdrName])
  92
  93         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
  94         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
  95
  96         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
  97
  98         insert new []         = [new]
  99         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
 100                                                   EQ_  -> xxs
 101                                                   GT__ -> x : insert new xs
 102
 103         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 104         multiple_occs (rn, (o1:o2:_)) = True
 105         multiple_occs _               = False
 106     in
 107     returnPrimIO (rn_module, imp_mods,
 108                   top_errs  `unionBags` src_errs,
 109                   top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 110                   occ_fm, export_fn)
 111
 112     }) `thenPrimIO` \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
 113
 114     if not (isEmptyBag errs_so_far) then
 115         returnMn (rn_panic, rn_panic, rn_panic, rn_panic,
 116                   errs_so_far, warns_so_far)
 117     else
 118
 119     -- No errors renaming source so rename the interfaces ...
 120     let
 121         imports_used = [ rn | (rn,_) <- eltsUFM occ_fm, not (isLocallyDefined rn) ]
 122         (import_tcs, import_vals) = partition (\ rn -> isRnTyCon rn || isRnClass rn) imports_used
 123
 124         (orig_env, orig_dups) = extendGlobalRnEnv emptyRnEnv (map pair_orig import_vals)
 125                                                              (map pair_orig import_tcs)
 126         pair_orig rn = (getOrigNameRdr rn, rn)
 127
 128         -- ToDo: Do we need top-level names from this module in orig_env ???
 129     in
 130     ASSERT (isEmptyBag orig_dups)
 131     rnIfaces iface_var orig_env us3 rn_module imports_used
 132                 `thenPrimIO` \ (rn_module_with_imports,
 133                                 (implicit_val_fm, implicit_tc_fm),
 134                                 iface_errs, iface_warns) ->
 135     let
 136         all_imports_used = imports_used ++ eltsFM implicit_tc_fm ++ eltsFM implicit_val_fm
 137     in
 138     finalIfaceInfo iface_var all_imports_used imp_mods
 139                 `thenPrimIO` \ (version_info, instance_mods) ->
 140
 141     returnMn (rn_module_with_imports, imp_mods,
 142               version_info, instance_mods,
 143               errs_so_far  `unionBags` iface_errs,
 144               warns_so_far `unionBags` iface_warns)
 145
 146   where
 147     rn_panic = panic "renameModule: aborted with errors"
 148
 149     (us1, us') = splitUniqSupply us
 150     (us2, us3) = splitUniqSupply us'
 151 \end{code}