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