ghc/compiler/rename/RnUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnUtils]{Functions used by both renaming passes}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnUtils (
  10         SYN_IE(RnEnv), SYN_IE(QualNames),
  11         SYN_IE(UnqualNames), SYN_IE(ScopeStack),
  12         emptyRnEnv, initRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
  13         lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
  14         getLocalsFromRnEnv,
  15
  16         lubExportFlag,
  17
  18         qualNameErr,
  19         dupNamesErr,
  20         pprRnEnv -- debugging only
  21     ) where
  22
  23 IMP_Ubiq(){-uitous-}
  24 IMPORT_1_3(List(partition))
  25
  26 import Bag              ( Bag, emptyBag, snocBag, unionBags )
  27 import CmdLineOpts      ( opt_GlasgowExts )
  28 import ErrUtils         ( addShortErrLocLine )
  29 import FiniteMap        ( emptyFM, isEmptyFM, fmToList, listToFM, keysFM,
  30                           lookupFM, addListToFM, addToFM, eltsFM, FiniteMap )
  31 import Maybes           ( maybeToBool )
  32 import Name             ( RdrName(..),  ExportFlag(..),
  33                           isQual, pprNonSym, getLocalName, isLocallyDefined )
  34 import PprStyle         ( PprStyle(..) )
  35 import PrelInfo         ( builtinValNamesMap, builtinTcNamesMap )
  36 import PrelMods         ( gHC_BUILTINS )
  37 import Pretty
  38 import RnHsSyn          ( RnName )
  39 import Util             ( assertPanic )
  40 \end{code}
  41
  42 *********************************************************
  43 *                                                       *
  44 \subsection{RnEnv: renaming environment}
  45 *                                                       *
  46 *********************************************************
  47
  48 Separate FiniteMaps are kept for lookup up Qual names,
  49 Unqual names and Local names.
  50
  51 \begin{code}
  52 type RnEnv = ((QualNames, UnqualNames, QualNames, UnqualNames), ScopeStack)
  53
  54 type QualNames    = FiniteMap (FAST_STRING,Module) RnName
  55 type UnqualNames  = FiniteMap FAST_STRING RnName
  56 type ScopeStack   = FiniteMap FAST_STRING RnName
  57
  58 emptyRnEnv        :: RnEnv
  59 initRnEnv         :: RnEnv
  60 extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
  61                   -> (RnEnv, Bag (RdrName, RnName, RnName))
  62 extendLocalRnEnv  :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
  63 lookupRnEnv       :: RnEnv -> RdrName -> Maybe RnName
  64 lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName
  65 lookupTcRnEnv     :: RnEnv -> RdrName -> Maybe RnName
  66
  67 getLocalsFromRnEnv :: RnEnv -> ([RnName], [RnName])
  68         -- grabs the locally defined names from the unqual envs
  69 \end{code}
  70
  71 If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global
  72 value QualNames.  If it is @Unqual@, it looks it up first in the
  73 ScopeStack, and if it isn't found there, then in the global
  74 vaule Unqual Names.
  75
  76 @lookupTcRnEnv@ looks up tycons/classes in the alternative global
  77 name space.
  78
  79 @extendGlobalRnEnv@ adds global names to the RnEnv. It takes separate
  80 value and tycon/class name lists. It returns any duplicate names
  81 seperately.
  82
  83 @extendRnEnv@ adds new local names to the ScopeStack in an RnEnv.
  84 It optionally reports any shadowed names.
  85
  86 \begin{code}
  87 emptyRnEnv = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
  88
  89     -- an emptyRnEnv is empty; the initRnEnv may have
  90     -- primitive names already in it (both unqual and qual),
  91     -- and quals for all the other wired-in dudes.
  92
  93 initRnEnv
  94   = if (not opt_GlasgowExts) then
  95         emptyRnEnv
  96     else
  97         ((listToFM qual, listToFM unqual, listToFM tc_qual, listToFM tc_unqual), emptyFM)
  98   where
  99     qual      = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinValNamesMap ]
 100     tc_qual   = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinTcNamesMap  ]
 101
 102     builtin_qual    = filter (\ ((_,m),_) -> m == gHC_BUILTINS) qual
 103     builtin_tc_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) tc_qual
 104
 105     unqual    = map (\ ((n,_),rn) -> (n,rn)) builtin_qual
 106     tc_unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_tc_qual
 107
 108 -----------------
 109
 110 extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
 111   = ASSERT(isEmptyFM stack)
 112     (((qual', unqual', tc_qual', tc_unqual'), stack), tc_dups `unionBags` dups)
 113   where
 114     (qual', unqual', dups)          = extend_global qual unqual val_list
 115     (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list
 116
 117     extend_global qual unqual rdr_list = (qual', unqual', dups)
 118       where
 119         (qual_list, unqual_list) = partition (isQual.fst) rdr_list
 120         qual_in   = map mk_qual qual_list
 121         unqual_in = map mk_unqual unqual_list
 122         mk_qual   (Qual m s, rn) = ((s,m), rn)
 123         mk_unqual (Unqual s, rn) = (s, rn)
 124
 125         (qual', qual_dups)     = do_dups qual_in qual emptyBag (\ (s,m) -> Qual m s)
 126         (unqual', unqual_dups) = do_dups unqual_in unqual emptyBag Unqual
 127
 128         dups = unqual_dups `unionBags` qual_dups
 129
 130         do_dups [] fm dups to_rdr = (fm, dups)
 131         do_dups ((k,v):rest) fm dups to_rdr
 132           = case lookupFM fm k of
 133               Nothing  -> do_dups rest (addToFM fm k v) dups to_rdr
 134               Just cur -> do_dups rest fm (dups `snocBag` (to_rdr k, cur, v)) to_rdr
 135
 136
 137 extendLocalRnEnv report_shadows (global, stack) new_local
 138   = ((global, new_stack), dups)
 139   where
 140     (new_stack, dups) = extend new_local stack
 141
 142     extend names stack
 143       = if report_shadows then
 144             do_shadows names stack []
 145         else
 146             (addListToFM stack [ (getLocalName n, n) | n <- names], [])
 147
 148     do_shadows [] stack dups = (stack, dups)
 149     do_shadows (name:names) stack dups
 150       = do_shadows names (addToFM stack str name) ext_dups
 151       where
 152         str = getLocalName name
 153         ext_dups = if maybeToBool (lookupFM stack str)
 154                    then name:dups
 155                    else dups
 156 \end{code}
 157
 158 \begin{code}
 159 lookupRnEnv ((qual, unqual, _, _), stack) rdr
 160   = case rdr of
 161       Unqual str   -> lookup stack str (lookupFM unqual str)
 162       Qual mod str -> lookupFM qual (str,mod)
 163   where
 164     lookup fm thing do_on_fail
 165       = case lookupFM fm thing of
 166             found@(Just name) -> found
 167             Nothing           -> do_on_fail
 168
 169 lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
 170   = case rdr of
 171       Unqual str   -> lookupFM unqual str
 172       Qual mod str -> lookupFM qual (str,mod)
 173
 174 lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
 175   = case rdr of
 176       Unqual str   -> lookupFM tc_unqual str
 177       Qual mod str -> lookupFM tc_qual (str,mod)
 178
 179 getLocalsFromRnEnv ((_, vals, _, tcs), _)
 180   = (filter isLocallyDefined (eltsFM vals),
 181      filter isLocallyDefined (eltsFM tcs))
 182 \end{code}
 183
 184 *********************************************************
 185 *                                                       *
 186 \subsection{Export Flag Functions}
 187 *                                                       *
 188 *********************************************************
 189
 190 \begin{code}
 191 lubExportFlag ExportAll ExportAll = ExportAll
 192 lubExportFlag ExportAll ExportAbs = ExportAll
 193 lubExportFlag ExportAbs ExportAll = ExportAll
 194 lubExportFlag ExportAbs ExportAbs = ExportAbs
 195 \end{code}
 196
 197 *********************************************************
 198 *                                                       *
 199 \subsection{Errors used *more than once* in the renamer}
 200 *                                                       *
 201 *********************************************************
 202
 203 \begin{code}
 204 qualNameErr descriptor (name,locn)
 205   = addShortErrLocLine locn ( \ sty ->
 206     ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] )
 207
 208 dupNamesErr descriptor ((name1,locn1) : dup_things) sty
 209   = ppAboves (item1 : map dup_item dup_things)
 210   where
 211     item1
 212       = addShortErrLocLine locn1 (\ sty ->
 213         ppBesides [ppStr "multiple declarations of a ", ppStr descriptor, ppStr " `",
 214                    pprNonSym sty name1, ppStr "'" ]) sty
 215
 216     dup_item (name, locn)
 217       = addShortErrLocLine locn (\ sty ->
 218         ppBesides [ppStr "here was another declaration of `",
 219                    pprNonSym sty name, ppStr "'" ]) sty
 220
 221 -----------------
 222 pprRnEnv :: PprStyle -> RnEnv -> Pretty
 223
 224 pprRnEnv sty ((qual, unqual, tc_qual, tc_unqual), stack)
 225   = ppAboves [ ppStr "Stack:"
 226              , ppCat (map ppPStr (keysFM stack))
 227              , ppStr "Val qual:"
 228              , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM qual]
 229              , ppStr "Val unqual:"
 230              , ppCat (map ppPStr (keysFM unqual))
 231              , ppStr "Tc qual:"
 232              , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM tc_qual]
 233              , ppStr "Tc unqual:"
 234              , ppCat (map ppPStr (keysFM tc_unqual))
 235              ]
 236 \end{code}