ghc/compiler/rename/RnEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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, isClassDataConRdrName
  16                         )
  17 import HsTypes          ( getTyVarName, replaceTyVarName )
  18 import BasicTypes       ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
  19 import RnMonad
  20 import ErrUtils         ( ErrMsg )
  21 import Name             ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
  22                           occNameFlavour, getSrcLoc, occNameString,
  23                           NameSet, emptyNameSet, addListToNameSet, nameSetToList,
  24                           mkLocalName, mkGlobalName, modAndOcc,
  25                           nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
  26                           pprOccName, isLocalName
  27                         )
  28 import TyCon            ( TyCon )
  29 import TysWiredIn       ( tupleTyCon, listTyCon, charTyCon )
  30 import FiniteMap
  31 import Unique           ( Unique, Uniquable(..), unboundKey )
  32 import UniqFM           ( listToUFM, plusUFM_C )
  33 import UniqSupply
  34 import SrcLoc           ( SrcLoc, noSrcLoc )
  35 import Outputable
  36 import Util             ( removeDups )
  37 import List             ( nub )
  38 import Char             ( isAlphanum )
  39 \end{code}
  40
  41
  42
  43 %*********************************************************
  44 %*                                                      *
  45 \subsection{Making new names}
  46 %*                                                      *
  47 %*********************************************************
  48
  49 \begin{code}
  50 newImportedGlobalName :: Module -> OccName
  51                       -> IfaceFlavour
  52                       -> RnM s d Name
  53 newImportedGlobalName mod occ hif
  54   =     -- First check the cache
  55     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  56     let
  57         key = (mod,occ)
  58         prov = NonLocalDef noSrcLoc hif False
  59     in
  60     case lookupFM cache key of
  61
  62         -- A hit in the cache!
  63         -- If it has no provenance at the moment then set its provenance
  64         -- so that it has the right HiFlag component.
  65         -- (This is necessary
  66         -- for known-key things.  For example, GHCmain.lhs imports as SOURCE
  67         -- Main; but Main.main is a known-key thing.)
  68         -- Don't fiddle with the provenance if it already has one
  69         Just name -> case getNameProvenance name of
  70                         NoProvenance -> let
  71                                           new_name = setNameProvenance name prov
  72                                           new_cache = addToFM cache key new_name
  73                                         in
  74                                         setNameSupplyRn (us, inst_ns, new_cache)        `thenRn_`
  75                                         returnRn new_name
  76                         other        -> returnRn name
  77
  78         Nothing ->      -- Miss in the cache!
  79                         -- Build a new original name, and put it in the cache
  80                    let
  81                         (us', us1) = splitUniqSupply us
  82                         uniq       = getUnique us1
  83                         name       = mkGlobalName uniq mod occ prov
  84                         new_cache  = addToFM cache key name
  85                    in
  86                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
  87                    returnRn name
  88
  89 {-
  90             let
  91               pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->"
  92                                      <+> ppr name
  93             in
  94             pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ,
  95                            brackets (sep (map pprC (fmToList cache))),
  96                            text ""
  97                           ])            $
  98 -}
  99
 100
 101 newLocallyDefinedGlobalName :: Module -> OccName
 102                             -> (Name -> ExportFlag) -> SrcLoc
 103                             -> RnM s d Name
 104 newLocallyDefinedGlobalName mod occ rec_exp_fn loc
 105   =     -- First check the cache
 106     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 107     let
 108         key = (mod,occ)
 109     in
 110     case lookupFM cache key of
 111
 112         -- A hit in the cache!
 113         -- Overwrite whatever provenance is in the cache already;
 114         -- this updates WiredIn things and known-key things,
 115         -- which are there from the start, to LocalDef.
 116         Just name -> let
 117                         new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name))
 118                         new_cache = addToFM cache key new_name
 119                      in
 120                      setNameSupplyRn (us, inst_ns, new_cache)           `thenRn_`
 121                      returnRn new_name
 122
 123         -- Miss in the cache!
 124         -- Build a new original name, and put it in the cache
 125         Nothing -> let
 126                         provenance = LocalDef loc (rec_exp_fn new_name)
 127                         (us', us1) = splitUniqSupply us
 128                         uniq       = getUnique us1
 129                         new_name   = mkGlobalName uniq mod occ provenance
 130                         new_cache  = addToFM cache key new_name
 131                    in
 132                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
 133                    returnRn new_name
 134
 135
 136 -- newDfunName is a variant, specially for dfuns.
 137 -- When renaming derived definitions we are in *interface* mode (because we can trip
 138 -- over original names), but we still want to make the Dfun locally-defined.
 139 -- So we can't use whether or not we're in source mode to decide the locally-defined question.
 140 newDfunName :: OccName -> OccName -> Maybe RdrName -> SrcLoc -> RnMS s Name
 141 newDfunName _ _ (Just n) src_loc                        -- Imported ones have "Just n"
 142   = getModuleRn         `thenRn` \ mod_name ->
 143     newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
 144 newDfunName cl_nm tycon_nm Nothing src_loc              -- Local instance decls have a "Nothing"
 145   = getModuleRn         `thenRn` \ mod_name ->
 146     newInstUniq name    `thenRn` \ inst_uniq ->
 147     let
 148      dfun_occ = VarOcc (_PK_ ("$d" ++ (_UNPK_ name) ++ show inst_uniq))
 149     in
 150     newLocallyDefinedGlobalName mod_name dfun_occ
 151                                 (\_ -> Exported) src_loc
 152    where
 153        {-
 154              Dictionary names have the following form
 155
 156                $d<class><tycon><n>
 157
 158              where "n" is a positive number, and "tycon" is the
 159              name of the type constructor for which a "class"
 160              instance is derived.
 161
 162              Prefixing dictionary names with their class and instance
 163              types improves the behaviour of the recompilation checker.
 164              (fewer recompilations required should an instance or type
 165               declaration be added to a module.)
 166       -}
 167      -- We're dropping the modids on purpose.
 168      tycon_nm_str    = occNameString tycon_nm
 169      cl_nm_str       = occNameString cl_nm
 170
 171       -- give up on any type constructor that starts with a
 172       -- non-alphanumeric char (e.g., [] (,*)
 173      name
 174       | (_NULL_ tycon_nm_str) || not (isAlphanum (_HEAD_ (tycon_nm_str))) = cl_nm_str
 175       | otherwise = cl_nm_str _APPEND_ tycon_nm_str
 176
 177
 178 newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
 179 newLocalNames rdr_names
 180   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 181     let
 182         n          = length rdr_names
 183         (us', us1) = splitUniqSupply us
 184         uniqs      = getUniques n us1
 185         locals     = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 186                      | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
 187                      ]
 188     in
 189     setNameSupplyRn (us', inst_ns, cache)       `thenRn_`
 190     returnRn locals
 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) noSrcLoc
 196
 197 isUnboundName :: Name -> Bool
 198 isUnboundName name = uniqueOf name == unboundKey
 199 \end{code}
 200
 201 \begin{code}
 202 bindLocatedLocalsRn :: SDoc                     -- Documentation string for error message
 203                     -> [(RdrName,SrcLoc)]
 204                     -> ([Name] -> RnMS s a)
 205                     -> RnMS s a
 206 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 207   = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 208
 209     getLocalNameEnv                     `thenRn` \ name_env ->
 210     (if opt_WarnNameShadowing
 211      then
 212         mapRn (check_shadow name_env) rdr_names_w_loc
 213      else
 214         returnRn []
 215     )                                   `thenRn_`
 216
 217     newLocalNames rdr_names_w_loc       `thenRn` \ names ->
 218     let
 219         new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
 220     in
 221     setLocalNameEnv new_name_env (enclosed_scope names)
 222   where
 223     check_shadow name_env (rdr_name,loc)
 224         = case lookupFM name_env rdr_name of
 225                 Nothing   -> returnRn ()
 226                 Just name -> pushSrcLocRn loc $
 227                              addWarnRn (shadowedNameWarn rdr_name)
 228
 229 bindLocalsRn doc_str rdr_names enclosed_scope
 230   = getSrcLocRn         `thenRn` \ loc ->
 231     bindLocatedLocalsRn (text doc_str)
 232                         (rdr_names `zip` repeat loc)
 233                         enclosed_scope
 234
 235 bindTyVarsRn doc_str tyvar_names enclosed_scope
 236   = getSrcLocRn                                 `thenRn` \ loc ->
 237     let
 238         located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
 239     in
 240     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 241     enclosed_scope (zipWith replaceTyVarName tyvar_names names)
 242
 243         -- Works in any variant of the renamer monad
 244 checkDupOrQualNames, checkDupNames :: SDoc
 245                                    -> [(RdrName, SrcLoc)]
 246                                    -> RnM s d ()
 247
 248 checkDupOrQualNames doc_str rdr_names_w_loc
 249   =     -- Check for use of qualified names
 250     mapRn (qualNameErr doc_str) quals   `thenRn_`
 251     checkDupNames doc_str rdr_names_w_loc
 252   where
 253     quals = filter (isQual.fst) rdr_names_w_loc
 254
 255 checkDupNames doc_str rdr_names_w_loc
 256   =     -- Check for dupicated names in a binding group
 257     mapRn (dupNamesErr doc_str) dups    `thenRn_`
 258     returnRn ()
 259   where
 260     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 261
 262
 263 -- Yuk!
 264 ifaceFlavour name = case getNameProvenance name of
 265                         NonLocalDef _ hif _ -> hif
 266                         other               -> HiFile   -- Shouldn't happen
 267 \end{code}
 268
 269
 270 %*********************************************************
 271 %*                                                      *
 272 \subsection{Looking up names}
 273 %*                                                      *
 274 %*********************************************************
 275
 276 Looking up a name in the RnEnv.
 277
 278 \begin{code}
 279 lookupRn :: RdrName
 280          -> Maybe Name          -- Result of environment lookup
 281          -> RnMS s Name
 282 lookupRn rdr_name (Just name)
 283   =     -- Found the name in the envt
 284     returnRn name       -- In interface mode the only things in
 285                         -- the environment are things in local (nested) scopes
 286 lookupRn rdr_name nm@Nothing
 287   = tryLookupRn rdr_name nm `thenRn` \ name_or_error ->
 288     case name_or_error of
 289       Left (nm,err) -> failWithRn nm err
 290       Right nm      -> returnRn nm
 291
 292 tryLookupRn :: RdrName
 293             -> Maybe Name               -- Result of environment lookup
 294             -> RnMS s (Either (Name, ErrMsg) Name)
 295 tryLookupRn rdr_name (Just name)
 296   =     -- Found the name in the envt
 297     returnRn (Right name) -- In interface mode the only things in
 298                           -- the environment are things in local (nested) scopes
 299
 300 -- lookup in environment, but don't flag an error if
 301 -- name is not found.
 302 tryLookupRn rdr_name Nothing
 303   =     -- We didn't find the name in the environment
 304     getModeRn           `thenRn` \ mode ->
 305     case mode of {
 306         SourceMode -> returnRn (Left ( mkUnboundName rdr_name
 307                                      , unknownNameErr rdr_name));
 308                 -- Source mode; lookup failure is an error
 309
 310         InterfaceMode _ _ ->
 311
 312
 313         ----------------------------------------------------
 314         -- OK, so we're in interface mode
 315         -- An Unqual is allowed; interface files contain
 316         -- unqualified names for locally-defined things, such as
 317         -- constructors of a data type.
 318         -- So, qualify the unqualified name with the
 319         -- module of the interface file, and try again
 320     case rdr_name of
 321         Unqual occ       ->
 322             getModuleRn         `thenRn` \ mod ->
 323             newImportedGlobalName mod occ HiFile `thenRn` \ nm ->
 324             returnRn (Right nm)
 325         Qual mod occ hif ->
 326             newImportedGlobalName mod occ hif `thenRn` \ nm ->
 327             returnRn (Right nm)
 328
 329     }
 330
 331 lookupBndrRn rdr_name
 332   = lookupNameRn rdr_name               `thenRn` \ maybe_name ->
 333     lookupRn rdr_name maybe_name        `thenRn` \ name ->
 334
 335     if isLocalName name then
 336         returnRn name
 337     else
 338
 339         ----------------------------------------------------
 340         -- OK, so we're at the binding site of a top-level defn
 341         -- Check to see whether its an imported decl
 342     getModeRn           `thenRn` \ mode ->
 343     case mode of {
 344           SourceMode -> returnRn name ;
 345
 346           InterfaceMode _ print_unqual_fn ->
 347
 348         ----------------------------------------------------
 349         -- OK, the binding site of an *imported* defn
 350         -- so we can make the provenance more informative
 351     getSrcLocRn         `thenRn` \ src_loc ->
 352     let
 353         name' = case getNameProvenance name of
 354                     NonLocalDef _ hif _ -> setNameProvenance name
 355                                                 (NonLocalDef src_loc hif (print_unqual_fn name'))
 356                     other               -> name
 357     in
 358     returnRn name'
 359     }
 360
 361 -- Just like lookupRn except that we record the occurrence too
 362 -- Perhaps surprisingly, even wired-in names are recorded.
 363 -- Why?  So that we know which wired-in names are referred to when
 364 -- deciding which instance declarations to import.
 365 lookupOccRn :: RdrName -> RnMS s Name
 366 lookupOccRn rdr_name
 367   = tryLookupOccRn rdr_name `thenRn` \ name_or_error ->
 368     case name_or_error of
 369       Left (nm, err) -> failWithRn nm err
 370       Right nm       -> returnRn nm
 371
 372 -- tryLookupOccRn is the fail-safe version of lookupOccRn, returning
 373 -- back the error rather than immediately flagging it. It is only
 374 -- directly used by RnExpr.rnExpr to catch and rewrite unbound
 375 -- uses of `assert'.
 376 tryLookupOccRn :: RdrName -> RnMS s (Either (Name,ErrMsg) Name)
 377 tryLookupOccRn rdr_name
 378   = lookupNameRn rdr_name               `thenRn` \ maybe_name ->
 379     tryLookupRn rdr_name maybe_name     `thenRn` \ name_or_error ->
 380     case name_or_error of
 381      Left _     -> returnRn name_or_error
 382      Right name ->
 383        let
 384         name' = mungePrintUnqual rdr_name name
 385        in
 386        addOccurrenceName name' `thenRn_`
 387        returnRn name_or_error
 388
 389
 390 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 391 -- environment only.  It's used for record field names only.
 392 lookupGlobalOccRn :: RdrName -> RnMS s Name
 393 lookupGlobalOccRn rdr_name
 394   = lookupGlobalNameRn rdr_name         `thenRn` \ maybe_name ->
 395     lookupRn rdr_name maybe_name        `thenRn` \ name ->
 396     let
 397         name' = mungePrintUnqual rdr_name name
 398     in
 399     addOccurrenceName name'
 400
 401 -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
 402 -- if they were mentioned unqualified in the source code.
 403 -- This improves error messages from the type checker.
 404 -- NB: the binding site is treated differently; see lookupBndrRn
 405 --     After the type checker all occurrences are replaced by the one
 406 --     at the binding site.
 407 mungePrintUnqual (Qual _ _ _) name = name
 408 mungePrintUnqual (Unqual _)   name = case new_prov of
 409                                         Nothing    -> name
 410                                         Just prov' -> setNameProvenance name prov'
 411                                    where
 412                                      new_prov = case getNameProvenance name of
 413                                                    NonLocalDef loc hif False -> Just (NonLocalDef loc hif True)
 414                                                    other                     -> Nothing
 415
 416 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
 417 -- adds it to the occurrence pool so that it'll be loaded later.  This is
 418 -- used when language constructs (such as monad comprehensions, overloaded literals,
 419 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
 420 -- mentioned in the code.
 421 --
 422 -- This doesn't apply in interface mode, where everything is explicit, but
 423 -- we don't check for this case: it does no harm to record an "extra" occurrence
 424 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
 425 -- Nothing clause of rnDerivs that calls it at all I think).
 426 --      [Jan 98: this comment is wrong: rnHsType uses it quite a bit.]
 427 --
 428 -- For List and Tuple types it's important to get the correct
 429 -- isLocallyDefined flag, which is used in turn when deciding
 430 -- whether there are any instance decls in this module are "special".
 431 -- The name cache should have the correct provenance, though.
 432
 433 lookupImplicitOccRn :: RdrName -> RnMS s Name
 434 lookupImplicitOccRn (Qual mod occ hif)
 435  = newImportedGlobalName mod occ hif    `thenRn` \ name ->
 436    addOccurrenceName name
 437
 438 addImplicitOccRn :: Name -> RnMS s Name
 439 addImplicitOccRn name = addOccurrenceName name
 440
 441 addImplicitOccsRn :: [Name] -> RnMS s ()
 442 addImplicitOccsRn names = addOccurrenceNames names
 443
 444 listType_RDR    = qual (modAndOcc listType_name)
 445 tupleType_RDR n = qual (modAndOcc (tupleType_name n))
 446
 447 charType_name    = getName charTyCon
 448 listType_name    = getName listTyCon
 449 tupleType_name n = getName (tupleTyCon n)
 450 \end{code}
 451
 452 \begin{code}
 453 lookupFixity :: RdrName -> RnMS s Fixity
 454 lookupFixity rdr_name
 455   = getFixityEnv        `thenRn` \ fixity_env ->
 456     returnRn (lookupFixityEnv fixity_env rdr_name)
 457 \end{code}
 458
 459 mkImportFn returns a function that takes a Name and tells whether
 460 its unqualified name is in scope.  This is put as a boolean flag in
 461 the Name's provenance to guide whether or not to print the name qualified
 462 in error messages.
 463
 464 \begin{code}
 465 mkImportFn :: RnEnv -> Name -> Bool
 466 mkImportFn (RnEnv env _)
 467   = lookup
 468   where
 469     lookup name = case lookupFM env (Unqual (nameOccName name)) of
 470                            Just (name', _) -> name == name'
 471                            Nothing         -> False
 472 \end{code}
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsection{Envt utility functions}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 ===============  RnEnv  ================
 481 \begin{code}
 482 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
 483   = plusGlobalNameEnvRn n1 n2           `thenRn` \ n ->
 484     plusFixityEnvRn f1 f2               `thenRn` \ f ->
 485     returnRn (RnEnv n f)
 486 \end{code}
 487
 488
 489 ===============  NameEnv  ================
 490 \begin{code}
 491 plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
 492 plusGlobalNameEnvRn env1 env2
 493   = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2)            `thenRn_`
 494     returnRn (env1 `plusFM` env2)
 495
 496 addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
 497 addOneToGlobalNameEnv env rdr_name name
 498  = case lookupFM env rdr_name of
 499         Just name2 | conflicting_name name name2
 500                    -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_`
 501                       returnRn env
 502
 503         other      -> returnRn (addToFM env rdr_name name)
 504
 505 delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv
 506 delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name
 507
 508 conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool
 509 conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True
 510 conflicting_name (n1,h1)               (n2,h2)               = n1 /= n2
 511         -- We complain of a conflict if one RdrName maps to two different Names,
 512         -- OR if one RdrName maps to the same *locally-defined* Name.  The latter
 513         -- case is to catch two separate, local definitions of the same thing.
 514         --
 515         -- If a module imports itself then there might be a local defn and an imported
 516         -- defn of the same name; in this case the names will compare as equal, but
 517         -- will still have different HowInScope fields
 518
 519 lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
 520 lookupNameEnv = lookupFM
 521 \end{code}
 522
 523 ===============  FixityEnv  ================
 524 \begin{code}
 525 plusFixityEnvRn f1 f2
 526   = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2)         `thenRn_`
 527     returnRn (f1 `plusFM` f2)
 528
 529 addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity
 530
 531 lookupFixityEnv env rdr_name
 532   = case lookupFM env rdr_name of
 533         Just (fixity,_) -> fixity
 534         Nothing         -> Fixity 9 InfixL              -- Default case
 535
 536 bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool
 537 bad_fix (f1,_) (f2,_) = f1 /= f2
 538
 539 pprFixityProvenance :: (Fixity, HowInScope) -> SDoc
 540 pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope
 541 \end{code}
 542
 543
 544
 545 ===============  ExportAvails  ================
 546 \begin{code}
 547 mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails
 548 mkExportAvails mod_name unqual_imp name_env avails
 549   = (mod_avail_env, entity_avail_env)
 550   where
 551     mod_avail_env = unitFM mod_name unqual_avails
 552
 553         -- unqual_avails is the Avails that are visible in *unqualfied* form
 554         -- (1.4 Report, Section 5.1.1)
 555         -- For example, in
 556         --      import T hiding( f )
 557         -- we delete f from avails
 558
 559     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 560                   | otherwise      = [prune avail | avail <- avails]
 561
 562     prune (Avail n) | unqual_in_scope n = Avail n
 563     prune (Avail n) | otherwise         = NotAvailable
 564     prune (AvailTC n ns)                = AvailTC n (filter unqual_in_scope ns)
 565
 566     unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
 567
 568     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 569                                                   name  <- availEntityNames avail]
 570
 571 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 572 plusExportAvails (m1, e1) (m2, e2)
 573   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 574 \end{code}
 575
 576
 577 ===============  AvailInfo  ================
 578 \begin{code}
 579 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 580 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 581 plusAvail a NotAvailable = a
 582 plusAvail NotAvailable a = a
 583 -- Added SOF 4/97
 584 #ifdef DEBUG
 585 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 586 #endif
 587
 588 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 589 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 590
 591 availsToNameSet :: [AvailInfo] -> NameSet
 592 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 593
 594 availName :: AvailInfo -> Name
 595 availName (Avail n)     = n
 596 availName (AvailTC n _) = n
 597
 598 availNames :: AvailInfo -> [Name]
 599 availNames NotAvailable   = []
 600 availNames (Avail n)      = [n]
 601 availNames (AvailTC n ns) = ns
 602
 603 -- availEntityNames is used to extract the names that can appear on their own in
 604 -- an export or import list.  For class decls, class methods can appear on their
 605 -- own, thus    import A( op )
 606 -- but constructors cannot; thus
 607 --              import B( T )
 608 -- means import type T from B, not constructor T.
 609
 610 availEntityNames :: AvailInfo -> [Name]
 611 availEntityNames NotAvailable   = []
 612 availEntityNames (Avail n)      = [n]
 613 availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns
 614
 615 filterAvail :: RdrNameIE        -- Wanted
 616             -> AvailInfo        -- Available
 617             -> AvailInfo        -- Resulting available;
 618                                 -- NotAvailable if wanted stuff isn't there
 619
 620 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 621   | sub_names_ok = AvailTC n (filter is_wanted ns)
 622   | otherwise    = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
 623                    NotAvailable
 624   where
 625     is_wanted name = nameOccName name `elem` wanted_occs
 626     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 627     avail_occs     = map nameOccName ns
 628     wanted_occs    = map rdrNameOcc (want:wants)
 629
 630 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 631                                                   AvailTC n [n]
 632
 633 filterAvail (IEThingAbs _) avail@(Avail n)      = avail         -- Type synonyms
 634
 635 filterAvail (IEVar _)      avail@(Avail n)      = avail
 636 filterAvail (IEVar v)      avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
 637                                                 where
 638                                                   wanted n = nameOccName n == occ
 639                                                   occ      = rdrNameOcc v
 640         -- The second equation happens if we import a class op, thus
 641         --      import A( op )
 642         -- where op is a class operation
 643
 644 filterAvail (IEThingAll _) avail@(AvailTC _ _)  = avail
 645
 646 filterAvail ie avail = NotAvailable
 647
 648
 649 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 650 pprAvail avail = getPprStyle $ \ sty ->
 651                  if ifaceStyle sty then
 652                     ppr_avail (pprOccName . nameOccName) avail
 653                  else
 654                     ppr_avail ppr avail
 655
 656 ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable")
 657 ppr_avail pp_name (AvailTC n ns) = hsep [
 658                                      pp_name n,
 659                                      parens  $ hsep $ punctuate comma $
 660                                      map pp_name ns
 661                                    ]
 662 ppr_avail pp_name (Avail n) = pp_name n
 663 \end{code}
 664
 665
 666
 667
 668 %************************************************************************
 669 %*                                                                      *
 670 \subsection{Finite map utilities}
 671 %*                                                                      *
 672 %************************************************************************
 673
 674
 675 Generally useful function on finite maps to check for overlap.
 676
 677 \begin{code}
 678 conflictsFM :: Ord a
 679             => (b->b->Bool)             -- False <=> no conflict; you can pick either
 680             -> FiniteMap a b -> FiniteMap a b
 681             -> [(a,(b,b))]
 682 conflictsFM bad fm1 fm2
 683   = filter (\(a,(b1,b2)) -> bad b1 b2)
 684            (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
 685
 686 conflictFM :: Ord a
 687            => (b->b->Bool)
 688            -> FiniteMap a b -> a -> b
 689            -> Maybe (a,(b,b))
 690 conflictFM bad fm key elt
 691   = case lookupFM fm key of
 692         Just elt' | bad elt elt' -> Just (key,(elt,elt'))
 693         other                    -> Nothing
 694 \end{code}
 695
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsection{Envt utility functions}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703
 704 \begin{code}
 705 warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d ()
 706
 707 warnUnusedBinds names
 708   | opt_WarnUnusedBinds = warnUnusedNames names
 709   | otherwise           = returnRn ()
 710
 711 warnUnusedMatches names
 712   | opt_WarnUnusedMatches = warnUnusedNames names
 713   | otherwise           = returnRn ()
 714
 715 warnUnusedImports names
 716   | opt_WarnUnusedImports = warnUnusedNames names
 717   | otherwise           = returnRn ()
 718
 719 warnUnusedNames :: NameSet -> RnM s d ()
 720 warnUnusedNames names
 721   = mapRn warn (nameSetToList names)    `thenRn_`
 722     returnRn ()
 723   where
 724     warn name = pushSrcLocRn (getSrcLoc name) $
 725                 addWarnRn (unusedNameWarn name)
 726
 727 unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
 728
 729 addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 730   | isClassDataConRdrName rdr_name
 731         -- Nasty hack to prevent error messages complain about conflicts for ":C",
 732         -- where "C" is a class.  There'll be a message about C, and :C isn't
 733         -- the programmer's business.  There may be a better way to filter this
 734         -- out, but I couldn't get up the energy to find it.
 735   = returnRn ()
 736
 737   | otherwise
 738   = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
 739               4 (vcat [ppr how_in_scope1,
 740                        ppr how_in_scope2]))
 741
 742 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 743   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 744         4 (vcat [ppr how_in_scope1,
 745                  ppr how_in_scope2])
 746
 747 shadowedNameWarn shadow
 748   = hcat [ptext SLIT("This binding for"),
 749                quotes (ppr shadow),
 750                ptext SLIT("shadows an existing binding")]
 751
 752 unknownNameErr name
 753   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 754   where
 755     flavour = occNameFlavour (rdrNameOcc name)
 756
 757 qualNameErr descriptor (name,loc)
 758   = pushSrcLocRn loc $
 759     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 760                      quotes (ppr name),
 761                      ptext SLIT("in"),
 762                      descriptor])
 763
 764 dupNamesErr descriptor ((name,loc) : dup_things)
 765   = pushSrcLocRn loc $
 766     addErrRn (hsep [ptext SLIT("Conflicting definitions for"),
 767                     quotes (ppr name),
 768                     ptext SLIT("in"), descriptor])
 769 \end{code}
 770