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