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          ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
  35 import MainMonad
  36
  37 import Bag              ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
  38 import CmdLineOpts      ( opt_HiDirList, opt_SysHiDirList )
  39 import ErrUtils         ( Error(..), Warning(..) )
  40 import FiniteMap        ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
  41 import Maybes           ( catMaybes )
  42 import Name             ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
  43 import PrelInfo         ( BuiltinNames(..), BuiltinKeys(..) )
  44 import PrelMods         ( pRELUDE )
  45 import UniqFM           ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
  46 import UniqSupply       ( splitUniqSupply )
  47 import Util             ( panic, assertPanic )
  48 \end{code}
  49
  50 \begin{code}
  51 renameModule :: BuiltinNames
  52              -> BuiltinKeys
  53              -> UniqSupply
  54              -> RdrNameHsModule
  55
  56              -> IO (RenamedHsModule,    -- output, after renaming
  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: Return OrigName RnEnv to rename derivings etc with.
  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 b_names b_keys us
  73              input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
  74
  75   = pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
  76                             ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
  77                                      , ppCat (map ppPStr (keysFM builtin_tcs))
  78                                      , ppCat (map ppPStr (keysFM b_keys))
  79                                      ]}) $
  80
  81     findHiFiles opt_HiDirList opt_SysHiDirList      >>=          \ hi_files ->
  82     newVar (emptyFM, hi_files){-init iface cache-}  `thenPrimIO` \ iface_cache ->
  83
  84     fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
  85     let
  86         rec_occ_fn :: Name -> [RdrName]
  87         rec_occ_fn n = case lookupUFM rec_occ_fm n of
  88                          Nothing        -> []
  89                          Just (rn,occs) -> occs
  90
  91         global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
  92     in
  93     getGlobalNames iface_cache global_name_info us1 input >>=
  94         \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
  95
  96     if not (isEmptyBag top_errs) then
  97         return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
  98     else
  99
 100     -- No top-level name errors so rename source ...
 101     case initRn True mod occ_env us2
 102                 (rnSource imp_mods unqual_imps imp_fixes input) of {
 103         ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
 104
 105     --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
 106
 107     let
 108         occ_fm :: UniqFM (RnName, [RdrName])
 109
 110         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
 111         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
 112
 113         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
 114
 115         insert new []         = [new]
 116         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
 117                                                   EQ_  -> xxs
 118                                                   GT__ -> x : insert new xs
 119
 120         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 121         multiple_occs (rn, (o1:o2:_)) = True
 122         multiple_occs _               = False
 123     in
 124     return (rn_module, imp_mods,
 125             top_errs  `unionBags` src_errs,
 126             top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 127             occ_fm, export_fn)
 128
 129     }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
 130
 131     if not (isEmptyBag errs_so_far) then
 132         return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
 133     else
 134
 135     -- No errors renaming source so rename the interfaces ...
 136     let
 137         -- split up all names that occurred in the source; between
 138         -- those that are defined therein and those merely mentioned.
 139         -- We also divide by tycon/class and value names (as usual).
 140
 141         occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
 142         -- all occurrence names, from this module and imported
 143
 144         (defined_here, defined_elsewhere)
 145           = partition isLocallyDefined occ_rns
 146
 147         (_, imports_used) = 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         must_haves  -- everything in the BuiltinKey table; as we *may* need these
 164                     -- later, we'd better bring their definitions in
 165           = catMaybes [ mk_key_name str name_fn u | (str, (u, name_fn)) <- fmToList b_keys ]
 166           where
 167             mk_key_name str name_fn u
 168               = -- this is emphatically *not* the Right Way to do this... (WDP 96/04)
 169                 if (str == SLIT("main") || str == SLIT("mainPrimIO")) then
 170                     Nothing
 171                 else
 172                     Just (name_fn (mkBuiltinName u pRELUDE str))
 173     in
 174     ASSERT (isEmptyBag orig_occ_dups)
 175     ASSERT (isEmptyBag orig_def_dups)
 176
 177     rnIfaces iface_cache us3 orig_def_env orig_occ_env rn_module (imports_used ++ must_haves) >>=
 178         \ (rn_module_with_imports, (implicit_val_fm, implicit_tc_fm), iface_errs, iface_warns) ->
 179
 180     let
 181         all_imports_used = bagToList (unionManyBags [listToBag imports_used,
 182                                                      listToBag (eltsFM implicit_tc_fm),
 183                                                      listToBag (eltsFM implicit_val_fm)])
 184     in
 185     finalIfaceInfo iface_cache all_imports_used imp_mods >>=
 186         \ (version_info, instance_mods) ->
 187
 188     return (rn_module_with_imports, imp_mods, version_info, instance_mods,
 189             errs_so_far  `unionBags` iface_errs, 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 pprPIface (ParsedIface m v mv lcm exm ims lfx ltdm lvdm lids ldp)
 199   = ppAboves [
 200         ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
 201                case mv of { Nothing -> ppNil; Just n -> ppInt n }],
 202
 203         ppPStr SLIT("__versions__"),
 204         ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ],
 205
 206         ppPStr SLIT("__exports__"),
 207         ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn,
 208                              case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}]
 209                  | (n,(rn,ex)) <- fmToList exm ],
 210
 211         pp_ims (bagToList ims),
 212         pp_fixities lfx,
 213         pp_decls ltdm lvdm,
 214         pp_insts (bagToList lids),
 215         pp_pragmas ldp
 216     ]
 217   where
 218     pp_ims [] = ppNil
 219     pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
 220                         (ppCat (map ppPStr ms))
 221
 222     pp_fixities fx
 223       | isEmptyFM fx = ppNil
 224       | otherwise = ppAboves (ppPStr SLIT("__fixities__")
 225                    : [ ppr PprDebug fix | (n, fix) <- fmToList fx])
 226
 227     pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__")
 228                               : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds])
 229
 230     pp_insts [] = ppNil
 231     pp_insts is = ppAboves (ppPStr SLIT("__instances__")
 232                               : [ pprRdrInstDecl i | i <- is])
 233
 234     pp_pragmas ps | isEmptyFM ps = ppNil
 235                   | otherwise = panic "Rename.pp_pragmas"
 236
 237 pprRdrIfaceDecl (TypeSig tc _ decl)
 238   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
 239
 240 pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
 241   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, ppStr "; ", ppr PprDebug decl]
 242
 243 pprRdrIfaceDecl (DataSig tc dcs _ decl)
 244   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, ppStr "; ", ppr PprDebug decl]
 245
 246 pprRdrIfaceDecl (ClassSig c ops _ decl)
 247   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, ppStr "; ", ppr PprDebug decl]
 248
 249 pprRdrIfaceDecl (ValSig f _ ty)
 250   = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
 251
 252 pprRdrInstDecl (InstSig c t _ decl)
 253   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
 254                 ppr PprDebug decl]
 255 \end{code}