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         ( 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 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     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
 170         must_haves
 171           = [ name_fn (mkBuiltinName u pRELUDE str)
 172             | (str, (u, name_fn)) <- fmToList b_keys,
 173               str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
 174     in
 175     ASSERT (isEmptyBag orig_occ_dups)
 176     ASSERT (isEmptyBag orig_def_dups)
 177
 178     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
 179              rn_module (must_haves ++ imports_used) >>=
 180         \ (rn_module_with_imports, final_env,
 181            (implicit_val_fm, implicit_tc_fm),
 182            usage_stuff,
 183            (iface_errs, iface_warns)) ->
 184
 185     return (rn_module_with_imports,
 186             final_env,
 187             imp_mods,
 188             usage_stuff,
 189             errs_so_far  `unionBags` iface_errs,
 190             warns_so_far `unionBags` iface_warns)
 191   where
 192     rn_panic = panic "renameModule: aborted with errors"
 193
 194     (us1, us') = splitUniqSupply us
 195     (us2, us3) = splitUniqSupply us'
 196 \end{code}
 197
 198 \begin{code}
 199 makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
 200
 201 makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
 202 makeHiMap (Just f)
 203   = readFile f  >>= \ cts ->
 204     return (snag_mod emptyFM cts [])
 205   where
 206     -- we alternate between "snag"ging mod(ule names) and path(names),
 207     -- accumulating names (reversed) and the final resulting map
 208     -- as we move along.
 209
 210     snag_mod map  []       []   = map
 211     snag_mod map  (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
 212     snag_mod map  (c:cs)   rmod = snag_mod  map cs (c:rmod)
 213
 214     snag_path map mod []        rpath = addToFM map mod (reverse rpath)
 215     snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
 216     snag_path map mod (c:cs)    rpath = snag_path map mod cs (c:rpath)
 217 \end{code}
 218
 219 \begin{code}
 220 {- TESTING:
 221 pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
 222   = ppAboves [
 223         ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
 224                case mv of { Nothing -> ppNil; Just n -> ppInt n }],
 225
 226         ppPStr SLIT("__versions__"),
 227         ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ],
 228
 229         ppPStr SLIT("__exports__"),
 230         ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn,
 231                              case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}]
 232                  | (n,(rn,ex)) <- fmToList exm ],
 233
 234         pp_ims (bagToList ims),
 235         pp_fixities lfx,
 236         pp_decls ltdm lvdm,
 237         pp_insts (bagToList lids),
 238         pp_pragmas ldp
 239     ]
 240   where
 241     pp_ims [] = ppNil
 242     pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
 243                         (ppCat (map ppPStr ms))
 244
 245     pp_fixities fx
 246       | isEmptyFM fx = ppNil
 247       | otherwise = ppAboves (ppPStr SLIT("__fixities__")
 248                    : [ ppr PprDebug fix | (n, fix) <- fmToList fx])
 249
 250     pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__")
 251                               : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds])
 252
 253     pp_insts [] = ppNil
 254     pp_insts is = ppAboves (ppPStr SLIT("__instances__")
 255                               : [ pprRdrInstDecl i | i <- is])
 256
 257     pp_pragmas ps | isEmptyFM ps = ppNil
 258                   | otherwise = panic "Rename.pp_pragmas"
 259
 260 pprRdrIfaceDecl (TypeSig tc _ decl)
 261   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
 262
 263 pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
 264   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc,
 265                ppStr "; ", ppr PprDebug decl]
 266
 267 pprRdrIfaceDecl (DataSig tc dcs dfs _ decl)
 268   = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs,
 269                ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl]
 270
 271 pprRdrIfaceDecl (ClassSig c ops _ decl)
 272   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
 273                ppStr "; ", ppr PprDebug decl]
 274
 275 pprRdrIfaceDecl (ValSig f _ ty)
 276   = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
 277
 278 pprRdrInstDecl (InstSig c t _ decl)
 279   = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
 280                 ppr PprDebug decl]
 281 -}
 282 \end{code}