ghc/compiler/rename/RnEnv.lhs

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