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                            other        -> 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
 503 --      a local thing                 over an   imported thing
 504 --      a user-imported thing         over a    non-user-imported thing
 505 --      an explicitly-imported thing  over an   implicitly imported thing
 506 better_provenance n1 n2
 507   = case (getNameProvenance n1, getNameProvenance n2) of
 508         (LocalDef _ _,                          _                             ) -> True
 509         (NonLocalDef (UserImport _ _ True) _ _, _                             ) -> True
 510         (NonLocalDef (UserImport _ _ _   ) _ _, NonLocalDef ImplicitImport _ _) -> True
 511         other                                                                   -> False
 512
 513 no_conflict :: Name -> Name -> Bool
 514 no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
 515                   | otherwise                                  = n1 == n2
 516         -- We complain of a conflict if one RdrName maps to two different Names,
 517         -- OR if one RdrName maps to the same *locally-defined* Name.  The latter
 518         -- case is to catch two separate, local definitions of the same thing.
 519         --
 520         -- If a module imports itself then there might be a local defn and an imported
 521         -- defn of the same name; in this case the names will compare as equal, but
 522         -- will still have different provenances
 523 \end{code}
 524
 525
 526
 527 ===============  ExportAvails  ================
 528 \begin{code}
 529 mkEmptyExportAvails :: Module -> ExportAvails
 530 mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
 531
 532 mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
 533 mkExportAvails mod_name unqual_imp name_env avails
 534   = (mod_avail_env, entity_avail_env)
 535   where
 536     mod_avail_env = unitFM mod_name unqual_avails
 537
 538         -- unqual_avails is the Avails that are visible in *unqualfied* form
 539         -- (1.4 Report, Section 5.1.1)
 540         -- For example, in
 541         --      import T hiding( f )
 542         -- we delete f from avails
 543
 544     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 545                   | otherwise      = [prune avail | avail <- avails]
 546
 547     prune (Avail n) | unqual_in_scope n = Avail n
 548     prune (Avail n) | otherwise         = NotAvailable
 549     prune (AvailTC n ns)                = AvailTC n (filter unqual_in_scope ns)
 550
 551     unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
 552
 553     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 554                                                   name  <- availNames avail]
 555
 556 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 557 plusExportAvails (m1, e1) (m2, e2)
 558   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 559         -- ToDo: wasteful: we do this once for each constructor!
 560 \end{code}
 561
 562
 563 ===============  AvailInfo  ================
 564 \begin{code}
 565 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 566 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 567 plusAvail a NotAvailable = a
 568 plusAvail NotAvailable a = a
 569 -- Added SOF 4/97
 570 #ifdef DEBUG
 571 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 572 #endif
 573
 574 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 575 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 576
 577 availsToNameSet :: [AvailInfo] -> NameSet
 578 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 579
 580 availName :: AvailInfo -> Name
 581 availName (Avail n)     = n
 582 availName (AvailTC n _) = n
 583
 584 availNames :: AvailInfo -> [Name]
 585 availNames NotAvailable   = []
 586 availNames (Avail n)      = [n]
 587 availNames (AvailTC n ns) = ns
 588
 589 filterAvail :: RdrNameIE        -- Wanted
 590             -> AvailInfo        -- Available
 591             -> AvailInfo        -- Resulting available;
 592                                 -- NotAvailable if (any of the) wanted stuff isn't there
 593
 594 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 595   | sub_names_ok = AvailTC n (filter is_wanted ns)
 596   | otherwise    =
 597 #ifdef DEBUG
 598                    pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
 599 #endif
 600                    NotAvailable
 601   where
 602     is_wanted name = nameOccName name `elem` wanted_occs
 603     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 604     avail_occs     = map nameOccName ns
 605     wanted_occs    = map rdrNameOcc (want:wants)
 606
 607 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 608                                                   AvailTC n [n]
 609 filterAvail (IEThingAll _) avail@(AvailTC _ _)  = avail
 610
 611 filterAvail (IEVar _)      avail@(Avail n)      = avail
 612 filterAvail (IEVar v)      avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
 613                                                 where
 614                                                   wanted n = nameOccName n == occ
 615                                                   occ      = rdrNameOcc v
 616         -- The second equation happens if we import a class op, thus
 617         --      import A( op )
 618         -- where op is a class operation
 619
 620
 621 #ifdef DEBUG
 622 filterAvail ie avail = pprPanic "filterAvail" (ppr ie $$ pprAvail avail)
 623 #endif
 624
 625
 626 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 627 pprAvail avail = getPprStyle $ \ sty ->
 628                  if ifaceStyle sty then
 629                     ppr_avail (pprOccName . nameOccName) avail
 630                  else
 631                     ppr_avail ppr avail
 632
 633 ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable")
 634 ppr_avail pp_name (AvailTC n ns) = hsep [
 635                                      pp_name n,
 636                                      parens  $ hsep $ punctuate comma $
 637                                      map pp_name ns
 638                                    ]
 639 ppr_avail pp_name (Avail n) = pp_name n
 640 \end{code}
 641
 642
 643
 644
 645 %************************************************************************
 646 %*                                                                      *
 647 \subsection{Free variable manipulation}
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 \begin{code}
 652 type FreeVars   = NameSet
 653
 654 plusFV   :: FreeVars -> FreeVars -> FreeVars
 655 addOneFV :: FreeVars -> Name -> FreeVars
 656 unitFV   :: Name -> FreeVars
 657 emptyFVs :: FreeVars
 658 plusFVs  :: [FreeVars] -> FreeVars
 659
 660 plusFV    = unionNameSets
 661 addOneFV  = addOneToNameSet
 662 unitFV    = unitNameSet
 663 emptyFVs  = emptyNameSet
 664 plusFVs   = unionManyNameSets
 665 \end{code}
 666
 667
 668 %************************************************************************
 669 %*                                                                      *
 670 \subsection{Envt utility functions}
 671 %*                                                                      *
 672 %************************************************************************
 673
 674
 675 \begin{code}
 676 warnUnusedBinds, warnUnusedMatches :: [Name] -> RnM s d ()
 677
 678 warnUnusedTopNames ns
 679   | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
 680   = returnRn () -- Don't force ns unless necessary
 681
 682 warnUnusedTopNames (n:ns)
 683   | is_local     && opt_WarnUnusedBinds   = warnUnusedNames ns
 684   | not is_local && opt_WarnUnusedImports = warnUnusedNames ns
 685   where
 686     is_local = isLocallyDefined n
 687
 688 warnUnusedTopName other = returnRn ()
 689
 690 warnUnusedBinds ns
 691   | not opt_WarnUnusedBinds = returnRn ()
 692   | otherwise               = warnUnusedNames ns
 693
 694 warnUnusedMatches names
 695   | opt_WarnUnusedMatches = warnUnusedNames names
 696   | otherwise             = returnRn ()
 697
 698 warnUnusedNames :: [Name] -> RnM s d ()
 699 warnUnusedNames []
 700   = returnRn ()
 701
 702 warnUnusedNames names
 703   = addWarnRn $
 704     sep [text "The following names are unused:",
 705          nest 4 (vcat (map pp names))]
 706   where
 707     pp n = ppr n <> comma <+> pprNameProvenance n
 708
 709
 710 addNameClashErrRn rdr_name names
 711 {-      NO LONGER NEEDED WITH LAZY NAME-CLASH REPORTING
 712   | isClassDataConRdrName rdr_name
 713         -- Nasty hack to prevent error messages complain about conflicts for ":C",
 714         -- where "C" is a class.  There'll be a message about C, and :C isn't
 715         -- the programmer's business.  There may be a better way to filter this
 716         -- out, but I couldn't get up the energy to find it.
 717   = returnRn ()
 718
 719   | otherwise
 720 -}
 721
 722   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 723                     ptext SLIT("It could refer to:") <+> vcat (map mk_ref names)])
 724   where
 725     mk_ref name = ppr name <> colon <+> pprNameProvenance name
 726
 727 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 728   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 729         4 (vcat [ppr how_in_scope1,
 730                  ppr how_in_scope2])
 731
 732 shadowedNameWarn shadow
 733   = hsep [ptext SLIT("This binding for"),
 734                quotes (ppr shadow),
 735                ptext SLIT("shadows an existing binding")]
 736
 737 unknownNameErr name
 738   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 739   where
 740     flavour = occNameFlavour (rdrNameOcc name)
 741
 742 qualNameErr descriptor (name,loc)
 743   = pushSrcLocRn loc $
 744     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 745                      quotes (ppr name),
 746                      ptext SLIT("in"),
 747                      descriptor])
 748
 749 dupNamesErr descriptor ((name,loc) : dup_things)
 750   = pushSrcLocRn loc $
 751     addErrRn (hsep [ptext SLIT("Conflicting definitions for"),
 752                     quotes (ppr name),
 753                     ptext SLIT("in"), descriptor])
 754 \end{code}
 755