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         RnEnv(..), QualNames(..),
  11         UnqualNames(..), ScopeStack(..),
  12         emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
  13         lookupRnEnv, lookupTcRnEnv,
  14
  15         unknownNameErr,
  16         badClassOpErr,
  17         qualNameErr,
  18         dupNamesErr,
  19         shadowedNameWarn,
  20         multipleOccWarn,
  21
  22         -- ToDo: nuke/move? WDP 96/04/05
  23         GlobalNameMapper(..),  GlobalNameMappers(..)
  24     ) where
  25
  26 import Ubiq
  27
  28 import Bag              ( Bag, emptyBag, snocBag, unionBags )
  29 import ErrUtils         ( addShortErrLocLine, addErrLoc )
  30 import FiniteMap        ( FiniteMap, emptyFM, isEmptyFM,
  31                           lookupFM, addListToFM, addToFM )
  32 import Maybes           ( maybeToBool )
  33 import Name             ( RdrName(..), isQual )
  34 import Outputable       ( pprNonOp, getLocalName )
  35 import PprStyle         ( PprStyle(..) )
  36 import Pretty
  37 import RnHsSyn          ( RnName )
  38 import Util             ( assertPanic )
  39
  40 type GlobalNameMapper  = RnName -> Maybe Name
  41 type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper)
  42 \end{code}
  43
  44 *********************************************************
  45 *                                                       *
  46 \subsection{RnEnv: renaming environment}
  47 *                                                       *
  48 *********************************************************
  49
  50 Seperate FiniteMaps are kept for lookup up Qual names,
  51 Unqual names and Local names.
  52
  53 \begin{code}
  54 type RnEnv = ((QualNames, UnqualNames, QualNames, UnqualNames), ScopeStack)
  55
  56 type QualNames    = FiniteMap (FAST_STRING,Module) RnName
  57 type UnqualNames  = FiniteMap FAST_STRING RnName
  58 type ScopeStack   = FiniteMap FAST_STRING RnName
  59
  60 emptyRnEnv        :: RnEnv
  61 extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
  62                   -> (RnEnv, Bag (RdrName, RnName, RnName))
  63 extendLocalRnEnv  :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
  64 lookupRnEnv       :: RnEnv -> RdrName -> Maybe RnName
  65 lookupTcRnEnv     :: RnEnv -> RdrName -> Maybe RnName
  66 \end{code}
  67
  68 If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global
  69 value QualNames.  If it is @Unqual@, it looks it up first in the
  70 ScopeStack, and if it isn't found there, then in the global
  71 vaule Unqual Names.
  72
  73 @lookupTcRnEnv@ looks up tycons/classes in the alternative global
  74 name space.
  75
  76 @extendGlobalRnEnv@ adds global names to the RnEnv. It takes seperate
  77 value and tycon/class name lists. It returns any duplicate names
  78 seperatle.
  79
  80 @extendRnEnv@ adds new local names to the ScopeStack in an RnEnv.
  81 It optionally reports any shadowed names.
  82
  83 \begin{code}
  84 emptyRnEnv
  85   = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
  86
  87
  88 extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
  89   = ASSERT(isEmptyFM stack)
  90     (((qual', unqual', tc_qual, tc_unqual), stack), tc_dups `unionBags` dups)
  91   where
  92     (qual', unqual', dups)          = extend_global qual unqual val_list
  93     (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list
  94
  95     extend_global qual unqual rdr_list = (qual', unqual', dups)
  96       where
  97         (qual_list, unqual_list) = partition (isQual.fst) rdr_list
  98         qual_in   = map mk_qual qual_list
  99         unqual_in = map mk_unqual unqual_list
 100         mk_qual   (Qual m s, rn) = ((s,m), rn)
 101         mk_unqual (Unqual s, rn) = (s, rn)
 102
 103         (qual', qual_dups)     = do_dups qual_in qual emptyBag (\ (s,m) -> Qual m s)
 104         (unqual', unqual_dups) = do_dups unqual_in unqual emptyBag Unqual
 105
 106         dups = unqual_dups `unionBags` qual_dups
 107
 108         do_dups [] fm dups to_rdr = (fm, dups)
 109         do_dups ((k,v):rest) fm dups to_rdr
 110           = case lookupFM fm k of
 111               Nothing  -> do_dups rest (addToFM fm k v) dups to_rdr
 112               Just cur -> do_dups rest fm (dups `snocBag` (to_rdr k, cur, v)) to_rdr
 113
 114
 115 extendLocalRnEnv report_shadows (global, stack) new_local
 116   = ((global, new_stack), dups)
 117   where
 118     (new_stack, dups) = extend new_local stack
 119
 120     extend names stack
 121       = if report_shadows then
 122             do_shadows names stack []
 123         else
 124             (addListToFM stack [ (getLocalName n, n) | n <- names], [])
 125
 126     do_shadows [] stack dups = (stack, dups)
 127     do_shadows (name:names) stack dups
 128       = do_shadows names (addToFM stack str name) ext_dups
 129       where
 130         str = getLocalName name
 131         ext_dups = if maybeToBool (lookupFM stack str)
 132                    then name:dups
 133                    else dups
 134
 135
 136 lookupRnEnv ((qual, unqual, _, _), stack) rdr
 137   = case rdr of
 138       Unqual str   -> lookup stack str (lookup unqual str Nothing)
 139       Qual mod str -> lookup qual (str,mod) Nothing
 140   where
 141     lookup fm thing do_on_fail
 142       = case lookupFM fm thing of
 143             found@(Just name) -> found
 144             Nothing           -> do_on_fail
 145
 146 lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
 147   = case rdr of
 148       Unqual str   -> lookupFM tc_unqual str
 149       Qual mod str -> lookupFM tc_qual (str,mod)
 150 \end{code}
 151
 152 *********************************************************
 153 *                                                       *
 154 \subsection{Errors used in RnMonad}
 155 *                                                       *
 156 *********************************************************
 157
 158 \begin{code}
 159 unknownNameErr descriptor name locn
 160   = addShortErrLocLine locn ( \ sty ->
 161     ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonOp sty name] )
 162
 163 badClassOpErr clas op locn
 164   = addErrLoc locn "" ( \ sty ->
 165     ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
 166               ppr sty clas, ppStr "'"] )
 167
 168 qualNameErr descriptor (name,locn)
 169   = addShortErrLocLine locn ( \ sty ->
 170     ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonOp sty name ] )
 171
 172 dupNamesErr descriptor ((name1,locn1) : dup_things) sty
 173   = ppAboves (item1 : map dup_item dup_things)
 174   where
 175     item1
 176       = ppBesides [ ppr PprForUser locn1,
 177             ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
 178             pprNonOp sty name1 ]
 179
 180     dup_item (name, locn)
 181       = ppBesides [ ppr PprForUser locn,
 182             ppStr ": here was another declaration of `", pprNonOp sty name, ppStr "'" ]
 183
 184 shadowedNameWarn locn shadow
 185   = addShortErrLocLine locn ( \ sty ->
 186     ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] )
 187
 188 multipleOccWarn (name, occs) sty
 189   = ppBesides [ppStr "multiple names used to refer to `", ppr sty name, ppStr "': ",
 190                ppInterleave ppComma (map (ppr sty) occs)]
 191 \end{code}
 192