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