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