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