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