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(..){-.. is for Ix hack only-}, 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         ( rnIfaces )
  36 import RnUtils          ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
  37
  38 import Bag              ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
  39 import CmdLineOpts      ( opt_HiMap )
  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 Unique           ( ixClassKey )
  47 import UniqFM           ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
  48 import UniqSupply       ( splitUniqSupply )
  49 import Util             ( panic, assertPanic )
  50 \end{code}
  51
  52 \begin{code}
  53 renameModule :: UniqSupply
  54              -> RdrNameHsModule
  55
  56              -> IO (RenamedHsModule,    -- output, after renaming
  57                     RnEnv,              -- final env (for renaming derivings)
  58                     [Module],           -- imported modules; for profiling
  59
  60                     (UsagesMap,
  61                     VersionsMap,        -- version info; for usage
  62                     [Module]),          -- instance modules; for iface
  63
  64                     Bag Error,
  65                     Bag Warning)
  66 \end{code}
  67
  68 ToDo: May want to arrange to return old interface for this module!
  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     makeHiMap opt_HiMap     >>=          \ hi_files ->
  84 --  pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
  85     newVar (emptyFM,emptyFM,hi_files){-init iface cache-}  `thenPrimIO` \ iface_cache ->
  86
  87     fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
  88     let
  89         rec_occ_fn :: Name -> [RdrName]
  90         rec_occ_fn n = case lookupUFM rec_occ_fm n of
  91                          Nothing        -> []
  92                          Just (rn,occs) -> occs
  93
  94         global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
  95     in
  96     getGlobalNames iface_cache global_name_info us1 input >>=
  97         \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
  98
  99     if not (isEmptyBag top_errs) then
 100         return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
 101     else
 102
 103     -- No top-level name errors so rename source ...
 104     case initRn True mod occ_env us2
 105                 (rnSource imp_mods unqual_imps imp_fixes input) of {
 106         ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
 107
 108     --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
 109
 110     let
 111         occ_fm :: UniqFM (RnName, [RdrName])
 112
 113         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
 114         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
 115
 116         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
 117
 118         insert new []         = [new]
 119         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
 120                                                   EQ_  -> xxs
 121                                                   GT__ -> x : insert new xs
 122
 123         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 124         multiple_occs (rn, (o1:o2:_)) = True
 125         multiple_occs _               = False
 126     in
 127     return (rn_module, imp_mods,
 128             top_errs  `unionBags` src_errs,
 129             top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 130             occ_fm, export_fn)
 131
 132     }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
 133
 134     if not (isEmptyBag errs_so_far) then
 135         return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
 136     else
 137
 138     -- No errors renaming source so rename the interfaces ...
 139     let
 140         -- split up all names that occurred in the source; between
 141         -- those that are defined therein and those merely mentioned.
 142         -- We also divide by tycon/class and value names (as usual).
 143
 144         occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
 145                 -- all occurrence names, from this module and imported
 146
 147         (defined_here, defined_elsewhere)
 148           = partition isLocallyDefined occ_rns
 149
 150         (_, imports_used)
 151           = partition isRnWired defined_elsewhere
 152
 153         (def_tcs, def_vals) = partition isRnTyConOrClass defined_here
 154         (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
 155                 -- the occ stuff includes *all* occurrences,
 156                 -- including those for which we have definitions
 157
 158         (orig_def_env, orig_def_dups)
 159           = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals)
 160                                          (map pair_orig def_tcs)
 161         (orig_occ_env, orig_occ_dups)
 162           = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals)
 163                                          (map pair_orig occ_tcs)
 164
 165         pair_orig rn = (origName rn, rn)
 166
 167         -- we must ensure that the definitions of things in the BuiltinKey
 168         -- table which may be *required* by the typechecker etc are read.
 169         -- We *hack* in a requirement for Ix.Ix here
 170         -- (it's the one thing that doesn't come from Prelude.<blah>)
 171
 172         must_haves
 173           = (RnImplicitClass (mkBuiltinName ixClassKey SLIT("Ix") SLIT("Ix")))
 174           : [ name_fn (mkBuiltinName u pRELUDE str)
 175             | (str, (u, name_fn)) <- fmToList b_keys,
 176               str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
 177     in
 178 --  ASSERT (isEmptyBag orig_occ_dups)
 179     (if (isEmptyBag orig_occ_dups) then \x->x
 180      else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
 181     ASSERT (isEmptyBag orig_def_dups)
 182
 183     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
 184              rn_module (must_haves ++ imports_used) >>=
 185         \ (rn_module_with_imports, final_env,
 186            (implicit_val_fm, implicit_tc_fm),
 187            usage_stuff,
 188            (iface_errs, iface_warns)) ->
 189
 190     return (rn_module_with_imports,
 191             final_env,
 192             imp_mods,
 193             usage_stuff,
 194             errs_so_far  `unionBags` iface_errs,
 195             warns_so_far `unionBags` iface_warns)
 196   where
 197     rn_panic = panic "renameModule: aborted with errors"
 198
 199     (us1, us') = splitUniqSupply us
 200     (us2, us3) = splitUniqSupply us'
 201 \end{code}
 202
 203 \begin{code}
 204 makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
 205
 206 makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
 207 makeHiMap (Just f)
 208   = readFile f  >>= \ cts ->
 209     return (snag_mod emptyFM cts [])
 210   where
 211     -- we alternate between "snag"ging mod(ule names) and path(names),
 212     -- accumulating names (reversed) and the final resulting map
 213     -- as we move along.
 214
 215     snag_mod map  []       []   = map
 216     snag_mod map  (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
 217     snag_mod map  (c:cs)   rmod = snag_mod  map cs (c:rmod)
 218
 219     snag_path map mod []        rpath = addToFM map mod (reverse rpath)
 220     snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
 221     snag_path map mod (c:cs)    rpath = snag_path map mod cs (c:rpath)
 222 \end{code}
 223
 224 \begin{code}
 225 {- TESTING:
 226 pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
 227   = ppAboves [
 228         ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
 229                case mv of { Nothing -> ppNil; Just n -> ppInt n }],
 230
 231         ppPStr SLIT("__versions__"),
 232         ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ],
 233
 234         ppPStr SLIT("__exports__"),
 235         ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn,
 236                              case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}]
 237                  | (n,(rn,ex)) <- fmToList exm ],
 238
 239         pp_ims (bagToList ims),
 240         pp_fixities lfx,
 241         pp_decls ltdm lvdm,
 242         pp_insts (bagToList lids),
 243         pp_pragmas ldp
 244     ]
 245   where
 246     pp_ims [] = ppNil
 247     pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
 248                         (ppCat (map ppPStr ms))
 249
 250     pp_fixities fx
 251       | isEmptyFM fx = ppNil
 252       | otherwise = ppAboves (ppPStr SLIT("__fixities__")
 253                    : [ ppr PprDebug fix | (n, fix) <- fmToList fx])
 254
 255     pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__")
 256                               : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds])
 257
 258     pp_insts [] = ppNil
 259     pp_insts is = ppAboves (ppPStr SLIT("__instances__")
 260                               : [ pprRdrInstDecl i | i <- is])
 261
 262     pp_pragmas ps | isEmptyFM ps = ppNil
 263                   | otherwise = panic "Rename.pp_pragmas"
 264
 265 pprRdrIfaceDecl (TypeSig tc _ decl)
 266   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
 267
 268 pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
 269   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc,
 270                ppStr "; ", ppr PprDebug decl]
 271
 272 pprRdrIfaceDecl (DataSig tc dcs dfs _ decl)
 273   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs,
 274                ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl]
 275
 276 pprRdrIfaceDecl (ClassSig c ops _ decl)
 277   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
 278                ppStr "; ", ppr PprDebug decl]
 279
 280 pprRdrIfaceDecl (ValSig f _ ty)
 281   = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
 282
 283 pprRdrInstDecl (InstSig c t _ decl)
 284   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
 285                 ppr PprDebug decl]
 286 -}
 287 \end{code}