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 RnMonad
  20 import RnNames          ( getGlobalNames, GlobalNameInfo(..) )
  21 import RnSource         ( rnSource )
  22 import RnIfaces         ( findHiFiles, rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface )
  23 import RnUtils          ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
  24 import MainMonad
  25
  26 import Bag              ( isEmptyBag, unionBags, bagToList, listToBag )
  27 import ErrUtils         ( Error(..), Warning(..) )
  28 import FiniteMap        ( emptyFM, eltsFM )
  29 import Name             ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) )
  30 import PrelInfo         ( BuiltinNames(..), BuiltinKeys(..) )
  31 import UniqFM           ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
  32 import UniqSupply       ( splitUniqSupply )
  33 import Util             ( panic, assertPanic )
  34
  35 opt_HiDirList = panic "opt_HiDirList"
  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   = findHiFiles opt_HiDirList   `thenPrimIO` \ hi_files ->
  66     newVar (emptyFM, hi_files)  `thenPrimIO` \ iface_var ->
  67
  68     fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
  69     let
  70         rec_occ_fn :: Name -> [RdrName]
  71         rec_occ_fn n = case lookupUFM rec_occ_fm n of
  72                          Nothing        -> []
  73                          Just (rn,occs) -> occs
  74
  75         global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
  76     in
  77     getGlobalNames iface_var global_name_info us1 input
  78                 `thenPrimIO` \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
  79
  80     if not (isEmptyBag top_errs) then
  81         returnPrimIO (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
  82     else
  83
  84     -- No top-level name errors so rename source ...
  85     case initRn True mod occ_env us2
  86                 (rnSource imp_mods unqual_imps imp_fixes input) of {
  87         ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
  88
  89     let
  90         occ_fm :: UniqFM (RnName, [RdrName])
  91
  92         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
  93         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
  94
  95         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
  96
  97         insert new []         = [new]
  98         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
  99                                                   EQ_  -> xxs
 100                                                   GT__ -> x : insert new xs
 101
 102         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 103         multiple_occs (rn, (o1:o2:_)) = True
 104         multiple_occs _               = False
 105     in
 106     returnPrimIO (rn_module, imp_mods,
 107                   top_errs  `unionBags` src_errs,
 108                   top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 109                   occ_fm, export_fn)
 110
 111     }) `thenPrimIO` \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
 112
 113     if not (isEmptyBag errs_so_far) then
 114         returnMn (rn_panic, rn_panic, rn_panic, rn_panic,
 115                   errs_so_far, warns_so_far)
 116     else
 117
 118     -- No errors renaming source so rename the interfaces ...
 119     let
 120         imports_used = [ rn | (rn,_) <- eltsUFM occ_fm, not (isLocallyDefined rn) ]
 121         (import_tcs, import_vals) = partition (\ rn -> isRnTyCon rn || isRnClass rn) imports_used
 122
 123         (orig_env, orig_dups) = extendGlobalRnEnv emptyRnEnv (map pair_orig import_vals)
 124                                                              (map pair_orig import_tcs)
 125         pair_orig rn = (getOrigNameRdr rn, rn)
 126
 127         -- ToDo: Do we need top-level names from this module in orig_env ???
 128     in
 129     ASSERT (isEmptyBag orig_dups)
 130     rnInterfaces iface_var orig_env us3 rn_module imports_used
 131                 `thenPrimIO` \ (rn_module_with_imports,
 132                                 (implicit_val_fm, implicit_tc_fm),
 133                                 iface_errs, iface_warns) ->
 134     let
 135         all_imports_used = imports_used ++ eltsFM implicit_tc_fm ++ eltsFM implicit_val_fm
 136     in
 137     finalIfaceInfo iface_var all_imports_used imp_mods
 138                 `thenPrimIO` \ (version_info, instance_mods) ->
 139
 140     returnMn (rn_module_with_imports, imp_mods,
 141               version_info, instance_mods,
 142               errs_so_far  `unionBags` iface_errs,
 143               warns_so_far `unionBags` iface_warns)
 144
 145   where
 146     rn_panic = panic "renameModule: aborted with errors"
 147
 148     (us1, us') = splitUniqSupply us
 149     (us2, us3) = splitUniqSupply us'
 150 \end{code}