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         ( RdrName(..), RdrNameIE,
  15                           rdrNameOcc, isQual, qual
  16                         )
  17 import HsTypes          ( getTyVarName, replaceTyVarName )
  18 import BasicTypes       ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
  19 import RnMonad
  20 import Name             ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
  21                           ImportReason(..), getSrcLoc,
  22                           mkLocalName, mkGlobalName,
  23                           nameOccName,
  24                           pprOccName, isLocalName, isLocallyDefined, isAnonOcc,
  25                           setNameProvenance, getNameProvenance, pprNameProvenance
  26                         )
  27 import NameSet
  28 import OccName          ( OccName, mkModuleFS,
  29                           mkDFunOcc, tcOcc, varOcc, tvOcc,
  30                           isVarOcc, occNameFlavour, occNameString
  31                         )
  32 import TyCon            ( TyCon )
  33 import FiniteMap
  34 import Unique           ( Unique, Uniquable(..), unboundKey )
  35 import UniqFM           ( emptyUFM, listToUFM, plusUFM_C )
  36 import UniqSupply
  37 import SrcLoc           ( SrcLoc, noSrcLoc )
  38 import Outputable
  39 import Util             ( removeDups )
  40 import List             ( nub )
  41 import Char             ( isAlphanum )
  42 \end{code}
  43
  44
  45
  46 %*********************************************************
  47 %*                                                      *
  48 \subsection{Making new rdr names}
  49 %*                                                      *
  50 %*********************************************************
  51
  52 These functions make new RdrNames from stuff read from an interface file
  53
  54 \begin{code}
  55 ifaceQualTC  (m,n,hif) = Qual (mkModuleFS m) (tcOcc n) hif
  56 ifaceQualVar (m,n,hif) = Qual (mkModuleFS m) (varOcc n) hif
  57
  58 ifaceUnqualTC  n = Unqual (tcOcc n)
  59 ifaceUnqualVar n = Unqual (varOcc n)
  60 ifaceUnqualTv  n = Unqual (tvOcc n)
  61 \end{code}
  62
  63 %*********************************************************
  64 %*                                                      *
  65 \subsection{Making new names}
  66 %*                                                      *
  67 %*********************************************************
  68
  69 \begin{code}
  70 newImportedGlobalName :: Module -> OccName -> IfaceFlavour
  71                       -> RnM s d Name
  72 newImportedGlobalName mod occ hif
  73   =     -- First check the cache
  74     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  75     let
  76         key = (mod,occ)
  77         prov = NonLocalDef ImplicitImport hif False
  78         -- For in-scope things we improve the provenance in RnNames.qualifyImports
  79     in
  80     case lookupFM cache key of
  81
  82         -- A hit in the cache!
  83         -- If it has no provenance at the moment then set its provenance
  84         -- so that it has the right HiFlag component.
  85         -- (This is necessary for known-key things.
  86         --      For example, GHCmain.lhs imports as SOURCE
  87         --      Main; but Main.main is a known-key thing.)
  88         -- Don't fiddle with the provenance if it already has one
  89         Just name -> case getNameProvenance name of
  90                         NoProvenance -> let
  91                                           new_name = setNameProvenance name prov
  92                                           new_cache = addToFM cache key new_name
  93                                         in
  94                                         setNameSupplyRn (us, inst_ns, new_cache)        `thenRn_`
  95                                         returnRn new_name
  96                         other        -> returnRn name
  97
  98         Nothing ->      -- Miss in the cache!
  99                         -- Build a new original name, and put it in the cache
 100                    let
 101                         (us', us1) = splitUniqSupply us
 102                         uniq       = uniqFromSupply us1
 103                         name       = mkGlobalName uniq mod occ prov
 104                         new_cache  = addToFM cache key name
 105                    in
 106                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
 107                    returnRn name
 108
 109
 110 newImportedGlobalFromRdrName (Qual mod_name occ hif)
 111   = newImportedGlobalName mod_name occ hif
 112
 113 newImportedGlobalFromRdrName (Unqual occ)
 114   =     -- An Unqual is allowed; interface files contain
 115         -- unqualified names for locally-defined things, such as
 116         -- constructors of a data type.
 117     getModuleRn         `thenRn ` \ mod_name ->
 118     newImportedGlobalName mod_name occ HiFile
 119
 120
 121 newLocallyDefinedGlobalName :: Module -> OccName
 122                             -> (Name -> ExportFlag) -> SrcLoc
 123                             -> RnM s d Name
 124 newLocallyDefinedGlobalName mod occ rec_exp_fn loc
 125   =     -- First check the cache
 126     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 127     let
 128         key          = (mod,occ)
 129         mk_prov name = LocalDef loc (rec_exp_fn name)
 130         -- We must set the provenance of the thing in the cache
 131         -- correctly, particularly whether or not it is locally defined.
 132         --
 133         -- Since newLocallyDefinedGlobalName is used only
 134         -- at binding occurrences, we may as well get the provenance
 135         -- dead right first time; hence the rec_exp_fn passed in
 136     in
 137     case lookupFM cache key of
 138
 139         -- A hit in the cache!
 140         -- Overwrite whatever provenance is in the cache already;
 141         -- this updates WiredIn things and known-key things,
 142         -- which are there from the start, to LocalDef.
 143         --
 144         -- It also means that if there are two defns for the same thing
 145         -- in a module, then each gets a separate SrcLoc
 146         Just name -> let
 147                         new_name = setNameProvenance name (mk_prov new_name)
 148                         new_cache = addToFM cache key new_name
 149                      in
 150                      setNameSupplyRn (us, inst_ns, new_cache)           `thenRn_`
 151                      returnRn new_name
 152
 153         -- Miss in the cache!
 154         -- Build a new original name, and put it in the cache
 155         Nothing -> let
 156                         (us', us1) = splitUniqSupply us
 157                         uniq       = uniqFromSupply us1
 158                         new_name   = mkGlobalName uniq mod occ (mk_prov new_name)
 159                         new_cache  = addToFM cache key new_name
 160                    in
 161                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
 162                    returnRn new_name
 163
 164
 165 newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
 166 newLocalNames rdr_names
 167   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 168     let
 169         n          = length rdr_names
 170         (us', us1) = splitUniqSupply us
 171         uniqs      = uniqsFromSupply n us1
 172           -- Note: we're not making use of the source location. Not good.
 173         locals     = [ mkLocalName uniq (rdrNameOcc rdr_name)
 174                      | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
 175                      ]
 176     in
 177     setNameSupplyRn (us', inst_ns, cache)       `thenRn_`
 178     returnRn locals
 179
 180 newDFunName cl_occ tycon_occ (Just n) src_loc           -- Imported ones have "Just n"
 181   = getModuleRn         `thenRn` \ mod_name ->
 182     newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
 183
 184 newDFunName cl_occ tycon_occ Nothing src_loc            -- Local instance decls have a "Nothing"
 185   = getModuleRn                         `thenRn` \ mod_name ->
 186     newInstUniq (cl_occ, tycon_occ)     `thenRn` \ inst_uniq ->
 187     let
 188         dfun_occ = mkDFunOcc cl_occ tycon_occ inst_uniq
 189     in
 190     newLocallyDefinedGlobalName mod_name dfun_occ (\_ -> Exported) src_loc
 191
 192
 193 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
 194 -- during compiler debugging.
 195 mkUnboundName :: RdrName -> Name
 196 mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name)
 197
 198 isUnboundName :: Name -> Bool
 199 isUnboundName name = getUnique name == unboundKey
 200 \end{code}
 201
 202 \begin{code}
 203 -------------------------------------
 204 bindLocatedLocalsRn :: SDoc                     -- Documentation string for error message
 205                     -> [(RdrName,SrcLoc)]
 206                     -> ([Name] -> RnMS s a)
 207                     -> RnMS s a
 208 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 209   = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 210
 211     getLocalNameEnv                     `thenRn` \ name_env ->
 212     (if opt_WarnNameShadowing
 213      then
 214         mapRn (check_shadow name_env) rdr_names_w_loc
 215      else
 216         returnRn []
 217     )                                   `thenRn_`
 218
 219     newLocalNames rdr_names_w_loc       `thenRn` \ names ->
 220     let
 221         new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 222     in
 223     setLocalNameEnv new_name_env (enclosed_scope names)
 224   where
 225     check_shadow name_env (rdr_name,loc)
 226         = case lookupRdrEnv name_env rdr_name of
 227                 Nothing   -> returnRn ()
 228                 Just name -> pushSrcLocRn loc $
 229                              addWarnRn (shadowedNameWarn rdr_name)
 230
 231
 232 -------------------------------------
 233 bindLocalsRn doc_str rdr_names enclosed_scope
 234   = getSrcLocRn         `thenRn` \ loc ->
 235     bindLocatedLocalsRn (text doc_str)
 236                         (rdr_names `zip` repeat loc)
 237                         enclosed_scope
 238
 239         -- binLocalsFVRn is the same as bindLocalsRn
 240         -- except that it deals with free vars
 241 bindLocalsFVRn doc_str rdr_names enclosed_scope
 242   = bindLocalsRn doc_str rdr_names      $ \ names ->
 243     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 244     returnRn (thing, delListFromNameSet fvs names)
 245
 246 -------------------------------------
 247 extendTyVarEnvRn :: [HsTyVar Name] -> RnMS s a -> RnMS s a
 248         -- This tiresome function is used only in rnDecl on InstDecl
 249 extendTyVarEnvRn tyvars enclosed_scope
 250   = getLocalNameEnv             `thenRn` \ env ->
 251     let
 252         new_env = addListToRdrEnv env [ (Unqual (getOccName name), name)
 253                                       | tyvar <- tyvars,
 254                                         let name = getTyVarName tyvar
 255                                       ]
 256     in
 257     setLocalNameEnv new_env enclosed_scope
 258
 259 bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
 260               -> ([HsTyVar Name] -> RnMS s a)
 261               -> RnMS s a
 262 bindTyVarsRn doc_str tyvar_names enclosed_scope
 263   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 264     enclosed_scope tyvars
 265
 266 -- Gruesome name: return Names as well as HsTyVars
 267 bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
 268               -> ([Name] -> [HsTyVar Name] -> RnMS s a)
 269               -> RnMS s a
 270 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 271   = getSrcLocRn                                 `thenRn` \ loc ->
 272     let
 273         located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
 274     in
 275     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 276     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 277
 278 bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
 279               -> ([HsTyVar Name] -> RnMS s (a, FreeVars))
 280               -> RnMS s (a, FreeVars)
 281 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 282   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 283     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 284     returnRn (thing, delListFromNameSet fvs names)
 285
 286 bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
 287               -> ([Name] -> [HsTyVar Name] -> RnMS s (a, FreeVars))
 288               -> RnMS s (a, FreeVars)
 289 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 290   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 291     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 292     returnRn (thing, delListFromNameSet fvs names)
 293
 294
 295 -------------------------------------
 296 checkDupOrQualNames, checkDupNames :: SDoc
 297                                    -> [(RdrName, SrcLoc)]
 298                                    -> RnM s d ()
 299         -- Works in any variant of the renamer monad
 300
 301 checkDupOrQualNames doc_str rdr_names_w_loc
 302   =     -- Check for use of qualified names
 303     mapRn (qualNameErr doc_str) quals   `thenRn_`
 304     checkDupNames doc_str rdr_names_w_loc
 305   where
 306     quals = filter (isQual.fst) rdr_names_w_loc
 307
 308 checkDupNames doc_str rdr_names_w_loc
 309   =     -- Check for dupicated names in a binding group
 310     mapRn (dupNamesErr doc_str) dups    `thenRn_`
 311     returnRn ()
 312   where
 313     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 314
 315
 316 -- Yuk!
 317 ifaceFlavour name = case getNameProvenance name of
 318                         NonLocalDef _ hif _ -> hif
 319                         other               -> HiFile   -- Shouldn't happen
 320 \end{code}
 321
 322
 323 %*********************************************************
 324 %*                                                      *
 325 \subsection{Looking up names}
 326 %*                                                      *
 327 %*********************************************************
 328
 329 Looking up a name in the RnEnv.
 330
 331 \begin{code}
 332 checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name
 333 checkUnboundRn rdr_name (Just name)
 334   =     -- Found it!
 335      returnRn name
 336
 337 checkUnboundRn rdr_name Nothing
 338   =     -- Not found by lookup
 339     getModeRn   `thenRn` \ mode ->
 340     case mode of
 341         -- Not found when processing source code; so fail
 342         SourceMode    -> failWithRn (mkUnboundName rdr_name)
 343                                     (unknownNameErr rdr_name)
 344
 345         -- Not found when processing an imported declaration,
 346         -- so we create a new name for the purpose
 347         InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name
 348
 349 lookupBndrRn rdr_name
 350   = lookupNameRn rdr_name               `thenRn` \ maybe_name ->
 351     checkUnboundRn rdr_name maybe_name
 352
 353 -- Just like lookupRn except that we record the occurrence too
 354 -- Perhaps surprisingly, even wired-in names are recorded.
 355 -- Why?  So that we know which wired-in names are referred to when
 356 -- deciding which instance declarations to import.
 357 lookupOccRn :: RdrName -> RnMS s Name
 358 lookupOccRn rdr_name
 359   = lookupNameRn rdr_name               `thenRn` \ maybe_name ->
 360     checkUnboundRn rdr_name maybe_name  `thenRn` \ name ->
 361     let
 362         name' = mungePrintUnqual rdr_name name
 363     in
 364     addOccurrenceName name'
 365
 366 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 367 -- environment.  It's used only for
 368 --      record field names
 369 --      class op names in class and instance decls
 370 lookupGlobalOccRn :: RdrName -> RnMS s Name
 371 lookupGlobalOccRn rdr_name
 372   = lookupGlobalNameRn rdr_name         `thenRn` \ maybe_name ->
 373     checkUnboundRn rdr_name maybe_name  `thenRn` \ name ->
 374     let
 375         name' = mungePrintUnqual rdr_name name
 376     in
 377     addOccurrenceName name'
 378
 379
 380 -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
 381 -- if they were mentioned unqualified in the source code.
 382 -- This improves error messages from the type checker.
 383 -- NB: the binding site is treated differently; see lookupBndrRn
 384 --     After the type checker all occurrences are replaced by the one
 385 --     at the binding site.
 386 mungePrintUnqual (Qual _ _ _) name = name
 387 mungePrintUnqual (Unqual _)   name
 388   = case getNameProvenance name of
 389         NonLocalDef imp hif False -> setNameProvenance name (NonLocalDef imp hif True)
 390         other                     -> name
 391
 392 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
 393 -- adds it to the occurrence pool so that it'll be loaded later.  This is
 394 -- used when language constructs (such as monad comprehensions, overloaded literals,
 395 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
 396 -- mentioned in the code.
 397 --
 398 -- This doesn't apply in interface mode, where everything is explicit, but
 399 -- we don't check for this case: it does no harm to record an "extra" occurrence
 400 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
 401 -- Nothing clause of rnDerivs that calls it at all I think).
 402 --      [Jan 98: this comment is wrong: rnHsType uses it quite a bit.]
 403 --
 404 -- For List and Tuple types it's important to get the correct
 405 -- isLocallyDefined flag, which is used in turn when deciding
 406 -- whether there are any instance decls in this module are "special".
 407 -- The name cache should have the correct provenance, though.
 408
 409 lookupImplicitOccRn :: RdrName -> RnMS s Name
 410 lookupImplicitOccRn (Qual mod occ hif)
 411  = newImportedGlobalName mod occ hif    `thenRn` \ name ->
 412    addOccurrenceName name
 413
 414 addImplicitOccRn :: Name -> RnMS s Name
 415 addImplicitOccRn name = addOccurrenceName name
 416
 417 addImplicitOccsRn :: [Name] -> RnMS s ()
 418 addImplicitOccsRn names = addOccurrenceNames names
 419 \end{code}
 420
 421 \begin{code}
 422 lookupFixity :: Name -> RnMS s Fixity
 423 lookupFixity name
 424   = getFixityEnv        `thenRn` \ fixity_env ->
 425     case lookupNameEnv fixity_env name of
 426         Just (FixitySig _ fixity _) -> returnRn fixity
 427         Nothing                     -> returnRn (Fixity 9 InfixL)       -- Default case
 428 \end{code}
 429
 430 mkPrintUnqualFn returns a function that takes a Name and tells whether
 431 its unqualified name is in scope.  This is put as a boolean flag in
 432 the Name's provenance to guide whether or not to print the name qualified
 433 in error messages.
 434
 435 \begin{code}
 436 mkPrintUnqualFn :: GlobalRdrEnv -> Name -> Bool
 437 mkPrintUnqualFn env
 438   = lookup
 439   where
 440     lookup name = case lookupRdrEnv env (Unqual (nameOccName name)) of
 441                            Just [name'] -> name == name'
 442                            other        -> False
 443 \end{code}
 444
 445 %************************************************************************
 446 %*                                                                      *
 447 \subsection{Envt utility functions}
 448 %*                                                                      *
 449 %************************************************************************
 450
 451 ===============  RnEnv  ================
 452 \begin{code}
 453 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
 454   = RnEnv (n1 `plusGlobalRdrEnv` n2)
 455           (f1 `plusNameEnv`     f2)
 456 \end{code}
 457
 458
 459 ===============  NameEnv  ================
 460 \begin{code}
 461 -- Look in global env only
 462 lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name)
 463 lookupGlobalNameRn rdr_name
 464   = getNameEnvs         `thenRn` \ (global_env, local_env) ->
 465     lookup_global global_env rdr_name
 466
 467 -- Look in both local and global env
 468 lookupNameRn :: RdrName -> RnMS s (Maybe Name)
 469 lookupNameRn rdr_name
 470   = getNameEnvs         `thenRn` \ (global_env, local_env) ->
 471     case lookupRdrEnv local_env rdr_name of
 472           Just name -> returnRn (Just name)
 473           Nothing   -> lookup_global global_env rdr_name
 474
 475 lookup_global global_env rdr_name
 476   = case lookupRdrEnv global_env rdr_name of
 477         Just [name]         -> returnRn (Just name)
 478         Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
 479                                returnRn (Just name)
 480         Nothing -> returnRn Nothing
 481
 482 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 483 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 484
 485 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
 486 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 487
 488 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 489 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 490
 491 combine_globals :: [Name]       -- Old
 492                 -> [Name]       -- New
 493                 -> [Name]
 494 combine_globals ns_old ns_new   -- ns_new is often short
 495   = foldr add ns_old ns_new
 496   where
 497     add n ns | all (no_conflict n) ns_old = map choose ns       -- Eliminate duplicates
 498              | otherwise                  = n:ns
 499              where
 500                choose n' | n==n' && better_provenance n n' = n
 501                          | otherwise                       = n'
 502
 503 -- Choose
 504 --      a local thing                 over an   imported thing
 505 --      a user-imported thing         over a    non-user-imported thing
 506 --      an explicitly-imported thing  over an   implicitly imported thing
 507 better_provenance n1 n2
 508   = case (getNameProvenance n1, getNameProvenance n2) of
 509         (LocalDef _ _,                          _                             ) -> True
 510         (NonLocalDef (UserImport _ _ True) _ _, _                             ) -> True
 511         (NonLocalDef (UserImport _ _ _   ) _ _, NonLocalDef ImplicitImport _ _) -> True
 512         other                                                                   -> False
 513
 514 no_conflict :: Name -> Name -> Bool
 515 no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
 516                   | otherwise                                  = n1 == n2
 517         -- We complain of a conflict if one RdrName maps to two different Names,
 518         -- OR if one RdrName maps to the same *locally-defined* Name.  The latter
 519         -- case is to catch two separate, local definitions of the same thing.
 520         --
 521         -- If a module imports itself then there might be a local defn and an imported
 522         -- defn of the same name; in this case the names will compare as equal, but
 523         -- will still have different provenances
 524 \end{code}
 525
 526
 527
 528 ===============  ExportAvails  ================
 529 \begin{code}
 530 mkEmptyExportAvails :: Module -> ExportAvails
 531 mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
 532
 533 mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
 534 mkExportAvails mod_name unqual_imp name_env avails
 535   = (mod_avail_env, entity_avail_env)
 536   where
 537     mod_avail_env = unitFM mod_name unqual_avails
 538
 539         -- unqual_avails is the Avails that are visible in *unqualfied* form
 540         -- (1.4 Report, Section 5.1.1)
 541         -- For example, in
 542         --      import T hiding( f )
 543         -- we delete f from avails
 544
 545     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 546                   | otherwise      = [prune avail | avail <- avails]
 547
 548     prune (Avail n) | unqual_in_scope n = Avail n
 549     prune (Avail n) | otherwise         = NotAvailable
 550     prune (AvailTC n ns)                = AvailTC n (filter unqual_in_scope ns)
 551
 552     unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
 553
 554     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 555                                                   name  <- availNames avail]
 556
 557 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 558 plusExportAvails (m1, e1) (m2, e2)
 559   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 560         -- ToDo: wasteful: we do this once for each constructor!
 561 \end{code}
 562
 563
 564 ===============  AvailInfo  ================
 565 \begin{code}
 566 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 567 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 568 plusAvail a NotAvailable = a
 569 plusAvail NotAvailable a = a
 570 -- Added SOF 4/97
 571 #ifdef DEBUG
 572 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 573 #endif
 574
 575 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 576 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 577
 578 availsToNameSet :: [AvailInfo] -> NameSet
 579 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 580
 581 availName :: AvailInfo -> Name
 582 availName (Avail n)     = n
 583 availName (AvailTC n _) = n
 584
 585 availNames :: AvailInfo -> [Name]
 586 availNames NotAvailable   = []
 587 availNames (Avail n)      = [n]
 588 availNames (AvailTC n ns) = ns
 589
 590 filterAvail :: RdrNameIE        -- Wanted
 591             -> AvailInfo        -- Available
 592             -> AvailInfo        -- Resulting available;
 593                                 -- NotAvailable if (any of the) wanted stuff isn't there
 594
 595 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 596   | sub_names_ok = AvailTC n (filter is_wanted ns)
 597   | otherwise    =
 598 #ifdef DEBUG
 599                    pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
 600 #endif
 601                    NotAvailable
 602   where
 603     is_wanted name = nameOccName name `elem` wanted_occs
 604     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 605     avail_occs     = map nameOccName ns
 606     wanted_occs    = map rdrNameOcc (want:wants)
 607
 608 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 609                                                   AvailTC n [n]
 610 filterAvail (IEThingAll _) avail@(AvailTC _ _)  = avail
 611
 612 filterAvail (IEVar _)      avail@(Avail n)      = avail
 613 filterAvail (IEVar v)      avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
 614                                                 where
 615                                                   wanted n = nameOccName n == occ
 616                                                   occ      = rdrNameOcc v
 617         -- The second equation happens if we import a class op, thus
 618         --      import A( op )
 619         -- where op is a class operation
 620
 621
 622 #ifdef DEBUG
 623 filterAvail ie avail = pprPanic "filterAvail" (ppr ie $$ pprAvail avail)
 624 #endif
 625
 626
 627 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 628 pprAvail avail = getPprStyle $ \ sty ->
 629                  if ifaceStyle sty then
 630                     ppr_avail (pprOccName . nameOccName) avail
 631                  else
 632                     ppr_avail ppr avail
 633
 634 ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable")
 635 ppr_avail pp_name (AvailTC n ns) = hsep [
 636                                      pp_name n,
 637                                      parens  $ hsep $ punctuate comma $
 638                                      map pp_name ns
 639                                    ]
 640 ppr_avail pp_name (Avail n) = pp_name n
 641 \end{code}
 642
 643
 644
 645
 646 %************************************************************************
 647 %*                                                                      *
 648 \subsection{Free variable manipulation}
 649 %*                                                                      *
 650 %************************************************************************
 651
 652 \begin{code}
 653 type FreeVars   = NameSet
 654
 655 plusFV   :: FreeVars -> FreeVars -> FreeVars
 656 addOneFV :: FreeVars -> Name -> FreeVars
 657 unitFV   :: Name -> FreeVars
 658 emptyFVs :: FreeVars
 659 plusFVs  :: [FreeVars] -> FreeVars
 660
 661 plusFV    = unionNameSets
 662 addOneFV  = addOneToNameSet
 663 unitFV    = unitNameSet
 664 emptyFVs  = emptyNameSet
 665 plusFVs   = unionManyNameSets
 666 \end{code}
 667
 668
 669 %************************************************************************
 670 %*                                                                      *
 671 \subsection{Envt utility functions}
 672 %*                                                                      *
 673 %************************************************************************
 674
 675
 676 \begin{code}
 677 warnUnusedBinds, warnUnusedMatches :: [Name] -> RnM s d ()
 678
 679 warnUnusedTopNames ns
 680   | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
 681   = returnRn () -- Don't force ns unless necessary
 682
 683 warnUnusedTopNames (n:ns)
 684   | is_local     && opt_WarnUnusedBinds   = warnUnusedNames False{-include name's provenance-} ns
 685   | not is_local && opt_WarnUnusedImports = warnUnusedNames False ns
 686   where
 687     is_local = isLocallyDefined n
 688
 689 warnUnusedTopName other = returnRn ()
 690
 691 warnUnusedBinds ns
 692   | not opt_WarnUnusedBinds = returnRn ()
 693   | otherwise               = warnUnusedNames False ns
 694
 695 {-
 696  Haskell 98 encourages compilers to suppress warnings about
 697  unused names in a pattern if they start with "_". Which
 698  we do here.
 699
 700  Note: omit the inclusion of the names' provenance in the
 701  generated warning -- it's already given in the header
 702  of the warning (+ the local names we've been given have
 703  a provenance that's ultra low in content.)
 704
 705 -}
 706 warnUnusedMatches names
 707   | opt_WarnUnusedMatches = warnUnusedNames True (filter (not.isAnonOcc.getOccName) names)
 708   | otherwise             = returnRn ()
 709
 710 warnUnusedNames :: Bool{-display provenance-} -> [Name] -> RnM s d ()
 711 warnUnusedNames _ []
 712   = returnRn ()
 713
 714 warnUnusedNames short_msg names
 715   = addWarnRn $
 716     sep [text "The following names are unused:",
 717          nest 4 ((if short_msg then hsep else vcat) (map pp names))]
 718   where
 719     pp n
 720      | short_msg = ppr n
 721      | otherwise = ppr n <> comma <+> pprNameProvenance n
 722
 723 addNameClashErrRn rdr_name names
 724 {-      NO LONGER NEEDED WITH LAZY NAME-CLASH REPORTING
 725   | isClassDataConRdrName rdr_name
 726         -- Nasty hack to prevent error messages complain about conflicts for ":C",
 727         -- where "C" is a class.  There'll be a message about C, and :C isn't
 728         -- the programmer's business.  There may be a better way to filter this
 729         -- out, but I couldn't get up the energy to find it.
 730   = returnRn ()
 731
 732   | otherwise
 733 -}
 734
 735   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 736                     ptext SLIT("It could refer to:") <+> vcat (map mk_ref names)])
 737   where
 738     mk_ref name = ppr name <> colon <+> pprNameProvenance name
 739
 740 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 741   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 742         4 (vcat [ppr how_in_scope1,
 743                  ppr how_in_scope2])
 744
 745 shadowedNameWarn shadow
 746   = hsep [ptext SLIT("This binding for"),
 747                quotes (ppr shadow),
 748                ptext SLIT("shadows an existing binding")]
 749
 750 unknownNameErr name
 751   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 752   where
 753     flavour = occNameFlavour (rdrNameOcc name)
 754
 755 qualNameErr descriptor (name,loc)
 756   = pushSrcLocRn loc $
 757     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 758                      quotes (ppr name),
 759                      ptext SLIT("in"),
 760                      descriptor])
 761
 762 dupNamesErr descriptor ((name,loc) : dup_things)
 763   = pushSrcLocRn loc $
 764     addErrRn (hsep [ptext SLIT("Conflicting definitions for"),
 765                     quotes (ppr name),
 766                     ptext SLIT("in"), descriptor])
 767 \end{code}
 768