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