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