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