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, newVar, MutableVar(..) )
  12
  13 import Ubiq
  14
  15 import HsSyn
  16 import RdrHsSyn         ( RdrNameHsModule(..), RdrNameImportDecl(..) )
  17 import RnHsSyn          ( RnName, 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         ( findHiFiles, rnIfaces )
  36 import RnUtils          ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
  37
  38 import Bag              ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
  39 import CmdLineOpts      ( opt_HiDirList, opt_SysHiDirList )
  40 import ErrUtils         ( Error(..), Warning(..) )
  41 import FiniteMap        ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
  42 import Maybes           ( catMaybes )
  43 import Name             ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
  44 import PrelInfo         ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
  45 import PrelMods         ( pRELUDE )
  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                     (UsagesMap,
  60                     VersionsMap,        -- version info; for usage
  61                     [Module]),          -- instance modules; for iface
  62
  63                     Bag Error,
  64                     Bag Warning)
  65 \end{code}
  66
  67 ToDo: May want to arrange to return old interface for this module!
  68 ToDo: Builtin names which must be read.
  69 ToDo: Deal with instances (instance version, this module on instance list ???)
  70
  71 \begin{code}
  72 renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
  73
  74   = let
  75         (b_names, b_keys, _) = builtinNameInfo
  76     in
  77     --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
  78     --                      ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
  79     --                               , ppCat (map ppPStr (keysFM builtin_tcs))
  80     --                               , ppCat (map ppPStr (keysFM b_keys))
  81     --                               ]}) $
  82
  83     findHiFiles opt_HiDirList opt_SysHiDirList      >>=          \ hi_files ->
  84     newVar (emptyFM,emptyFM,hi_files){-init iface cache-}  `thenPrimIO` \ iface_cache ->
  85
  86     fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
  87     let
  88         rec_occ_fn :: Name -> [RdrName]
  89         rec_occ_fn n = case lookupUFM rec_occ_fm n of
  90                          Nothing        -> []
  91                          Just (rn,occs) -> occs
  92
  93         global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
  94     in
  95     getGlobalNames iface_cache global_name_info us1 input >>=
  96         \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
  97
  98     if not (isEmptyBag top_errs) then
  99         return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
 100     else
 101
 102     -- No top-level name errors so rename source ...
 103     case initRn True mod occ_env us2
 104                 (rnSource imp_mods unqual_imps imp_fixes input) of {
 105         ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
 106
 107     --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
 108
 109     let
 110         occ_fm :: UniqFM (RnName, [RdrName])
 111
 112         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
 113         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
 114
 115         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
 116
 117         insert new []         = [new]
 118         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
 119                                                   EQ_  -> xxs
 120                                                   GT__ -> x : insert new xs
 121
 122         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 123         multiple_occs (rn, (o1:o2:_)) = True
 124         multiple_occs _               = False
 125     in
 126     return (rn_module, imp_mods,
 127             top_errs  `unionBags` src_errs,
 128             top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 129             occ_fm, export_fn)
 130
 131     }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
 132
 133     if not (isEmptyBag errs_so_far) then
 134         return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
 135     else
 136
 137     -- No errors renaming source so rename the interfaces ...
 138     let
 139         -- split up all names that occurred in the source; between
 140         -- those that are defined therein and those merely mentioned.
 141         -- We also divide by tycon/class and value names (as usual).
 142
 143         occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
 144                 -- all occurrence names, from this module and imported
 145
 146         (defined_here, defined_elsewhere)
 147           = partition isLocallyDefined occ_rns
 148
 149         (_, imports_used)
 150           = partition isRnWired defined_elsewhere
 151
 152         (def_tcs, def_vals) = partition isRnTyConOrClass defined_here
 153         (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
 154                 -- the occ stuff includes *all* occurrences,
 155                 -- including those for which we have definitions
 156
 157         (orig_def_env, orig_def_dups)
 158           = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals)
 159                                          (map pair_orig def_tcs)
 160         (orig_occ_env, orig_occ_dups)
 161           = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals)
 162                                          (map pair_orig occ_tcs)
 163
 164         pair_orig rn = (origName rn, rn)
 165
 166         -- we must ensure that the definitions of things in the BuiltinKey
 167         -- table which may be *required* by the typechecker etc are read.
 168
 169         must_haves
 170           = [ name_fn (mkBuiltinName u pRELUDE str)
 171             | (str, (u, name_fn)) <- fmToList b_keys,
 172               str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
 173     in
 174     ASSERT (isEmptyBag orig_occ_dups)
 175     ASSERT (isEmptyBag orig_def_dups)
 176
 177     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
 178              rn_module (must_haves ++ imports_used) >>=
 179         \ (rn_module_with_imports, final_env,
 180            (implicit_val_fm, implicit_tc_fm),
 181            usage_stuff,
 182            (iface_errs, iface_warns)) ->
 183
 184     return (rn_module_with_imports,
 185             final_env,
 186             imp_mods,
 187             usage_stuff,
 188             errs_so_far  `unionBags` iface_errs,
 189             warns_so_far `unionBags` iface_warns)
 190   where
 191     rn_panic = panic "renameModule: aborted with errors"
 192
 193     (us1, us') = splitUniqSupply us
 194     (us2, us3) = splitUniqSupply us'
 195 \end{code}
 196
 197 \begin{code}
 198 {- TESTING:
 199 pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
 200   = ppAboves [
 201         ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
 202                case mv of { Nothing -> ppNil; Just n -> ppInt n }],
 203
 204         ppPStr SLIT("__versions__"),
 205         ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ],
 206
 207         ppPStr SLIT("__exports__"),
 208         ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn,
 209                              case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}]
 210                  | (n,(rn,ex)) <- fmToList exm ],
 211
 212         pp_ims (bagToList ims),
 213         pp_fixities lfx,
 214         pp_decls ltdm lvdm,
 215         pp_insts (bagToList lids),
 216         pp_pragmas ldp
 217     ]
 218   where
 219     pp_ims [] = ppNil
 220     pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
 221                         (ppCat (map ppPStr ms))
 222
 223     pp_fixities fx
 224       | isEmptyFM fx = ppNil
 225       | otherwise = ppAboves (ppPStr SLIT("__fixities__")
 226                    : [ ppr PprDebug fix | (n, fix) <- fmToList fx])
 227
 228     pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__")
 229                               : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds])
 230
 231     pp_insts [] = ppNil
 232     pp_insts is = ppAboves (ppPStr SLIT("__instances__")
 233                               : [ pprRdrInstDecl i | i <- is])
 234
 235     pp_pragmas ps | isEmptyFM ps = ppNil
 236                   | otherwise = panic "Rename.pp_pragmas"
 237
 238 pprRdrIfaceDecl (TypeSig tc _ decl)
 239   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
 240
 241 pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
 242   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc,
 243                ppStr "; ", ppr PprDebug decl]
 244
 245 pprRdrIfaceDecl (DataSig tc dcs dfs _ decl)
 246   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs,
 247                ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl]
 248
 249 pprRdrIfaceDecl (ClassSig c ops _ decl)
 250   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
 251                ppStr "; ", ppr PprDebug decl]
 252
 253 pprRdrIfaceDecl (ValSig f _ ty)
 254   = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
 255
 256 pprRdrInstDecl (InstSig c t _ decl)
 257   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
 258                 ppr PprDebug decl]
 259 -}
 260 \end{code}