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