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