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