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