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, 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
  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     in
 194 --  ASSERT (isEmptyBag orig_occ_dups)
 195 --    (if (isEmptyBag orig_occ_dups) then \x->x
 196 --     else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
 197     ASSERT (isEmptyBag orig_def_dups)
 198
 199     -- _scc_ "rnIfaces"
 200     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
 201              rn_module (initMustHaves ++ imports_used) >>=
 202         \ (rn_module_with_imports, final_env,
 203            (implicit_val_fm, implicit_tc_fm),
 204            usage_stuff,
 205            (iface_errs, iface_warns)) ->
 206
 207     return (rn_module_with_imports,
 208             final_env,
 209             imp_mods,
 210             export_stuff,
 211             usage_stuff,
 212             errs_so_far  `unionBags` iface_errs,
 213             warns_so_far `unionBags` iface_warns)
 214   where
 215     rn_panic = panic "renameModule: aborted with errors"
 216
 217     (us1, us') = splitUniqSupply us
 218     (us2, us3) = splitUniqSupply us'
 219
 220 initMustHaves :: [RnName]
 221     -- things we *must* find declarations for, because the
 222     -- compiler may eventually make reference to them (e.g.,
 223     -- class Eq)
 224 initMustHaves
 225   | opt_NoImplicitPrelude
 226   = [{-no Prelude.hi, no point looking-}]
 227   | otherwise
 228   = [ name_fn (mkWiredInName u orig ExportAll)
 229     | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
 230 \end{code}
 231
 232 \begin{code}
 233 makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
 234
 235 makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
 236 makeHiMap (Just f)
 237   = readFile f  >>= \ cts ->
 238     return (snag_mod emptyFM cts [])
 239   where
 240     -- we alternate between "snag"ging mod(ule names) and path(names),
 241     -- accumulating names (reversed) and the final resulting map
 242     -- as we move along.
 243
 244     snag_mod map  []       []   = map
 245     snag_mod map  (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
 246     snag_mod map  (c:cs)   rmod = snag_mod  map cs (c:rmod)
 247
 248     snag_path map mod []        rpath = addToFM map mod (reverse rpath)
 249     snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
 250     snag_path map mod (c:cs)    rpath = snag_path map mod cs (c:rpath)
 251 \end{code}
 252
 253 Warning message used herein:
 254 \begin{code}
 255 multipleOccWarn (name, occs) sty
 256   = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
 257                ppInterleave ppComma (map (ppr sty) occs)]
 258 \end{code}