ghc/compiler/rename/RnEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnEnv]{Environment manipulation for the renamer monad}
   5
   6 \begin{code}
   7 module RnEnv where              -- Export everything
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn
  12 import RdrHsSyn         ( RdrNameIE )
  13 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
  14                           mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
  15                         )
  16 import HsTypes          ( hsTyVarName, replaceTyVarName )
  17 import HscTypes         ( Provenance(..), pprNameProvenance, hasBetterProv,
  18                           ImportReason(..), GlobalRdrEnv, AvailEnv,
  19                           AvailInfo, Avails, GenAvailInfo(..) )
  20 import RnMonad
  21 import Name             ( Name, NamedThing(..),
  22                           getSrcLoc,
  23                           mkLocalName, mkGlobalName,
  24                           mkIPName, nameOccName, nameModule_maybe,
  25                           setNameModuleAndLoc
  26                         )
  27 import Name             ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
  28 import NameSet
  29 import OccName          ( OccName, occNameUserString, occNameFlavour )
  30 import Module           ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )
  31 import FiniteMap
  32 import UniqSupply
  33 import SrcLoc           ( SrcLoc, noSrcLoc )
  34 import Outputable
  35 import ListSetOps       ( removeDups, equivClasses )
  36 import Util             ( sortLt )
  37 import List             ( nub )
  38 import PrelNames        ( mkUnboundName )
  39 import CmdLineOpts
  40 import FastString       ( FastString )
  41 \end{code}
  42
  43 %*********************************************************
  44 %*                                                      *
  45 \subsection{Making new names}
  46 %*                                                      *
  47 %*********************************************************
  48
  49 \begin{code}
  50 newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
  51         -- newTopBinder puts into the cache the binder with the
  52         -- module information set correctly.  When the decl is later renamed,
  53         -- the binding site will thereby get the correct module.
  54         -- There maybe occurrences that don't have the correct Module, but
  55         -- by the typechecker will propagate the binding definition to all
  56         -- the occurrences, so that doesn't matter
  57
  58 newTopBinder mod rdr_name loc
  59   =     -- First check the cache
  60     -- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
  61
  62         -- There should never be a qualified name in a binding position (except in instance decls)
  63         -- The parser doesn't check this because the same parser parses instance decls
  64     (if isQual rdr_name then
  65         qualNameErr (text "its declaration") (rdr_name,loc)
  66      else
  67         returnRn ()
  68     )                           `thenRn_`
  69
  70     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
  71     let
  72         occ = rdrNameOcc rdr_name
  73         key = (moduleName mod, occ)
  74     in
  75     case lookupFM cache key of
  76
  77         -- A hit in the cache!  We are at the binding site of the name, and
  78         -- this is the moment when we know all about
  79         --      a) the Name's host Module (in particular, which
  80         --         package it comes from)
  81         --      b) its defining SrcLoc
  82         -- So we update this info
  83
  84         Just name -> let
  85                         new_name  = setNameModuleAndLoc name mod loc
  86                         new_cache = addToFM cache key new_name
  87                      in
  88                      setNameSupplyRn (us, new_cache, ipcache)   `thenRn_`
  89                      traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
  90                      returnRn new_name
  91
  92         -- Miss in the cache!
  93         -- Build a completely new Name, and put it in the cache
  94         -- Even for locally-defined names we use implicitImportProvenance;
  95         -- updateProvenances will set it to rights
  96         Nothing -> let
  97                         (us', us1) = splitUniqSupply us
  98                         uniq       = uniqFromSupply us1
  99                         new_name   = mkGlobalName uniq mod occ loc
 100                         new_cache  = addToFM cache key new_name
 101                    in
 102                    setNameSupplyRn (us', new_cache, ipcache)    `thenRn_`
 103                    traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
 104                    returnRn new_name
 105
 106
 107 newGlobalName :: ModuleName -> OccName -> RnM d Name
 108   -- Used for *occurrences*.  We make a place-holder Name, really just
 109   -- to agree on its unique, which gets overwritten when we read in
 110   -- the binding occurence later (newTopBinder)
 111   -- The place-holder Name doesn't have the right SrcLoc, and its
 112   -- Module won't have the right Package either.
 113   --
 114   -- (We have to pass a ModuleName, not a Module, because we may be
 115   -- simply looking at an occurrence M.x in an interface file.)
 116   --
 117   -- This means that a renamed program may have incorrect info
 118   -- on implicitly-imported occurrences, but the correct info on the
 119   -- *binding* declaration. It's the type checker that propagates the
 120   -- correct information to all the occurrences.
 121   -- Since implicitly-imported names never occur in error messages,
 122   -- it doesn't matter that we get the correct info in place till later,
 123   -- (but since it affects DLL-ery it does matter that we get it right
 124   --  in the end).
 125 newGlobalName mod_name occ
 126   = getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 127     let
 128         key = (mod_name, occ)
 129     in
 130     case lookupFM cache key of
 131         Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
 132                      returnRn name
 133
 134         Nothing   -> setNameSupplyRn (us', new_cache, ipcache)                  `thenRn_`
 135                      -- traceRn (text "newGlobalName: new" <+> ppr name)        `thenRn_`
 136                      returnRn name
 137                   where
 138                      (us', us1) = splitUniqSupply us
 139                      uniq       = uniqFromSupply us1
 140                      mod        = mkVanillaModule mod_name
 141                      name       = mkGlobalName uniq mod occ noSrcLoc
 142                      new_cache  = addToFM cache key name
 143
 144 newIPName rdr_name
 145   = getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 146     case lookupFM ipcache key of
 147         Just name -> returnRn name
 148         Nothing   -> setNameSupplyRn (us', cache, new_ipcache)  `thenRn_`
 149                      returnRn name
 150                   where
 151                      (us', us1)  = splitUniqSupply us
 152                      uniq        = uniqFromSupply us1
 153                      name        = mkIPName uniq key
 154                      new_ipcache = addToFM ipcache key name
 155     where key = (rdrNameOcc rdr_name)
 156 \end{code}
 157
 158 %*********************************************************
 159 %*                                                      *
 160 \subsection{Looking up names}
 161 %*                                                      *
 162 %*********************************************************
 163
 164 Looking up a name in the RnEnv.
 165
 166 \begin{code}
 167 lookupBndrRn rdr_name
 168   = getLocalNameEnv             `thenRn` \ local_env ->
 169     case lookupRdrEnv local_env rdr_name of
 170           Just name -> returnRn name
 171           Nothing   -> lookupTopBndrRn rdr_name
 172
 173 lookupTopBndrRn rdr_name
 174   = getModeRn   `thenRn` \ mode ->
 175     case mode of
 176         InterfaceMode -> lookupIfaceName rdr_name
 177
 178         SourceMode    -> -- Source mode, so look up a *qualified* version
 179                          -- of the name, so that we get the right one even
 180                          -- if there are many with the same occ name
 181                          -- There must *be* a binding
 182                 getModuleRn             `thenRn` \ mod ->
 183                 getGlobalNameEnv        `thenRn` \ global_env ->
 184                 lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
 185
 186 -- lookupSigOccRn is used for type signatures and pragmas
 187 -- Is this valid?
 188 --   module A
 189 --      import M( f )
 190 --      f :: Int -> Int
 191 --      f x = x
 192 -- It's clear that the 'f' in the signature must refer to A.f
 193 -- The Haskell98 report does not stipulate this, but it will!
 194 -- So we must treat the 'f' in the signature in the same way
 195 -- as the binding occurrence of 'f', using lookupBndrRn
 196 lookupSigOccRn :: RdrName -> RnMS Name
 197 lookupSigOccRn = lookupBndrRn
 198
 199 -- lookupOccRn looks up an occurrence of a RdrName
 200 lookupOccRn :: RdrName -> RnMS Name
 201 lookupOccRn rdr_name
 202   = getLocalNameEnv                     `thenRn` \ local_env ->
 203     case lookupRdrEnv local_env rdr_name of
 204           Just name -> returnRn name
 205           Nothing   -> lookupGlobalOccRn rdr_name
 206
 207 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 208 -- environment.  It's used only for
 209 --      record field names
 210 --      class op names in class and instance decls
 211
 212 lookupGlobalOccRn rdr_name
 213   = getModeRn           `thenRn` \ mode ->
 214     case mode of
 215         SourceMode    -> getGlobalNameEnv                       `thenRn` \ global_env ->
 216                          lookupSrcName global_env rdr_name
 217
 218         InterfaceMode -> lookupIfaceName rdr_name
 219
 220 lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
 221 -- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
 222 lookupSrcName global_env rdr_name
 223   | isOrig rdr_name     -- Can occur in source code too
 224   = lookupOrigName rdr_name
 225
 226   | otherwise
 227   = case lookupRdrEnv global_env rdr_name of
 228         Just [(name,_)]         -> returnRn name
 229         Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
 230                                    returnRn name
 231         Nothing                 -> failWithRn (mkUnboundName rdr_name)
 232                                               (unknownNameErr rdr_name)
 233
 234 lookupOrigName :: RdrName -> RnM d Name
 235 lookupOrigName rdr_name
 236   = ASSERT( isOrig rdr_name )
 237     newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 238
 239 lookupIfaceUnqual :: RdrName -> RnM d Name
 240 lookupIfaceUnqual rdr_name
 241   = ASSERT( isUnqual rdr_name )
 242         -- An Unqual is allowed; interface files contain
 243         -- unqualified names for locally-defined things, such as
 244         -- constructors of a data type.
 245     getModuleRn                         `thenRn ` \ mod ->
 246     newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
 247
 248 lookupIfaceName :: RdrName -> RnM d Name
 249 lookupIfaceName rdr_name
 250   | isUnqual rdr_name = lookupIfaceUnqual rdr_name
 251   | otherwise         = lookupOrigName rdr_name
 252 \end{code}
 253
 254 @lookupOrigName@ takes an RdrName representing an {\em original}
 255 name, and adds it to the occurrence pool so that it'll be loaded
 256 later.  This is used when language constructs (such as monad
 257 comprehensions, overloaded literals, or deriving clauses) require some
 258 stuff to be loaded that isn't explicitly mentioned in the code.
 259
 260 This doesn't apply in interface mode, where everything is explicit,
 261 but we don't check for this case: it does no harm to record an
 262 ``extra'' occurrence and @lookupOrigNames@ isn't used much in
 263 interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
 264 calls it at all I think).
 265
 266   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 267
 268
 269 \begin{code}
 270 lookupOrigNames :: [RdrName] -> RnM d NameSet
 271 lookupOrigNames rdr_names
 272   = mapRn lookupOrigName rdr_names      `thenRn` \ names ->
 273     returnRn (mkNameSet names)
 274 \end{code}
 275
 276 lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
 277 It ensures that the module is set correctly in the name cache, and sets the provenance
 278 on the returned name too.  The returned name will end up actually in the type, class,
 279 or instance.
 280
 281 \begin{code}
 282 lookupSysBinder rdr_name
 283   = ASSERT( isUnqual rdr_name )
 284     getModuleRn                         `thenRn` \ mod ->
 285     getSrcLocRn                         `thenRn` \ loc ->
 286     newTopBinder mod rdr_name loc
 287 \end{code}
 288
 289
 290
 291 %*********************************************************
 292 %*                                                      *
 293 \subsection{Binding}
 294 %*                                                      *
 295 %*********************************************************
 296
 297 \begin{code}
 298 newLocalsRn :: [(RdrName,SrcLoc)]
 299             -> RnMS [Name]
 300 newLocalsRn rdr_names_w_loc
 301  =  getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 302     let
 303         n          = length rdr_names_w_loc
 304         (us', us1) = splitUniqSupply us
 305         uniqs      = uniqsFromSupply n us1
 306         names      = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 307                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 308                      ]
 309     in
 310     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 311     returnRn names
 312
 313
 314 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 315                     -> [(RdrName,SrcLoc)]
 316                     -> ([Name] -> RnMS a)
 317                     -> RnMS a
 318 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 319   = getModeRn                           `thenRn` \ mode ->
 320     getLocalNameEnv                     `thenRn` \ name_env ->
 321
 322         -- Check for duplicate names
 323     checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 324
 325     doptRn Opt_WarnNameShadowing                `thenRn` \ warn_shadow ->
 326
 327         -- Warn about shadowing, but only in source modules
 328     (case mode of
 329         SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
 330         other                              -> returnRn ()
 331     )                                   `thenRn_`
 332
 333     newLocalsRn rdr_names_w_loc         `thenRn` \ names ->
 334     let
 335         new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 336     in
 337     setLocalNameEnv new_local_env (enclosed_scope names)
 338
 339   where
 340     check_shadow name_env (rdr_name,loc)
 341         = case lookupRdrEnv name_env rdr_name of
 342                 Nothing   -> returnRn ()
 343                 Just name -> pushSrcLocRn loc $
 344                              addWarnRn (shadowedNameWarn rdr_name)
 345
 346 bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
 347   -- A specialised variant when renaming stuff from interface
 348   -- files (of which there is a lot)
 349   --    * one at a time
 350   --    * no checks for shadowing
 351   --    * always imported
 352   --    * deal with free vars
 353 bindCoreLocalRn rdr_name enclosed_scope
 354   = getSrcLocRn                 `thenRn` \ loc ->
 355     getLocalNameEnv             `thenRn` \ name_env ->
 356     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 357     let
 358         (us', us1) = splitUniqSupply us
 359         uniq       = uniqFromSupply us1
 360         name       = mkLocalName uniq (rdrNameOcc rdr_name) loc
 361     in
 362     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 363     let
 364         new_name_env = extendRdrEnv name_env rdr_name name
 365     in
 366     setLocalNameEnv new_name_env (enclosed_scope name)
 367
 368 bindCoreLocalsRn []     thing_inside = thing_inside []
 369 bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b        $ \ name' ->
 370                                        bindCoreLocalsRn bs      $ \ names' ->
 371                                        thing_inside (name':names')
 372
 373 bindLocalNames names enclosed_scope
 374   = getLocalNameEnv             `thenRn` \ name_env ->
 375     setLocalNameEnv (addListToRdrEnv name_env pairs)
 376                     enclosed_scope
 377   where
 378     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 379
 380 bindLocalNamesFV names enclosed_scope
 381   = bindLocalNames names $
 382     enclosed_scope `thenRn` \ (thing, fvs) ->
 383     returnRn (thing, delListFromNameSet fvs names)
 384
 385
 386 -------------------------------------
 387 bindLocalRn doc rdr_name enclosed_scope
 388   = getSrcLocRn                                 `thenRn` \ loc ->
 389     bindLocatedLocalsRn doc [(rdr_name,loc)]    $ \ (n:ns) ->
 390     ASSERT( null ns )
 391     enclosed_scope n
 392
 393 bindLocalsRn doc rdr_names enclosed_scope
 394   = getSrcLocRn         `thenRn` \ loc ->
 395     bindLocatedLocalsRn doc
 396                         (rdr_names `zip` repeat loc)
 397                         enclosed_scope
 398
 399         -- binLocalsFVRn is the same as bindLocalsRn
 400         -- except that it deals with free vars
 401 bindLocalsFVRn doc rdr_names enclosed_scope
 402   = bindLocalsRn doc rdr_names          $ \ names ->
 403     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 404     returnRn (thing, delListFromNameSet fvs names)
 405
 406 -------------------------------------
 407 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 408         -- This tiresome function is used only in rnDecl on InstDecl
 409 extendTyVarEnvFVRn tyvars enclosed_scope
 410   = bindLocalNames tyvars enclosed_scope        `thenRn` \ (thing, fvs) ->
 411     returnRn (thing, delListFromNameSet fvs tyvars)
 412
 413 bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
 414               -> ([HsTyVarBndr Name] -> RnMS a)
 415               -> RnMS a
 416 bindTyVarsRn doc_str tyvar_names enclosed_scope
 417   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 418     enclosed_scope tyvars
 419
 420 -- Gruesome name: return Names as well as HsTyVars
 421 bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
 422               -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
 423               -> RnMS a
 424 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 425   = getSrcLocRn                                 `thenRn` \ loc ->
 426     let
 427         located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
 428     in
 429     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 430     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 431
 432 bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
 433               -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
 434               -> RnMS (a, FreeVars)
 435 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 436   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 437     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 438     returnRn (thing, delListFromNameSet fvs names)
 439
 440 bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
 441               -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
 442               -> RnMS (a, FreeVars)
 443 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 444   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 445     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 446     returnRn (thing, delListFromNameSet fvs names)
 447
 448 bindNakedTyVarsFVRn :: SDoc -> [RdrName]
 449                     -> ([Name] -> RnMS (a, FreeVars))
 450                     -> RnMS (a, FreeVars)
 451 bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
 452   = getSrcLocRn                                 `thenRn` \ loc ->
 453     let
 454         located_tyvars = [(tv, loc) | tv <- tyvar_names]
 455     in
 456     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 457     enclosed_scope names                        `thenRn` \ (thing, fvs) ->
 458     returnRn (thing, delListFromNameSet fvs names)
 459
 460
 461 -------------------------------------
 462 checkDupOrQualNames, checkDupNames :: SDoc
 463                                    -> [(RdrName, SrcLoc)]
 464                                    -> RnM d ()
 465         -- Works in any variant of the renamer monad
 466
 467 checkDupOrQualNames doc_str rdr_names_w_loc
 468   =     -- Check for use of qualified names
 469     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 470     checkDupNames doc_str rdr_names_w_loc
 471   where
 472     quals = filter (isQual . fst) rdr_names_w_loc
 473
 474 checkDupNames doc_str rdr_names_w_loc
 475   =     -- Check for duplicated names in a binding group
 476     mapRn_ (dupNamesErr doc_str) dups
 477   where
 478     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{GlobalRdrEnv}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 mkGlobalRdrEnv :: ModuleName            -- Imported module (after doing the "as M" name change)
 490                -> Bool                  -- True <=> want unqualified import
 491                -> [AvailInfo]           -- What's to be hidden (but only the unqualified
 492                                         --      version is hidden)
 493                -> (Name -> Provenance)
 494                -> Avails                -- Whats imported and how
 495                -> GlobalRdrEnv
 496
 497 mkGlobalRdrEnv this_mod unqual_imp hides mk_provenance avails
 498   = gbl_env2
 499   where
 500         -- Make the name environment.  We're talking about a
 501         -- single module here, so there must be no name clashes.
 502         -- In practice there only ever will be if it's the module
 503         -- being compiled.
 504
 505         -- Add the things that are available
 506     gbl_env1 = foldl add_avail emptyRdrEnv avails
 507
 508         -- Delete things that are hidden
 509     gbl_env2 = foldl del_avail gbl_env1 hides
 510
 511     add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
 512     add_avail env avail = foldl add_name env (availNames avail)
 513
 514     add_name env name
 515         | unqual_imp = env2
 516         | otherwise  = env1
 517         where
 518           env1 = addOneToGlobalRdrEnv env  (mkRdrQual this_mod occ) (name,prov)
 519           env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ)        (name,prov)
 520           occ  = nameOccName name
 521           prov = mk_provenance name
 522
 523     del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
 524                         where
 525                           rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
 526
 527 mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv
 528 -- Used to construct a GlobalRdrEnv for an interface that we've
 529 -- read from a .hi file.  We can't construct the original top-level
 530 -- environment because we don't have enough info, but we compromise
 531 -- by making an environment from its exports
 532 mkIfaceGlobalRdrEnv m_avails
 533   = foldl add emptyRdrEnv m_avails
 534   where
 535     add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True [] (\n -> LocalDef) avails)
 536 \end{code}
 537
 538 \begin{code}
 539 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 540 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 541
 542 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv
 543 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 544
 545 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 546 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 547
 548 combine_globals :: [(Name,Provenance)]  -- Old
 549                 -> [(Name,Provenance)]  -- New
 550                 -> [(Name,Provenance)]
 551 combine_globals ns_old ns_new   -- ns_new is often short
 552   = foldr add ns_old ns_new
 553   where
 554     add n ns | any (is_duplicate n) ns_old = map (choose n) ns  -- Eliminate duplicates
 555              | otherwise                   = n:ns
 556
 557     choose n m | n `beats` m = n
 558                | otherwise   = m
 559
 560     (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
 561
 562     is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
 563     is_duplicate (n1,LocalDef) (n2,LocalDef) = False
 564     is_duplicate (n1,_)        (n2,_)        = n1 == n2
 565 \end{code}
 566
 567 We treat two bindings of a locally-defined name as a duplicate,
 568 because they might be two separate, local defns and we want to report
 569 and error for that, {\em not} eliminate a duplicate.
 570
 571 On the other hand, if you import the same name from two different
 572 import statements, we {\em do} want to eliminate the duplicate, not report
 573 an error.
 574
 575 If a module imports itself then there might be a local defn and an imported
 576 defn of the same name; in this case the names will compare as equal, but
 577 will still have different provenances.
 578
 579
 580 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 581 its unqualified name is in scope.  This is put as a boolean flag in
 582 the @Name@'s provenance to guide whether or not to print the name qualified
 583 in error messages.
 584
 585 \begin{code}
 586 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 587 unQualInScope env
 588   = (`elemNameSet` unqual_names)
 589   where
 590     unqual_names :: NameSet
 591     unqual_names = foldRdrEnv add emptyNameSet env
 592     add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
 593     add _        _          unquals                     = unquals
 594 \end{code}
 595
 596
 597 %************************************************************************
 598 %*                                                                      *
 599 \subsection{Avails}
 600 %*                                                                      *
 601 %************************************************************************
 602
 603 \begin{code}
 604 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 605 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 606 -- Added SOF 4/97
 607 #ifdef DEBUG
 608 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 609 #endif
 610
 611 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 612 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 613
 614 emptyAvailEnv = emptyNameEnv
 615 unitAvailEnv :: AvailInfo -> AvailEnv
 616 unitAvailEnv a = unitNameEnv (availName a) a
 617
 618 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 619 plusAvailEnv = plusNameEnv_C plusAvail
 620
 621 availEnvElts = nameEnvElts
 622
 623 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 624 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 625
 626 availsToNameSet :: [AvailInfo] -> NameSet
 627 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 628
 629 availName :: GenAvailInfo name -> name
 630 availName (Avail n)     = n
 631 availName (AvailTC n _) = n
 632
 633 availNames :: GenAvailInfo name -> [name]
 634 availNames (Avail n)      = [n]
 635 availNames (AvailTC n ns) = ns
 636
 637 -------------------------------------
 638 filterAvail :: RdrNameIE        -- Wanted
 639             -> AvailInfo        -- Available
 640             -> Maybe AvailInfo  -- Resulting available;
 641                                 -- Nothing if (any of the) wanted stuff isn't there
 642
 643 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 644   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 645   | otherwise    = Nothing
 646   where
 647     is_wanted name = nameOccName name `elem` wanted_occs
 648     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 649     avail_occs     = map nameOccName ns
 650     wanted_occs    = map rdrNameOcc (want:wants)
 651
 652 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 653                                                   Just (AvailTC n [n])
 654
 655 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 656
 657 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 658 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 659                                                 where
 660                                                   wanted n = nameOccName n == occ
 661                                                   occ      = rdrNameOcc v
 662         -- The second equation happens if we import a class op, thus
 663         --      import A( op )
 664         -- where op is a class operation
 665
 666 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 667         -- We don't complain even if the IE says T(..), but
 668         -- no constrs/class ops of T are available
 669         -- Instead that's caught with a warning by the caller
 670
 671 filterAvail ie avail = Nothing
 672
 673 -------------------------------------
 674 groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
 675   -- Group by module and sort by occurrence
 676   -- This keeps the list in canonical order
 677 groupAvails this_mod avails
 678   = [ (mkSysModuleNameFS fs, sortLt lt avails)
 679     | (fs,avails) <- fmToList groupFM
 680     ]
 681   where
 682     groupFM :: FiniteMap FastString Avails
 683         -- Deliberately use the FastString so we
 684         -- get a canonical ordering
 685     groupFM = foldl add emptyFM avails
 686
 687     add env avail = addToFM_C combine env mod_fs [avail']
 688                   where
 689                     mod_fs = moduleNameFS (moduleName avail_mod)
 690                     avail_mod = case nameModule_maybe (availName avail) of
 691                                           Just m  -> m
 692                                           Nothing -> this_mod
 693                     combine old _ = avail':old
 694                     avail'        = sortAvail avail
 695
 696     a1 `lt` a2 = occ1 < occ2
 697                where
 698                  occ1  = nameOccName (availName a1)
 699                  occ2  = nameOccName (availName a2)
 700
 701 sortAvail :: AvailInfo -> AvailInfo
 702 -- Sort the sub-names into canonical order.
 703 -- The canonical order has the "main name" at the beginning
 704 -- (if it's there at all)
 705 sortAvail (Avail n) = Avail n
 706 sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
 707                          | otherwise   = AvailTC n (    sortLt lt ns)
 708                          where
 709                            n1 `lt` n2 = nameOccName n1 < nameOccName n2
 710 \end{code}
 711
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection{Free variable manipulation}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 \begin{code}
 720 -- A useful utility
 721 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 722                let
 723                   (ys, fvs_s) = unzip stuff
 724                in
 725                returnRn (ys, plusFVs fvs_s)
 726 \end{code}
 727
 728
 729 %************************************************************************
 730 %*                                                                      *
 731 \subsection{Envt utility functions}
 732 %*                                                                      *
 733 %************************************************************************
 734
 735 \begin{code}
 736 warnUnusedModules :: [ModuleName] -> RnM d ()
 737 warnUnusedModules mods
 738   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 739     if warn then mapRn_ (addWarnRn . unused_mod) mods
 740             else returnRn ()
 741   where
 742     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 743                            text "is imported, but nothing from it is used",
 744                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 745                                    quotes (ppr m))]
 746
 747 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 748 warnUnusedImports names
 749   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 750     if warn then warnUnusedBinds names else returnRn ()
 751
 752 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 753 warnUnusedLocalBinds names
 754   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 755     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 756             else returnRn ()
 757
 758 warnUnusedMatches names
 759   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 760     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 761             else returnRn ()
 762
 763 -------------------------
 764
 765 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 766 warnUnusedBinds names
 767   = mapRn_ warnUnusedGroup  groups
 768   where
 769         -- Group by provenance
 770    groups = equivClasses cmp names
 771    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 772
 773
 774 -------------------------
 775
 776 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 777 warnUnusedGroup names
 778   | null filtered_names  = returnRn ()
 779   | not is_local         = returnRn ()
 780   | otherwise
 781   = pushSrcLocRn def_loc        $
 782     addWarnRn                   $
 783     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 784   where
 785     filtered_names = filter reportable names
 786     (name1, prov1) = head filtered_names
 787     (is_local, def_loc, msg)
 788         = case prov1 of
 789                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 790
 791                 NonLocalDef (UserImport mod loc _)
 792                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 793
 794     reportable (name,_) = case occNameUserString (nameOccName name) of
 795                                 ('_' : _) -> False
 796                                 zz_other  -> True
 797         -- Haskell 98 encourages compilers to suppress warnings about
 798         -- unused names in a pattern if they start with "_".
 799 \end{code}
 800
 801 \begin{code}
 802 addNameClashErrRn rdr_name (np1:nps)
 803   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 804                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 805   where
 806     msg1 = ptext  SLIT("either") <+> mk_ref np1
 807     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 808     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 809
 810 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 811   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 812         4 (vcat [ppr how_in_scope1,
 813                  ppr how_in_scope2])
 814
 815 shadowedNameWarn shadow
 816   = hsep [ptext SLIT("This binding for"),
 817                quotes (ppr shadow),
 818                ptext SLIT("shadows an existing binding")]
 819
 820 unknownNameErr name
 821   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 822   where
 823     flavour = occNameFlavour (rdrNameOcc name)
 824
 825 qualNameErr descriptor (name,loc)
 826   = pushSrcLocRn loc $
 827     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 828                      quotes (ppr name),
 829                      ptext SLIT("in"),
 830                      descriptor])
 831
 832 dupNamesErr descriptor ((name,loc) : dup_things)
 833   = pushSrcLocRn loc $
 834     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 835               $$
 836               (ptext SLIT("in") <+> descriptor))
 837 \end{code}