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