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, ieOcc, isQual, qual
  16                         )
  17 import HsTypes          ( getTyVarName, replaceTyVarName )
  18 import BasicTypes       ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule )
  19 import RnMonad
  20 import Name             ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
  21                           occNameString, occNameFlavour, getSrcLoc,
  22                           NameSet, emptyNameSet, addListToNameSet, nameSetToList,
  23                           mkLocalName, mkGlobalName, modAndOcc,
  24                           nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
  25                           pprProvenance, pprOccName, pprModule, pprNameProvenance,
  26                           isLocalName
  27                         )
  28 import TyCon            ( TyCon )
  29 import TysWiredIn       ( tupleTyCon, listTyCon, charTyCon, intTyCon )
  30 import FiniteMap
  31 import Unique           ( Unique, Uniquable(..), unboundKey )
  32 import UniqFM           ( listToUFM, plusUFM_C )
  33 import Maybes           ( maybeToBool )
  34 import UniqSupply
  35 import SrcLoc           ( SrcLoc, noSrcLoc )
  36 import Outputable
  37 import Util             ( removeDups )
  38 import List             ( nub )
  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 :: Maybe RdrName -> SrcLoc -> RnMS s Name
 141 newDfunName Nothing src_loc                     -- Local instance decls have a "Nothing"
 142   = getModuleRn         `thenRn` \ mod_name ->
 143     newInstUniq         `thenRn` \ inst_uniq ->
 144     let
 145         dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq))
 146     in
 147     newLocallyDefinedGlobalName mod_name dfun_occ
 148                                 (\_ -> Exported) src_loc
 149
 150 newDfunName (Just n) src_loc                    -- Imported ones have "Just n"
 151   = getModuleRn         `thenRn` \ mod_name ->
 152     newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
 153
 154
 155 newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
 156 newLocalNames rdr_names
 157   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 158     let
 159         n          = length rdr_names
 160         (us', us1) = splitUniqSupply us
 161         uniqs      = getUniques n us1
 162         locals     = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 163                      | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
 164                      ]
 165     in
 166     setNameSupplyRn (us', inst_ns, cache)       `thenRn_`
 167     returnRn locals
 168
 169 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
 170 -- during compiler debugging.
 171 mkUnboundName :: RdrName -> Name
 172 mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
 173
 174 isUnboundName :: Name -> Bool
 175 isUnboundName name = uniqueOf name == unboundKey
 176 \end{code}
 177
 178 \begin{code}
 179 bindLocatedLocalsRn :: SDoc                     -- Documentation string for error message
 180                     -> [(RdrName,SrcLoc)]
 181                     -> ([Name] -> RnMS s a)
 182                     -> RnMS s a
 183 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 184   = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 185
 186     getLocalNameEnv                     `thenRn` \ name_env ->
 187     (if opt_WarnNameShadowing
 188      then
 189         mapRn (check_shadow name_env) rdr_names_w_loc
 190      else
 191         returnRn []
 192     )                                   `thenRn_`
 193
 194     newLocalNames rdr_names_w_loc       `thenRn` \ names ->
 195     let
 196         new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
 197     in
 198     setLocalNameEnv new_name_env (enclosed_scope names)
 199   where
 200     check_shadow name_env (rdr_name,loc)
 201         = case lookupFM name_env rdr_name of
 202                 Nothing   -> returnRn ()
 203                 Just name -> pushSrcLocRn loc $
 204                              addWarnRn (shadowedNameWarn rdr_name)
 205
 206 bindLocalsRn doc_str rdr_names enclosed_scope
 207   = getSrcLocRn         `thenRn` \ loc ->
 208     bindLocatedLocalsRn (text doc_str)
 209                         (rdr_names `zip` repeat loc)
 210                         enclosed_scope
 211
 212 bindTyVarsRn doc_str tyvar_names enclosed_scope
 213   = getSrcLocRn                                 `thenRn` \ loc ->
 214     let
 215         located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
 216     in
 217     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 218     enclosed_scope (zipWith replaceTyVarName tyvar_names names)
 219
 220         -- Works in any variant of the renamer monad
 221 checkDupOrQualNames, checkDupNames :: SDoc
 222                                    -> [(RdrName, SrcLoc)]
 223                                    -> RnM s d ()
 224
 225 checkDupOrQualNames doc_str rdr_names_w_loc
 226   =     -- Check for use of qualified names
 227     mapRn (qualNameErr doc_str) quals   `thenRn_`
 228     checkDupNames doc_str rdr_names_w_loc
 229   where
 230     quals = filter (isQual.fst) rdr_names_w_loc
 231
 232 checkDupNames doc_str rdr_names_w_loc
 233   =     -- Check for dupicated names in a binding group
 234     mapRn (dupNamesErr doc_str) dups    `thenRn_`
 235     returnRn ()
 236   where
 237     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 238
 239
 240 -- Yuk!
 241 ifaceFlavour name = case getNameProvenance name of
 242                         NonLocalDef _ hif _ -> hif
 243                         other               -> HiFile   -- Shouldn't happen
 244 \end{code}
 245
 246
 247 %*********************************************************
 248 %*                                                      *
 249 \subsection{Looking up names}
 250 %*                                                      *
 251 %*********************************************************
 252
 253 Looking up a name in the RnEnv.
 254
 255 \begin{code}
 256 lookupRn :: RdrName
 257          -> Maybe Name          -- Result of environment lookup
 258          -> RnMS s Name
 259
 260 lookupRn rdr_name (Just name)
 261   =     -- Found the name in the envt
 262     returnRn name       -- In interface mode the only things in
 263                         -- the environment are things in local (nested) scopes
 264
 265 lookupRn rdr_name Nothing
 266   =     -- We didn't find the name in the environment
 267     getModeRn           `thenRn` \ mode ->
 268     case mode of {
 269         SourceMode -> failWithRn (mkUnboundName rdr_name)
 270                                  (unknownNameErr rdr_name) ;
 271                 -- Souurce mode; lookup failure is an error
 272
 273         InterfaceMode _ _ ->
 274
 275
 276         ----------------------------------------------------
 277         -- OK, so we're in interface mode
 278         -- An Unqual is allowed; interface files contain
 279         -- unqualified names for locally-defined things, such as
 280         -- constructors of a data type.
 281         -- So, qualify the unqualified name with the
 282         -- module of the interface file, and try again
 283     case rdr_name of
 284         Unqual occ       -> getModuleRn         `thenRn` \ mod ->
 285                             newImportedGlobalName mod occ HiFile
 286         Qual mod occ hif -> newImportedGlobalName mod occ hif
 287
 288     }
 289
 290 lookupBndrRn rdr_name
 291   = lookupNameRn rdr_name               `thenRn` \ maybe_name ->
 292     lookupRn rdr_name maybe_name        `thenRn` \ name ->
 293
 294     if isLocalName name then
 295         returnRn name
 296     else
 297
 298         ----------------------------------------------------
 299         -- OK, so we're at the binding site of a top-level defn
 300         -- Check to see whether its an imported decl
 301     getModeRn           `thenRn` \ mode ->
 302     case mode of {
 303           SourceMode -> returnRn name ;
 304
 305           InterfaceMode _ print_unqual_fn ->
 306
 307         ----------------------------------------------------
 308         -- OK, the binding site of an *imported* defn
 309         -- so we can make the provenance more informative
 310     getSrcLocRn         `thenRn` \ src_loc ->
 311     let
 312         name' = case getNameProvenance name of
 313                     NonLocalDef _ hif _ -> setNameProvenance name
 314                                                 (NonLocalDef src_loc hif (print_unqual_fn name'))
 315                     other               -> name
 316     in
 317     returnRn name'
 318     }
 319
 320 -- Just like lookupRn except that we record the occurrence too
 321 -- Perhaps surprisingly, even wired-in names are recorded.
 322 -- Why?  So that we know which wired-in names are referred to when
 323 -- deciding which instance declarations to import.
 324 lookupOccRn :: RdrName -> RnMS s Name
 325 lookupOccRn rdr_name
 326   = lookupNameRn rdr_name               `thenRn` \ maybe_name ->
 327     lookupRn rdr_name maybe_name        `thenRn` \ name ->
 328     let
 329         name' = mungePrintUnqual rdr_name name
 330     in
 331     addOccurrenceName name'
 332
 333 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 334 -- environment only.  It's used for record field names only.
 335 lookupGlobalOccRn :: RdrName -> RnMS s Name
 336 lookupGlobalOccRn rdr_name
 337   = lookupGlobalNameRn rdr_name         `thenRn` \ maybe_name ->
 338     lookupRn rdr_name maybe_name        `thenRn` \ name ->
 339     let
 340         name' = mungePrintUnqual rdr_name name
 341     in
 342     addOccurrenceName name'
 343
 344 -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
 345 -- if they were mentioned unqualified in the source code.
 346 -- This improves error messages from the type checker.
 347 -- NB: the binding site is treated differently; see lookupBndrRn
 348 --     After the type checker all occurrences are replaced by the one
 349 --     at the binding site.
 350 mungePrintUnqual (Qual _ _ _) name = name
 351 mungePrintUnqual (Unqual _)   name = case new_prov of
 352                                         Nothing    -> name
 353                                         Just prov' -> setNameProvenance name prov'
 354                                    where
 355                                      new_prov = case getNameProvenance name of
 356                                                    NonLocalDef loc hif False -> Just (NonLocalDef loc hif True)
 357                                                    other                     -> Nothing
 358
 359 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
 360 -- adds it to the occurrence pool so that it'll be loaded later.  This is
 361 -- used when language constructs (such as monad comprehensions, overloaded literals,
 362 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
 363 -- mentioned in the code.
 364 --
 365 -- This doesn't apply in interface mode, where everything is explicit, but
 366 -- we don't check for this case: it does no harm to record an "extra" occurrence
 367 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
 368 -- Nothing clause of rnDerivs that calls it at all I think).
 369 --      [Jan 98: this comment is wrong: rnHsType uses it quite a bit.]
 370 --
 371 -- For List and Tuple types it's important to get the correct
 372 -- isLocallyDefined flag, which is used in turn when deciding
 373 -- whether there are any instance decls in this module are "special".
 374 -- The name cache should have the correct provenance, though.
 375
 376 lookupImplicitOccRn :: RdrName -> RnMS s Name
 377 lookupImplicitOccRn (Qual mod occ hif)
 378  = newImportedGlobalName mod occ hif    `thenRn` \ name ->
 379    addOccurrenceName name
 380
 381 addImplicitOccRn :: Name -> RnMS s Name
 382 addImplicitOccRn name = addOccurrenceName name
 383
 384 addImplicitOccsRn :: [Name] -> RnMS s ()
 385 addImplicitOccsRn names = addOccurrenceNames names
 386
 387 listType_RDR    = qual (modAndOcc listType_name)
 388 tupleType_RDR n = qual (modAndOcc (tupleType_name n))
 389
 390 charType_name    = getName charTyCon
 391 listType_name    = getName listTyCon
 392 tupleType_name n = getName (tupleTyCon n)
 393 \end{code}
 394
 395 \begin{code}
 396 lookupFixity :: RdrName -> RnMS s Fixity
 397 lookupFixity rdr_name
 398   = getFixityEnv        `thenRn` \ fixity_env ->
 399     returnRn (lookupFixityEnv fixity_env rdr_name)
 400 \end{code}
 401
 402 mkImportFn returns a function that takes a Name and tells whether
 403 its unqualified name is in scope.  This is put as a boolean flag in
 404 the Name's provenance to guide whether or not to print the name qualified
 405 in error messages.
 406
 407 \begin{code}
 408 mkImportFn :: RnEnv -> Name -> Bool
 409 mkImportFn (RnEnv env _)
 410   = lookup
 411   where
 412     lookup name = case lookupFM env (Unqual (nameOccName name)) of
 413                            Just (name', _) -> name == name'
 414                            Nothing         -> False
 415 \end{code}
 416
 417 %************************************************************************
 418 %*                                                                      *
 419 \subsection{Envt utility functions}
 420 %*                                                                      *
 421 %************************************************************************
 422
 423 ===============  RnEnv  ================
 424 \begin{code}
 425 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
 426   = plusGlobalNameEnvRn n1 n2           `thenRn` \ n ->
 427     plusFixityEnvRn f1 f2               `thenRn` \ f ->
 428     returnRn (RnEnv n f)
 429 \end{code}
 430
 431
 432 ===============  NameEnv  ================
 433 \begin{code}
 434 plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
 435 plusGlobalNameEnvRn env1 env2
 436   = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2)              `thenRn_`
 437     returnRn (env1 `plusFM` env2)
 438
 439 addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
 440 addOneToGlobalNameEnv env rdr_name name
 441  = case lookupFM env rdr_name of
 442         Just name2 | conflicting_name name name2
 443                    -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
 444                       returnRn env
 445
 446         other      -> returnRn (addToFM env rdr_name name)
 447
 448 delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv
 449 delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name
 450
 451 conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool
 452 conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True
 453 conflicting_name (n1,h1)               (n2,h2)               = n1 /= n2
 454         -- We complain of a conflict if one RdrName maps to two different Names,
 455         -- OR if one RdrName maps to the same *locally-defined* Name.  The latter
 456         -- case is to catch two separate, local definitions of the same thing.
 457         --
 458         -- If a module imports itself then there might be a local defn and an imported
 459         -- defn of the same name; in this case the names will compare as equal, but
 460         -- will still have different HowInScope fields
 461
 462 lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
 463 lookupNameEnv = lookupFM
 464 \end{code}
 465
 466 ===============  FixityEnv  ================
 467 \begin{code}
 468 plusFixityEnvRn f1 f2
 469   = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2)         `thenRn_`
 470     returnRn (f1 `plusFM` f2)
 471
 472 addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity
 473
 474 lookupFixityEnv env rdr_name
 475   = case lookupFM env rdr_name of
 476         Just (fixity,_) -> fixity
 477         Nothing         -> Fixity 9 InfixL              -- Default case
 478
 479 bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool
 480 bad_fix (f1,_) (f2,_) = f1 /= f2
 481
 482 pprFixityProvenance :: (Fixity, HowInScope) -> SDoc
 483 pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope
 484 \end{code}
 485
 486
 487
 488 ===============  ExportAvails  ================
 489 \begin{code}
 490 mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails
 491 mkExportAvails mod_name unqual_imp name_env avails
 492   = (mod_avail_env, entity_avail_env)
 493   where
 494     mod_avail_env = unitFM mod_name unqual_avails
 495
 496         -- unqual_avails is the Avails that are visible in *unqualfied* form
 497         -- (1.4 Report, Section 5.1.1)
 498         -- For example, in
 499         --      import T hiding( f )
 500         -- we delete f from avails
 501
 502     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 503                   | otherwise      = [prune avail | avail <- avails]
 504
 505     prune (Avail n) | unqual_in_scope n = Avail n
 506     prune (Avail n) | otherwise         = NotAvailable
 507     prune (AvailTC n ns)                = AvailTC n (filter unqual_in_scope ns)
 508
 509     unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
 510
 511     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 512                                                   name  <- availEntityNames avail]
 513
 514 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 515 plusExportAvails (m1, e1) (m2, e2)
 516   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 517 \end{code}
 518
 519
 520 ===============  AvailInfo  ================
 521 \begin{code}
 522 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 523 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 524 plusAvail a NotAvailable = a
 525 plusAvail NotAvailable a = a
 526 -- Added SOF 4/97
 527 #ifdef DEBUG
 528 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 529 #endif
 530
 531 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 532 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 533
 534 availsToNameSet :: [AvailInfo] -> NameSet
 535 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 536
 537 availName :: AvailInfo -> Name
 538 availName (Avail n)     = n
 539 availName (AvailTC n _) = n
 540
 541 availNames :: AvailInfo -> [Name]
 542 availNames NotAvailable   = []
 543 availNames (Avail n)      = [n]
 544 availNames (AvailTC n ns) = ns
 545
 546 -- availEntityNames is used to extract the names that can appear on their own in
 547 -- an export or import list.  For class decls, class methods can appear on their
 548 -- own, thus    import A( op )
 549 -- but constructors cannot; thus
 550 --              import B( T )
 551 -- means import type T from B, not constructor T.
 552
 553 availEntityNames :: AvailInfo -> [Name]
 554 availEntityNames NotAvailable   = []
 555 availEntityNames (Avail n)      = [n]
 556 availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns
 557
 558 filterAvail :: RdrNameIE        -- Wanted
 559             -> AvailInfo        -- Available
 560             -> AvailInfo        -- Resulting available;
 561                                 -- NotAvailable if wanted stuff isn't there
 562
 563 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 564   | sub_names_ok = AvailTC n (filter is_wanted ns)
 565   | otherwise    = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
 566                    NotAvailable
 567   where
 568     is_wanted name = nameOccName name `elem` wanted_occs
 569     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 570     avail_occs     = map nameOccName ns
 571     wanted_occs    = map rdrNameOcc (want:wants)
 572
 573 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 574                                                   AvailTC n [n]
 575
 576 filterAvail (IEThingAbs _) avail@(Avail n)      = avail         -- Type synonyms
 577
 578 filterAvail (IEVar _)      avail@(Avail n)      = avail
 579 filterAvail (IEVar v)      avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
 580                                                 where
 581                                                   wanted n = nameOccName n == occ
 582                                                   occ      = rdrNameOcc v
 583         -- The second equation happens if we import a class op, thus
 584         --      import A( op )
 585         -- where op is a class operation
 586
 587 filterAvail (IEThingAll _) avail@(AvailTC _ _)  = avail
 588
 589 filterAvail ie avail = NotAvailable
 590
 591
 592 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 593 pprAvail avail = getPprStyle $ \ sty ->
 594                  if ifaceStyle sty then
 595                     ppr_avail (pprOccName . nameOccName) avail
 596                  else
 597                     ppr_avail ppr avail
 598
 599 ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable")
 600 ppr_avail pp_name (AvailTC n ns) = hsep [
 601                                      pp_name n,
 602                                      parens  $ hsep $ punctuate comma $
 603                                      map pp_name ns
 604                                    ]
 605 ppr_avail pp_name (Avail n) = pp_name n
 606 \end{code}
 607
 608
 609
 610
 611 %************************************************************************
 612 %*                                                                      *
 613 \subsection{Finite map utilities}
 614 %*                                                                      *
 615 %************************************************************************
 616
 617
 618 Generally useful function on finite maps to check for overlap.
 619
 620 \begin{code}
 621 conflictsFM :: Ord a
 622             => (b->b->Bool)             -- False <=> no conflict; you can pick either
 623             -> FiniteMap a b -> FiniteMap a b
 624             -> [(a,(b,b))]
 625 conflictsFM bad fm1 fm2
 626   = filter (\(a,(b1,b2)) -> bad b1 b2)
 627            (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
 628
 629 conflictFM :: Ord a
 630            => (b->b->Bool)
 631            -> FiniteMap a b -> a -> b
 632            -> Maybe (a,(b,b))
 633 conflictFM bad fm key elt
 634   = case lookupFM fm key of
 635         Just elt' | bad elt elt' -> Just (key,(elt,elt'))
 636         other                    -> Nothing
 637 \end{code}
 638
 639
 640 %************************************************************************
 641 %*                                                                      *
 642 \subsection{Envt utility functions}
 643 %*                                                                      *
 644 %************************************************************************
 645
 646
 647 \begin{code}
 648 warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d ()
 649
 650 warnUnusedBinds names
 651   | opt_WarnUnusedBinds = warnUnusedNames names
 652   | otherwise           = returnRn ()
 653
 654 warnUnusedMatches names
 655   | opt_WarnUnusedMatches = warnUnusedNames names
 656   | otherwise           = returnRn ()
 657
 658 warnUnusedImports names
 659   | opt_WarnUnusedImports = warnUnusedNames names
 660   | otherwise           = returnRn ()
 661
 662 warnUnusedNames :: NameSet -> RnM s d ()
 663 warnUnusedNames names
 664   = mapRn warn (nameSetToList names)    `thenRn_`
 665     returnRn ()
 666   where
 667     warn name = pushSrcLocRn (getSrcLoc name) $
 668                 addWarnRn (unusedNameWarn name)
 669
 670 unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
 671
 672 nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 673   = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
 674         4 (vcat [ppr how_in_scope1,
 675                  ppr how_in_scope2])
 676
 677 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 678   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 679         4 (vcat [ppr how_in_scope1,
 680                  ppr how_in_scope2])
 681
 682 shadowedNameWarn shadow
 683   = hcat [ptext SLIT("This binding for"),
 684                quotes (ppr shadow),
 685                ptext SLIT("shadows an existing binding")]
 686
 687 unknownNameErr name
 688   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 689   where
 690     flavour = occNameFlavour (rdrNameOcc name)
 691
 692 qualNameErr descriptor (name,loc)
 693   = pushSrcLocRn loc $
 694     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 695                      quotes (ppr name),
 696                      ptext SLIT("in"),
 697                      descriptor])
 698
 699 dupNamesErr descriptor ((name,loc) : dup_things)
 700   = pushSrcLocRn loc $
 701     addErrRn (hsep [ptext SLIT("Conflicting definitions for"),
 702                     quotes (ppr name),
 703                     ptext SLIT("in"), descriptor])
 704 \end{code}
 705