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