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 :: NameEnv -> RdrName -> RnMS s Name
 280 lookupRn name_env rdr_name
 281   = case lookupFM name_env rdr_name of
 282
 283         -- Found it!
 284         Just name -> returnRn name
 285
 286         -- Not found
 287         Nothing -> getModeRn    `thenRn` \ mode ->
 288                    case mode of
 289                         -- Not found when processing source code; so fail
 290                         SourceMode    -> failWithRn (mkUnboundName rdr_name)
 291                                                     (unknownNameErr rdr_name)
 292
 293                         -- Not found when processing an imported declaration,
 294                         -- so we create a new name for the purpose
 295                         InterfaceMode _ ->
 296                             case rdr_name of
 297
 298                                 Qual mod_name occ hif -> newGlobalName mod_name occ hif
 299
 300                                 -- An Unqual is allowed; interface files contain
 301                                 -- unqualified names for locally-defined things, such as
 302                                 -- constructors of a data type.
 303                                 Unqual occ -> getModuleRn       `thenRn ` \ mod_name ->
 304                                               newGlobalName mod_name occ HiFile
 305
 306
 307 lookupBndrRn rdr_name
 308   = getNameEnv                  `thenRn` \ name_env ->
 309     lookupRn name_env rdr_name
 310
 311 -- Just like lookupRn except that we record the occurrence too
 312 -- Perhaps surprisingly, even wired-in names are recorded.
 313 -- Why?  So that we know which wired-in names are referred to when
 314 -- deciding which instance declarations to import.
 315 lookupOccRn :: RdrName -> RnMS s Name
 316 lookupOccRn rdr_name
 317   = getNameEnv                  `thenRn` \ name_env ->
 318     lookupRn name_env rdr_name  `thenRn` \ name ->
 319     addOccurrenceName name
 320
 321 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 322 -- environment.  It's used for record field names only.
 323 lookupGlobalOccRn :: RdrName -> RnMS s Name
 324 lookupGlobalOccRn rdr_name
 325   = getGlobalNameEnv            `thenRn` \ name_env ->
 326     lookupRn name_env rdr_name  `thenRn` \ name ->
 327     addOccurrenceName name
 328
 329
 330 -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
 331 -- if they were mentioned unqualified in the source code.
 332 -- This improves error messages from the type checker.
 333 -- NB: the binding site is treated differently; see lookupBndrRn
 334 --     After the type checker all occurrences are replaced by the one
 335 --     at the binding site.
 336 mungePrintUnqual (Qual _ _ _) name = name
 337 mungePrintUnqual (Unqual _)   name = case new_prov of
 338                                         Nothing    -> name
 339                                         Just prov' -> setNameProvenance name prov'
 340                                    where
 341                                      new_prov = case getNameProvenance name of
 342                                                    NonLocalDef loc hif False -> Just (NonLocalDef loc hif True)
 343                                                    other                     -> Nothing
 344
 345 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
 346 -- adds it to the occurrence pool so that it'll be loaded later.  This is
 347 -- used when language constructs (such as monad comprehensions, overloaded literals,
 348 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
 349 -- mentioned in the code.
 350 --
 351 -- This doesn't apply in interface mode, where everything is explicit, but
 352 -- we don't check for this case: it does no harm to record an "extra" occurrence
 353 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
 354 -- Nothing clause of rnDerivs that calls it at all I think).
 355 --      [Jan 98: this comment is wrong: rnHsType uses it quite a bit.]
 356 --
 357 -- For List and Tuple types it's important to get the correct
 358 -- isLocallyDefined flag, which is used in turn when deciding
 359 -- whether there are any instance decls in this module are "special".
 360 -- The name cache should have the correct provenance, though.
 361
 362 lookupImplicitOccRn :: RdrName -> RnMS s Name
 363 lookupImplicitOccRn (Qual mod occ hif)
 364  = newImportedGlobalName mod occ hif    `thenRn` \ name ->
 365    addOccurrenceName name
 366
 367 addImplicitOccRn :: Name -> RnMS s Name
 368 addImplicitOccRn name = addOccurrenceName name
 369
 370 addImplicitOccsRn :: [Name] -> RnMS s ()
 371 addImplicitOccsRn names = addOccurrenceNames names
 372
 373 listType_RDR    = qual (modAndOcc listType_name)
 374 tupleType_RDR n = qual (modAndOcc (tupleType_name n))
 375
 376 charType_name    = getName charTyCon
 377 listType_name    = getName listTyCon
 378 tupleType_name n = getName (tupleTyCon n)
 379 \end{code}
 380
 381 \begin{code}
 382 lookupFixity :: RdrName -> RnMS s Fixity
 383 lookupFixity rdr_name
 384   = getFixityEnv        `thenRn` \ fixity_env ->
 385     returnRn (lookupFixityEnv fixity_env rdr_name)
 386 \end{code}
 387
 388 mkImportFn returns a function that takes a Name and tells whether
 389 its unqualified name is in scope.  This is put as a boolean flag in
 390 the Name's provenance to guide whether or not to print the name qualified
 391 in error messages.
 392
 393 \begin{code}
 394 mkImportFn :: RnEnv -> Name -> Bool
 395 mkImportFn (RnEnv env _)
 396   = lookup
 397   where
 398     lookup name = case lookupFM env (Unqual (nameOccName name)) of
 399                            Just (name', _) -> name == name'
 400                            Nothing         -> False
 401 \end{code}
 402
 403 %************************************************************************
 404 %*                                                                      *
 405 \subsection{Envt utility functions}
 406 %*                                                                      *
 407 %************************************************************************
 408
 409 ===============  RnEnv  ================
 410 \begin{code}
 411 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
 412   = plusGlobalNameEnvRn n1 n2           `thenRn` \ n ->
 413     plusFixityEnvRn f1 f2               `thenRn` \ f ->
 414     returnRn (RnEnv n f)
 415 \end{code}
 416
 417
 418 ===============  NameEnv  ================
 419 \begin{code}
 420 plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
 421 plusGlobalNameEnvRn env1 env2
 422   = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2)            `thenRn_`
 423     returnRn (env1 `plusFM` env2)
 424
 425 addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
 426 addOneToGlobalNameEnv env rdr_name name
 427  = case lookupFM env rdr_name of
 428         Just name2 | conflicting_name name name2
 429                    -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_`
 430                       returnRn env
 431
 432         other      -> returnRn (addToFM env rdr_name name)
 433
 434 delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv
 435 delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name
 436
 437 conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool
 438 conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True
 439 conflicting_name (n1,h1)               (n2,h2)               = n1 /= n2
 440         -- We complain of a conflict if one RdrName maps to two different Names,
 441         -- OR if one RdrName maps to the same *locally-defined* Name.  The latter
 442         -- case is to catch two separate, local definitions of the same thing.
 443         --
 444         -- If a module imports itself then there might be a local defn and an imported
 445         -- defn of the same name; in this case the names will compare as equal, but
 446         -- will still have different HowInScope fields
 447
 448 lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
 449 lookupNameEnv = lookupFM
 450 \end{code}
 451
 452 ===============  FixityEnv  ================
 453 \begin{code}
 454 plusFixityEnvRn f1 f2
 455   = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2)         `thenRn_`
 456     returnRn (f1 `plusFM` f2)
 457
 458 addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity
 459
 460 lookupFixityEnv env rdr_name
 461   = case lookupFM env rdr_name of
 462         Just (fixity,_) -> fixity
 463         Nothing         -> Fixity 9 InfixL              -- Default case
 464
 465 bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool
 466 bad_fix (f1,_) (f2,_) = f1 /= f2
 467
 468 pprFixityProvenance :: (Fixity, HowInScope) -> SDoc
 469 pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope
 470 \end{code}
 471
 472
 473
 474 ===============  ExportAvails  ================
 475 \begin{code}
 476 mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails
 477 mkExportAvails mod_name unqual_imp name_env avails
 478   = (mod_avail_env, entity_avail_env)
 479   where
 480     mod_avail_env = unitFM mod_name unqual_avails
 481
 482         -- unqual_avails is the Avails that are visible in *unqualfied* form
 483         -- (1.4 Report, Section 5.1.1)
 484         -- For example, in
 485         --      import T hiding( f )
 486         -- we delete f from avails
 487
 488     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 489                   | otherwise      = [prune avail | avail <- avails]
 490
 491     prune (Avail n) | unqual_in_scope n = Avail n
 492     prune (Avail n) | otherwise         = NotAvailable
 493     prune (AvailTC n ns)                = AvailTC n (filter unqual_in_scope ns)
 494
 495     unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
 496
 497     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 498                                                   name  <- availEntityNames avail]
 499
 500 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 501 plusExportAvails (m1, e1) (m2, e2)
 502   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 503 \end{code}
 504
 505
 506 ===============  AvailInfo  ================
 507 \begin{code}
 508 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 509 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 510 plusAvail a NotAvailable = a
 511 plusAvail NotAvailable a = a
 512 -- Added SOF 4/97
 513 #ifdef DEBUG
 514 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 515 #endif
 516
 517 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 518 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 519
 520 availsToNameSet :: [AvailInfo] -> NameSet
 521 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 522
 523 availName :: AvailInfo -> Name
 524 availName (Avail n)     = n
 525 availName (AvailTC n _) = n
 526
 527 availNames :: AvailInfo -> [Name]
 528 availNames NotAvailable   = []
 529 availNames (Avail n)      = [n]
 530 availNames (AvailTC n ns) = ns
 531
 532 -- availEntityNames is used to extract the names that can appear on their own in
 533 -- an export or import list.  For class decls, class methods can appear on their
 534 -- own, thus    import A( op )
 535 -- but constructors cannot; thus
 536 --              import B( T )
 537 -- means import type T from B, not constructor T.
 538
 539 availEntityNames :: AvailInfo -> [Name]
 540 availEntityNames NotAvailable   = []
 541 availEntityNames (Avail n)      = [n]
 542 availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns
 543
 544 filterAvail :: RdrNameIE        -- Wanted
 545             -> AvailInfo        -- Available
 546             -> AvailInfo        -- Resulting available;
 547                                 -- NotAvailable if wanted stuff isn't there
 548
 549 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 550   | sub_names_ok = AvailTC n (filter is_wanted ns)
 551   | otherwise    =
 552 #ifdef DEBUG
 553                    pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
 554 #endif
 555                    NotAvailable
 556   where
 557     is_wanted name = nameOccName name `elem` wanted_occs
 558     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 559     avail_occs     = map nameOccName ns
 560     wanted_occs    = map rdrNameOcc (want:wants)
 561
 562 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 563                                                   AvailTC n [n]
 564
 565 filterAvail (IEThingAbs _) avail@(Avail n)      = avail         -- Type synonyms
 566
 567 filterAvail (IEVar _)      avail@(Avail n)      = avail
 568 filterAvail (IEVar v)      avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
 569                                                 where
 570                                                   wanted n = nameOccName n == occ
 571                                                   occ      = rdrNameOcc v
 572         -- The second equation happens if we import a class op, thus
 573         --      import A( op )
 574         -- where op is a class operation
 575
 576 filterAvail (IEThingAll _) avail@(AvailTC _ _)  = avail
 577
 578 filterAvail ie avail = NotAvailable
 579
 580
 581 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 582 pprAvail avail = getPprStyle $ \ sty ->
 583                  if ifaceStyle sty then
 584                     ppr_avail (pprOccName . nameOccName) avail
 585                  else
 586                     ppr_avail ppr avail
 587
 588 ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable")
 589 ppr_avail pp_name (AvailTC n ns) = hsep [
 590                                      pp_name n,
 591                                      parens  $ hsep $ punctuate comma $
 592                                      map pp_name ns
 593                                    ]
 594 ppr_avail pp_name (Avail n) = pp_name n
 595 \end{code}
 596
 597
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection{Finite map utilities}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606
 607 Generally useful function on finite maps to check for overlap.
 608
 609 \begin{code}
 610 conflictsFM :: Ord a
 611             => (b->b->Bool)             -- False <=> no conflict; you can pick either
 612             -> FiniteMap a b -> FiniteMap a b
 613             -> [(a,(b,b))]
 614 conflictsFM bad fm1 fm2
 615   = filter (\(a,(b1,b2)) -> bad b1 b2)
 616            (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
 617
 618 conflictFM :: Ord a
 619            => (b->b->Bool)
 620            -> FiniteMap a b -> a -> b
 621            -> Maybe (a,(b,b))
 622 conflictFM bad fm key elt
 623   = case lookupFM fm key of
 624         Just elt' | bad elt elt' -> Just (key,(elt,elt'))
 625         other                    -> Nothing
 626 \end{code}
 627
 628
 629 %************************************************************************
 630 %*                                                                      *
 631 \subsection{Envt utility functions}
 632 %*                                                                      *
 633 %************************************************************************
 634
 635
 636 \begin{code}
 637 warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d ()
 638
 639 warnUnusedBinds names
 640   | opt_WarnUnusedBinds = warnUnusedNames names
 641   | otherwise           = returnRn ()
 642
 643 warnUnusedMatches names
 644   | opt_WarnUnusedMatches = warnUnusedNames names
 645   | otherwise           = returnRn ()
 646
 647 warnUnusedImports names
 648   | opt_WarnUnusedImports = warnUnusedNames names
 649   | otherwise           = returnRn ()
 650
 651 warnUnusedNames :: NameSet -> RnM s d ()
 652 warnUnusedNames names
 653   = mapRn warn (nameSetToList names)    `thenRn_`
 654     returnRn ()
 655   where
 656     warn name = pushSrcLocRn (getSrcLoc name) $
 657                 addWarnRn (unusedNameWarn name)
 658
 659 unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
 660
 661 addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 662   | isClassDataConRdrName rdr_name
 663         -- Nasty hack to prevent error messages complain about conflicts for ":C",
 664         -- where "C" is a class.  There'll be a message about C, and :C isn't
 665         -- the programmer's business.  There may be a better way to filter this
 666         -- out, but I couldn't get up the energy to find it.
 667   = returnRn ()
 668
 669   | otherwise
 670   = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
 671               4 (vcat [ppr how_in_scope1,
 672                        ppr how_in_scope2]))
 673
 674 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 675   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 676         4 (vcat [ppr how_in_scope1,
 677                  ppr how_in_scope2])
 678
 679 shadowedNameWarn shadow
 680   = hcat [ptext SLIT("This binding for"),
 681                quotes (ppr shadow),
 682                ptext SLIT("shadows an existing binding")]
 683
 684 unknownNameErr name
 685   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 686   where
 687     flavour = occNameFlavour (rdrNameOcc name)
 688
 689 qualNameErr descriptor (name,loc)
 690   = pushSrcLocRn loc $
 691     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 692                      quotes (ppr name),
 693                      ptext SLIT("in"),
 694                      descriptor])
 695
 696 dupNamesErr descriptor ((name,loc) : dup_things)
 697   = pushSrcLocRn loc $
 698     addErrRn (hsep [ptext SLIT("Conflicting definitions for"),
 699                     quotes (ppr name),
 700                     ptext SLIT("in"), descriptor])
 701 \end{code}
 702