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