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