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