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