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