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 )
  12
  13 IMP_Ubiq()
  14 IMPORT_1_3(List(partition))
  15
  16 import HsSyn
  17 import RdrHsSyn         ( RdrNameHsModule(..), RdrNameImportDecl(..) )
  18 import RnHsSyn          ( RnName(..){-.. is for Ix hack only-}, SYN_IE(RenamedHsModule), isRnTyConOrClass, isRnWired )
  19
  20 --ToDo:rm: all for debugging only
  21 --import Maybes
  22 --import Name
  23 --import Outputable
  24 --import RnIfaces
  25 --import PprStyle
  26 --import Pretty
  27 --import FiniteMap
  28 --import Util (pprPanic, pprTrace)
  29
  30 import ParseUtils       ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
  31                           UsagesMap(..), VersionsMap(..)
  32                         )
  33 import RnMonad
  34 import RnNames          ( getGlobalNames, SYN_IE(GlobalNameInfo) )
  35 import RnSource         ( rnSource )
  36 import RnIfaces         ( rnIfaces, initIfaceCache, IfaceCache )
  37 import RnUtils          ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
  38
  39 import Bag              ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
  40 import CmdLineOpts      ( opt_HiMap, opt_NoImplicitPrelude )
  41 import ErrUtils         ( SYN_IE(Error), SYN_IE(Warning) )
  42 import FiniteMap        ( emptyFM, eltsFM, fmToList, addToFM, lookupFM{-ToDo:rm-}, FiniteMap )
  43 import Maybes           ( catMaybes )
  44 import Name             ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
  45                           origName,
  46                           Name, RdrName(..), ExportFlag(..)
  47                         )
  48 import PprStyle         -- ToDo:rm
  49 import PrelInfo         ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
  50 import Pretty           -- ToDo:rm
  51 import Unique           ( ixClassKey )
  52 import UniqFM           ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
  53 import UniqSupply       ( splitUniqSupply )
  54 import Util             ( panic, assertPanic, pprTrace{-ToDo:rm-} )
  55 \end{code}
  56
  57 \begin{code}
  58 renameModule :: UniqSupply
  59              -> RdrNameHsModule
  60
  61              -> IO (RenamedHsModule,    -- output, after renaming
  62                     RnEnv,              -- final env (for renaming derivings)
  63                     [Module],           -- imported modules; for profiling
  64
  65                     (Name -> ExportFlag,        -- export info
  66                      ([(Name,ExportFlag)],
  67                       [(Name,ExportFlag)])),
  68
  69                     (UsagesMap,
  70                     VersionsMap,        -- version info; for usage
  71                     [Module]),          -- instance modules; for iface
  72
  73                     Bag Error,
  74                     Bag Warning)
  75 \end{code}
  76
  77 ToDo: May want to arrange to return old interface for this module!
  78 ToDo: Deal with instances (instance version, this module on instance list ???)
  79
  80 \begin{code}
  81 renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
  82
  83   = {-
  84     let
  85         pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
  86     in
  87     pprTrace "builtins:\n" (case builtinNameMaps of { (builtin_ids, builtin_tcs) ->
  88                             ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
  89                                      , ppCat (map pp_pair (keysFM builtin_tcs))
  90                                      , ppCat (map pp_pair (keysFM builtinKeysMap))
  91                                      ]}) $
  92     -}
  93 --    _scc_ "rnGlobalNames"
  94     makeHiMap opt_HiMap     >>=          \ hi_files ->
  95 --  pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
  96     initIfaceCache modname hi_files  >>= \ iface_cache ->
  97
  98     fixIO ( \ ~(_, _, _, _, rec_occ_fm, ~(rec_export_fn,_)) ->
  99     let
 100         rec_occ_fn :: Name -> [RdrName]
 101         rec_occ_fn n = case lookupUFM rec_occ_fm n of
 102                          Nothing        -> []
 103                          Just (rn,occs) -> occs
 104
 105         global_name_info = (builtinNameMaps, builtinKeysMap, rec_export_fn, rec_occ_fn)
 106     in
 107     getGlobalNames iface_cache global_name_info us1 input >>=
 108         \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
 109
 110     if not (isEmptyBag top_errs) then
 111         return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
 112     else
 113
 114     -- No top-level name errors so rename source ...
 115 --    _scc_ "rnSource"
 116     case initRn True modname occ_env us2
 117                 (rnSource imp_mods unqual_imps imp_fixes input) of {
 118         ((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) ->
 119
 120     --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
 121     let
 122         occ_fm :: UniqFM (RnName, [RdrName])
 123
 124         occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
 125         occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
 126
 127         insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
 128
 129         insert new []         = [new]
 130         insert new xxs@(x:xs) = case cmp new x of LT_  -> new : xxs
 131                                                   EQ_  -> xxs
 132                                                   GT__ -> x : insert new xs
 133
 134         occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
 135
 136         multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate")
 137                                         -- the user is rarely responsible if
 138                                         -- "negate" is mentioned in multiple ways
 139         multiple_occs _               = False
 140     in
 141     return (rn_module, imp_mods,
 142             top_errs  `unionBags` src_errs,
 143             top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
 144             occ_fm, (export_fn, module_dotdots))
 145
 146     }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_stuff) ->
 147
 148     if not (isEmptyBag errs_so_far) then
 149         return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
 150     else
 151
 152     -- No errors renaming source so rename the interfaces ...
 153 --    _scc_ "preRnIfaces"
 154     let
 155         -- split up all names that occurred in the source; between
 156         -- those that are defined therein and those merely mentioned.
 157         -- We also divide by tycon/class and value names (as usual).
 158
 159         occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
 160                 -- all occurrence names, from this module and imported
 161
 162         (defined_here, defined_elsewhere)
 163           = partition isLocallyDefined occ_rns
 164
 165         (_, imports_used)
 166           = partition isRnWired defined_elsewhere
 167
 168         (def_tcs, def_vals) = partition isRnTyConOrClass defined_here
 169         (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
 170                 -- the occ stuff includes *all* occurrences,
 171                 -- including those for which we have definitions
 172
 173         (orig_def_env, orig_def_dups)
 174           = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals)
 175                                          (map pairify_rn def_tcs)
 176         (orig_occ_env, orig_occ_dups)
 177           = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals)
 178                                          (map pairify_rn occ_tcs)
 179
 180         -- This stuff is pretty dodgy right now: I think original
 181         -- names and occurrence names may be getting entangled
 182         -- when they shouldn't be... WDP 96/06
 183
 184         pairify_rn rn -- ToDo: move to Name?
 185           = let
 186                 name = getName rn
 187             in
 188             (if isLocalName name
 189              then Unqual (getLocalName name)
 190              else case (origName "pairify_rn" name) of { OrigName m n ->
 191                   Qual m n }
 192              , rn)
 193
 194         must_haves
 195           | opt_NoImplicitPrelude
 196           = [{-no Prelude.hi, no point looking-}]
 197           | otherwise
 198           = [ name_fn (mkWiredInName u orig ExportAll)
 199             | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
 200     in
 201 --  ASSERT (isEmptyBag orig_occ_dups)
 202     (if (isEmptyBag orig_occ_dups) then \x->x
 203      else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
 204     ASSERT (isEmptyBag orig_def_dups)
 205
 206 --    _scc_ "rnIfaces"
 207     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
 208              rn_module (must_haves {-initMustHaves-} ++ imports_used) >>=
 209         \ (rn_module_with_imports, final_env,
 210            (implicit_val_fm, implicit_tc_fm),
 211            usage_stuff,
 212            (iface_errs, iface_warns)) ->
 213
 214     return (rn_module_with_imports,
 215             final_env,
 216             imp_mods,
 217             export_stuff,
 218             usage_stuff,
 219             errs_so_far  `unionBags` iface_errs,
 220             warns_so_far `unionBags` iface_warns)
 221   where
 222     rn_panic = panic "renameModule: aborted with errors"
 223
 224     (us1, us') = splitUniqSupply us
 225     (us2, us3) = splitUniqSupply us'
 226
 227 initMustHaves :: [RnName]
 228     -- things we *must* find declarations for, because the
 229     -- compiler may eventually make reference to them (e.g.,
 230     -- class Eq)
 231 initMustHaves
 232   | opt_NoImplicitPrelude
 233   = [{-no Prelude.hi, no point looking-}]
 234   | otherwise
 235   = [ name_fn (mkWiredInName u orig ExportAll)
 236     | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
 237 \end{code}
 238
 239 \begin{code}
 240 makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
 241
 242 makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
 243 makeHiMap (Just f)
 244   = readFile f  >>= \ cts ->
 245     return (snag_mod emptyFM cts [])
 246   where
 247     -- we alternate between "snag"ging mod(ule names) and path(names),
 248     -- accumulating names (reversed) and the final resulting map
 249     -- as we move along.
 250
 251     snag_mod map  []       []   = map
 252     snag_mod map  (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
 253     snag_mod map  (c:cs)   rmod = snag_mod  map cs (c:rmod)
 254
 255     snag_path map mod []        rpath = addToFM map mod (reverse rpath)
 256     snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
 257     snag_path map mod (c:cs)    rpath = snag_path map mod cs (c:rpath)
 258 \end{code}
 259
 260 Warning message used herein:
 261 \begin{code}
 262 multipleOccWarn (name, occs) sty
 263   = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
 264                ppInterleave ppComma (map (ppr sty) occs)]
 265 \end{code}