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