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         ( RdrNameIE )
  15 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, mkRdrUnqual, qualifyRdrName )
  16 import HsTypes          ( getTyVarName, replaceTyVarName )
  17 import BasicTypes       ( Fixity(..), FixityDirection(..) )
  18 import RnMonad
  19 import Name             ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
  20                           ImportReason(..), getSrcLoc,
  21                           mkLocalName, mkGlobalName, isSystemName,
  22                           nameOccName, nameModule, setNameModule,
  23                           pprOccName, isLocallyDefined, nameUnique, nameOccName,
  24                           setNameProvenance, getNameProvenance, pprNameProvenance
  25                         )
  26 import NameSet
  27 import OccName          ( OccName,
  28                           mkDFunOcc,
  29                           occNameFlavour
  30                         )
  31 import Module           ( moduleIfaceFlavour )
  32 import TyCon            ( TyCon )
  33 import FiniteMap
  34 import Unique           ( Unique, Uniquable(..), unboundKey )
  35 import UniqFM           ( emptyUFM, listToUFM, plusUFM_C )
  36 import UniqSupply
  37 import SrcLoc           ( SrcLoc, noSrcLoc )
  38 import Outputable
  39 import Util             ( removeDups, equivClasses, thenCmp )
  40 import List             ( nub )
  41 import Maybes           ( mapMaybe )
  42 \end{code}
  43
  44
  45
  46 %*********************************************************
  47 %*                                                      *
  48 \subsection{Making new names}
  49 %*                                                      *
  50 %*********************************************************
  51
  52 \begin{code}
  53 newImportedGlobalName :: Module -> OccName -> RnM s d Name
  54 newImportedGlobalName mod occ
  55   =     -- First check the cache
  56     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  57     let
  58         key     = (mod,occ)
  59     in
  60     case lookupFM cache key of
  61
  62         -- A hit in the cache!
  63         -- Make sure that the module in the name has the same IfaceFlavour as
  64         -- the module we are looking for; if not, make it so
  65         -- so that it has the right HiFlag component.
  66         -- (This is necessary for known-key things.
  67         --      For example, GHCmain.lhs imports as SOURCE
  68         --      Main; but Main.main is a known-key thing.)
  69         Just name | isSystemName name   -- A known-key name; fix the provenance and module
  70                   -> getOmitQualFn                      `thenRn` \ omit_fn ->
  71                      let
  72                           new_name = setNameProvenance (setNameModule name mod)
  73                                                        (NonLocalDef ImplicitImport (omit_fn name))
  74                           new_cache = addToFM cache key new_name
  75                      in
  76                      setNameSupplyRn (us, inst_ns, new_cache)   `thenRn_`
  77                      returnRn new_name
  78
  79                   | otherwise
  80                   -> returnRn name
  81
  82         Nothing ->      -- Miss in the cache!
  83                         -- Build a new original name, and put it in the cache
  84                    getOmitQualFn                        `thenRn` \ omit_fn ->
  85                    setModuleFlavourRn mod               `thenRn` \ mod' ->
  86                    let
  87                         (us', us1) = splitUniqSupply us
  88                         uniq       = uniqFromSupply us1
  89                         name       = mkGlobalName uniq mod' occ (NonLocalDef ImplicitImport (omit_fn name))
  90                                         -- For in-scope things we improve the provenance
  91                                         -- in RnNames.importsFromImportDecl
  92                         new_cache  = addToFM cache key name
  93                    in
  94                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
  95                    returnRn name
  96
  97
  98 newImportedGlobalFromRdrName rdr_name
  99   | isQual rdr_name
 100   = newImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 101
 102   | otherwise
 103   =     -- An Unqual is allowed; interface files contain
 104         -- unqualified names for locally-defined things, such as
 105         -- constructors of a data type.
 106     getModuleRn         `thenRn ` \ mod_name ->
 107     newImportedGlobalName mod_name (rdrNameOcc rdr_name)
 108
 109
 110 newLocallyDefinedGlobalName :: Module -> OccName
 111                             -> (Name -> ExportFlag) -> SrcLoc
 112                             -> RnM s d Name
 113 newLocallyDefinedGlobalName mod occ rec_exp_fn loc
 114   =     -- First check the cache
 115     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 116     let
 117         key          = (mod,occ)
 118         mk_prov name = LocalDef loc (rec_exp_fn name)
 119         -- We must set the provenance of the thing in the cache
 120         -- correctly, particularly whether or not it is locally defined.
 121         --
 122         -- Since newLocallyDefinedGlobalName is used only
 123         -- at binding occurrences, we may as well get the provenance
 124         -- dead right first time; hence the rec_exp_fn passed in
 125     in
 126     case lookupFM cache key of
 127
 128         -- A hit in the cache!
 129         -- Overwrite whatever provenance is in the cache already;
 130         -- this updates WiredIn things and known-key things,
 131         -- which are there from the start, to LocalDef.
 132         --
 133         -- It also means that if there are two defns for the same thing
 134         -- in a module, then each gets a separate SrcLoc
 135         Just name -> let
 136                         new_name = setNameProvenance name (mk_prov new_name)
 137                         new_cache = addToFM cache key new_name
 138                      in
 139                      setNameSupplyRn (us, inst_ns, new_cache)           `thenRn_`
 140                      returnRn new_name
 141
 142         -- Miss in the cache!
 143         -- Build a new original name, and put it in the cache
 144         Nothing -> let
 145                         (us', us1) = splitUniqSupply us
 146                         uniq       = uniqFromSupply us1
 147                         new_name   = mkGlobalName uniq mod occ (mk_prov new_name)
 148                         new_cache  = addToFM cache key new_name
 149                    in
 150                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
 151                    returnRn new_name
 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      = uniqsFromSupply 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 newDFunName cl_occ tycon_occ (Just n) src_loc           -- Imported ones have "Just n"
 169   = newImportedGlobalFromRdrName n
 170
 171 newDFunName cl_occ tycon_occ Nothing src_loc            -- Local instance decls have a "Nothing"
 172   = getModuleRn                         `thenRn` \ mod_name ->
 173     newInstUniq (cl_occ, tycon_occ)     `thenRn` \ inst_uniq ->
 174     let
 175         dfun_occ = mkDFunOcc cl_occ tycon_occ inst_uniq
 176     in
 177     newLocallyDefinedGlobalName mod_name dfun_occ (\_ -> Exported) src_loc
 178
 179
 180 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
 181 -- during compiler debugging.
 182 mkUnboundName :: RdrName -> Name
 183 mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
 184
 185 isUnboundName :: Name -> Bool
 186 isUnboundName name = getUnique name == unboundKey
 187 \end{code}
 188
 189 \begin{code}
 190 -------------------------------------
 191 bindLocatedLocalsRn :: SDoc                     -- Documentation string for error message
 192                     -> [(RdrName,SrcLoc)]
 193                     -> ([Name] -> RnMS s a)
 194                     -> RnMS s a
 195 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 196   = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 197
 198     getLocalNameEnv                     `thenRn` \ name_env ->
 199     (if opt_WarnNameShadowing
 200      then
 201         mapRn_ (check_shadow name_env) rdr_names_w_loc
 202      else
 203         returnRn ()
 204     )                                   `thenRn_`
 205
 206     newLocalNames rdr_names_w_loc       `thenRn` \ names ->
 207     let
 208         new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 209     in
 210     setLocalNameEnv new_name_env (enclosed_scope names)
 211   where
 212     check_shadow name_env (rdr_name,loc)
 213         = case lookupRdrEnv name_env rdr_name of
 214                 Nothing   -> returnRn ()
 215                 Just name -> pushSrcLocRn loc $
 216                              addWarnRn (shadowedNameWarn rdr_name)
 217
 218
 219 -------------------------------------
 220 bindLocalsRn doc_str rdr_names enclosed_scope
 221   = getSrcLocRn         `thenRn` \ loc ->
 222     bindLocatedLocalsRn (text doc_str)
 223                         (rdr_names `zip` repeat loc)
 224                         enclosed_scope
 225
 226         -- binLocalsFVRn is the same as bindLocalsRn
 227         -- except that it deals with free vars
 228 bindLocalsFVRn doc_str rdr_names enclosed_scope
 229   = bindLocalsRn doc_str rdr_names      $ \ names ->
 230     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 231     returnRn (thing, delListFromNameSet fvs names)
 232
 233 -------------------------------------
 234 extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS s (a, FreeVars) -> RnMS s (a, FreeVars)
 235         -- This tiresome function is used only in rnDecl on InstDecl
 236 extendTyVarEnvFVRn tyvars enclosed_scope
 237   = getLocalNameEnv             `thenRn` \ env ->
 238     let
 239         tyvar_names = map getTyVarName tyvars
 240         new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name)
 241                                       | name <- tyvar_names
 242                                       ]
 243     in
 244     setLocalNameEnv new_env enclosed_scope      `thenRn` \ (thing, fvs) ->
 245     returnRn (thing, delListFromNameSet fvs tyvar_names)
 246
 247 bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
 248               -> ([HsTyVar Name] -> RnMS s a)
 249               -> RnMS s a
 250 bindTyVarsRn doc_str tyvar_names enclosed_scope
 251   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 252     enclosed_scope tyvars
 253
 254 -- Gruesome name: return Names as well as HsTyVars
 255 bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
 256               -> ([Name] -> [HsTyVar Name] -> RnMS s a)
 257               -> RnMS s a
 258 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 259   = getSrcLocRn                                 `thenRn` \ loc ->
 260     let
 261         located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
 262     in
 263     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 264     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 265
 266 bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
 267               -> ([HsTyVar Name] -> RnMS s (a, FreeVars))
 268               -> RnMS s (a, FreeVars)
 269 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 270   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 271     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 272     returnRn (thing, delListFromNameSet fvs names)
 273
 274 bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
 275               -> ([Name] -> [HsTyVar Name] -> RnMS s (a, FreeVars))
 276               -> RnMS s (a, FreeVars)
 277 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 278   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 279     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 280     returnRn (thing, delListFromNameSet fvs names)
 281
 282
 283 -------------------------------------
 284 checkDupOrQualNames, checkDupNames :: SDoc
 285                                    -> [(RdrName, SrcLoc)]
 286                                    -> RnM s d ()
 287         -- Works in any variant of the renamer monad
 288
 289 checkDupOrQualNames doc_str rdr_names_w_loc
 290   =     -- Check for use of qualified names
 291     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 292     checkDupNames doc_str rdr_names_w_loc
 293   where
 294     quals = filter (isQual.fst) rdr_names_w_loc
 295
 296 checkDupNames doc_str rdr_names_w_loc
 297   =     -- Check for duplicated names in a binding group
 298     mapRn_ (dupNamesErr doc_str) dups
 299   where
 300     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 301 \end{code}
 302
 303
 304 %*********************************************************
 305 %*                                                      *
 306 \subsection{Looking up names}
 307 %*                                                      *
 308 %*********************************************************
 309
 310 Looking up a name in the RnEnv.
 311
 312 \begin{code}
 313 lookupBndrRn rdr_name
 314   = getNameEnvs         `thenRn` \ (global_env, local_env) ->
 315
 316         -- Try local env
 317     case lookupRdrEnv local_env rdr_name of {
 318           Just name -> returnRn name ;
 319           Nothing   ->
 320
 321     getModeRn   `thenRn` \ mode ->
 322     case mode of
 323         InterfaceMode _ ->      -- Look in the global name cache
 324                             newImportedGlobalFromRdrName rdr_name
 325
 326         SourceMode      ->      -- Source mode, so look up a *qualified* version
 327                                 -- of the name, so that we get the right one even
 328                                 -- if there are many with the same occ name
 329                                 -- There must *be* a binding
 330                             getModuleRn         `thenRn` \ mod ->
 331                             case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
 332                                 Just (name:rest) -> ASSERT( null rest )
 333                                                     returnRn name
 334                                 Nothing          -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_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   = getNameEnvs                                 `thenRn` \ (global_env, local_env) ->
 344     lookup_occ global_env local_env rdr_name    `thenRn` \ name ->
 345     addOccurrenceName name
 346
 347 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 348 -- environment.  It's used only for
 349 --      record field names
 350 --      class op names in class and instance decls
 351 lookupGlobalOccRn :: RdrName -> RnMS s Name
 352 lookupGlobalOccRn rdr_name
 353   = getNameEnvs                                 `thenRn` \ (global_env, local_env) ->
 354     lookup_global_occ global_env rdr_name       `thenRn` \ name ->
 355     addOccurrenceName name
 356
 357 -- Look in both local and global env
 358 lookup_occ global_env local_env rdr_name
 359   = case lookupRdrEnv local_env rdr_name of
 360           Just name -> returnRn name
 361           Nothing   -> lookup_global_occ global_env rdr_name
 362
 363 -- Look in global env only
 364 lookup_global_occ global_env rdr_name
 365   = case lookupRdrEnv global_env rdr_name of
 366         Just [name]         -> returnRn name
 367         Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
 368                                returnRn name
 369         Nothing -> getModeRn    `thenRn` \ mode ->
 370                    case mode of
 371                         -- Not found when processing source code; so fail
 372                         SourceMode    -> failUnboundNameErrRn rdr_name
 373
 374                         -- Not found when processing an imported declaration,
 375                         -- so we create a new name for the purpose
 376                         InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name
 377
 378
 379 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
 380 -- adds it to the occurrence pool so that it'll be loaded later.  This is
 381 -- used when language constructs (such as monad comprehensions, overloaded literals,
 382 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
 383 -- mentioned in the code.
 384 --
 385 -- This doesn't apply in interface mode, where everything is explicit, but
 386 -- we don't check for this case: it does no harm to record an "extra" occurrence
 387 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
 388 -- Nothing clause of rnDerivs that calls it at all I think).
 389 --      [Jan 98: this comment is wrong: rnHsType uses it quite a bit.]
 390 --
 391 -- For List and Tuple types it's important to get the correct
 392 -- isLocallyDefined flag, which is used in turn when deciding
 393 -- whether there are any instance decls in this module are "special".
 394 -- The name cache should have the correct provenance, though.
 395
 396 lookupImplicitOccRn :: RdrName -> RnMS s Name
 397 lookupImplicitOccRn rdr_name
 398  = newImportedGlobalFromRdrName rdr_name        `thenRn` \ name ->
 399    addOccurrenceName name
 400
 401 addImplicitOccRn :: Name -> RnMS s Name
 402 addImplicitOccRn name = addOccurrenceName name
 403
 404 addImplicitOccsRn :: [Name] -> RnMS s ()
 405 addImplicitOccsRn names = addOccurrenceNames names
 406 \end{code}
 407
 408 \begin{code}
 409 lookupFixity :: Name -> RnMS s Fixity
 410 lookupFixity name
 411   = getFixityEnv        `thenRn` \ fixity_env ->
 412     case lookupNameEnv fixity_env name of
 413         Just (FixitySig _ fixity _) -> returnRn fixity
 414         Nothing                     -> returnRn (Fixity 9 InfixL)       -- Default case
 415 \end{code}
 416
 417 unQualInScope returns a function that takes a Name and tells whether
 418 its unqualified name is in scope.  This is put as a boolean flag in
 419 the Name's provenance to guide whether or not to print the name qualified
 420 in error messages.
 421
 422 \begin{code}
 423 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 424 unQualInScope env
 425   = lookup
 426   where
 427     lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
 428                            Just [name'] -> name == name'
 429                            other        -> False
 430 \end{code}
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsection{Envt utility functions}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 ===============  RnEnv  ================
 439 \begin{code}
 440 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
 441   = RnEnv (n1 `plusGlobalRdrEnv` n2)
 442           (f1 `plusNameEnv`     f2)
 443 \end{code}
 444
 445
 446 ===============  NameEnv  ================
 447 \begin{code}
 448 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 449 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 450
 451 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
 452 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 453
 454 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 455 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 456
 457 combine_globals :: [Name]       -- Old
 458                 -> [Name]       -- New
 459                 -> [Name]
 460 combine_globals ns_old ns_new   -- ns_new is often short
 461   = foldr add ns_old ns_new
 462   where
 463     add n ns | any (is_duplicate n) ns_old = map choose ns      -- Eliminate duplicates
 464              | otherwise                   = n:ns
 465              where
 466                choose n' | n==n' && better_provenance n n' = n
 467                          | otherwise                       = n'
 468
 469 -- Choose
 470 --      a local thing                 over an   imported thing
 471 --      a user-imported thing         over a    non-user-imported thing
 472 --      an explicitly-imported thing  over an   implicitly imported thing
 473 better_provenance n1 n2
 474   = case (getNameProvenance n1, getNameProvenance n2) of
 475         (LocalDef _ _,                        _                           ) -> True
 476         (NonLocalDef (UserImport _ _ True) _, _                           ) -> True
 477         (NonLocalDef (UserImport _ _ _   ) _, NonLocalDef ImplicitImport _) -> True
 478         other                                                               -> False
 479
 480 is_duplicate :: Name -> Name -> Bool
 481 is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
 482                    | otherwise                                  = n1 == n2
 483         -- We treat two bindings of a locally-defined name as a duplicate,
 484         -- because they might be two separate, local defns and we want to report
 485         -- and error for that, *not* eliminate a duplicate.
 486
 487         -- On the other hand, if you import the same name from two different
 488         -- import statements, we *do* want to eliminate the duplicate, not report
 489         -- an error.
 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 provenances
 494 \end{code}
 495
 496
 497
 498 ===============  ExportAvails  ================
 499 \begin{code}
 500 mkEmptyExportAvails :: Module -> ExportAvails
 501 mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
 502
 503 mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
 504 mkExportAvails mod_name unqual_imp name_env avails
 505   = (mod_avail_env, entity_avail_env)
 506   where
 507     mod_avail_env = unitFM mod_name unqual_avails
 508
 509         -- unqual_avails is the Avails that are visible in *unqualfied* form
 510         -- (1.4 Report, Section 5.1.1)
 511         -- For example, in
 512         --      import T hiding( f )
 513         -- we delete f from avails
 514
 515     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 516                   | otherwise      = mapMaybe prune avails
 517
 518     prune (Avail n) | unqual_in_scope n = Just (Avail n)
 519     prune (Avail n) | otherwise         = Nothing
 520     prune (AvailTC n ns) | null uqs     = Nothing
 521                          | otherwise    = Just (AvailTC n uqs)
 522                          where
 523                            uqs = filter unqual_in_scope ns
 524
 525     unqual_in_scope n = unQualInScope name_env n
 526
 527     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 528                                                   name  <- availNames avail]
 529
 530 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 531 plusExportAvails (m1, e1) (m2, e2)
 532   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 533         -- ToDo: wasteful: we do this once for each constructor!
 534 \end{code}
 535
 536
 537 ===============  AvailInfo  ================
 538 \begin{code}
 539 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 540 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 541 -- Added SOF 4/97
 542 #ifdef DEBUG
 543 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 544 #endif
 545
 546 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 547 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 548
 549 availsToNameSet :: [AvailInfo] -> NameSet
 550 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 551
 552 availName :: AvailInfo -> Name
 553 availName (Avail n)     = n
 554 availName (AvailTC n _) = n
 555
 556 availNames :: AvailInfo -> [Name]
 557 availNames (Avail n)      = [n]
 558 availNames (AvailTC n ns) = ns
 559
 560 filterAvail :: RdrNameIE        -- Wanted
 561             -> AvailInfo        -- Available
 562             -> Maybe AvailInfo  -- Resulting available;
 563                                 -- Nothing if (any of the) wanted stuff isn't there
 564
 565 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 566   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 567   | otherwise    = Nothing
 568   where
 569     is_wanted name = nameOccName name `elem` wanted_occs
 570     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 571     avail_occs     = map nameOccName ns
 572     wanted_occs    = map rdrNameOcc (want:wants)
 573
 574 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 575                                                   Just (AvailTC n [n])
 576
 577 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 578
 579 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 580 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 581                                                 where
 582                                                   wanted n = nameOccName n == occ
 583                                                   occ      = rdrNameOcc v
 584         -- The second equation happens if we import a class op, thus
 585         --      import A( op )
 586         -- where op is a class operation
 587
 588 filterAvail (IEThingAll _) avail@(AvailTC _ _)  = Just avail
 589
 590 filterAvail ie avail = Nothing
 591
 592
 593 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 594 pprAvail avail = getPprStyle $ \ sty ->
 595                  if ifaceStyle sty then
 596                     ppr_avail (pprOccName . nameOccName) avail
 597                  else
 598                     ppr_avail ppr avail
 599
 600 ppr_avail pp_name (AvailTC n ns) = hsep [
 601                                      pp_name n,
 602                                      parens  $ hsep $ punctuate comma $
 603                                      map pp_name ns
 604                                    ]
 605 ppr_avail pp_name (Avail n) = pp_name n
 606 \end{code}
 607
 608
 609
 610
 611 %************************************************************************
 612 %*                                                                      *
 613 \subsection{Free variable manipulation}
 614 %*                                                                      *
 615 %************************************************************************
 616
 617 \begin{code}
 618 type FreeVars   = NameSet
 619
 620 plusFV   :: FreeVars -> FreeVars -> FreeVars
 621 addOneFV :: FreeVars -> Name -> FreeVars
 622 unitFV   :: Name -> FreeVars
 623 emptyFVs :: FreeVars
 624 plusFVs  :: [FreeVars] -> FreeVars
 625
 626 emptyFVs  = emptyNameSet
 627 plusFVs   = unionManyNameSets
 628 plusFV    = unionNameSets
 629
 630 -- No point in adding implicitly imported names to the free-var set
 631 addOneFV s n = addOneToNameSet s n
 632 unitFV     n = unitNameSet n
 633 \end{code}
 634
 635
 636 %************************************************************************
 637 %*                                                                      *
 638 \subsection{Envt utility functions}
 639 %*                                                                      *
 640 %************************************************************************
 641
 642
 643 \begin{code}
 644 warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM s d ()
 645
 646 warnUnusedTopNames names
 647   | not opt_WarnUnusedBinds && not opt_WarnUnusedImports = returnRn ()  -- Don't force ns unless necessary
 648   | otherwise                                            = warnUnusedBinds (\ is_local -> not is_local) names
 649
 650 warnUnusedLocalBinds ns
 651   | not opt_WarnUnusedBinds = returnRn ()
 652   | otherwise               = warnUnusedBinds (\ is_local -> is_local) ns
 653
 654 warnUnusedMatches names
 655   | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
 656   | otherwise             = returnRn ()
 657
 658 -------------------------
 659
 660 warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM s d ()
 661 warnUnusedBinds warn_when_local names
 662   = mapRn_ (warnUnusedGroup warn_when_local) groups
 663   where
 664         -- Group by provenance
 665    groups = equivClasses cmp names
 666    name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2
 667
 668    cmp_prov (LocalDef _ _) (NonLocalDef _ _)       = LT
 669    cmp_prov (LocalDef loc1 _) (LocalDef loc2 _)    = loc1 `compare` loc2
 670    cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
 671             (NonLocalDef (UserImport m2 loc2 _) _) = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
 672    cmp_prov (NonLocalDef _ _) (LocalDef _ _)       = GT
 673                         -- In-scope NonLocalDefs must have UserImport info on them
 674
 675 -------------------------
 676
 677 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM s d ()
 678 warnUnusedGroup _ []
 679   = returnRn ()
 680
 681 warnUnusedGroup emit_warning names
 682   | not (emit_warning is_local) = returnRn ()
 683   | otherwise
 684   = pushSrcLocRn def_loc        $
 685     addWarnRn                   $
 686     sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr names)))]
 687   where
 688     name1 = head names
 689     (is_local, def_loc, msg)
 690         = case getNameProvenance name1 of
 691                 LocalDef loc _                       -> (True, loc, text "Defined but not used")
 692                 NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+>
 693                                                                      text "but not used")
 694                 other -> (False, getSrcLoc name1, text "Strangely defined but not used")
 695 \end{code}
 696
 697 \begin{code}
 698 addNameClashErrRn rdr_name (name1:names)
 699   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 700                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 701   where
 702     msg1 = ptext  SLIT("either") <+> mk_ref name1
 703     msgs = [ptext SLIT("    or") <+> mk_ref name | name <- names]
 704     mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name
 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 failUnboundNameErrRn :: RdrName -> RnM s d Name
 712 failUnboundNameErrRn rdr_name =
 713     failWithRn (mkUnboundName rdr_name)
 714                (unknownNameErr rdr_name)
 715
 716 shadowedNameWarn shadow
 717   = hsep [ptext SLIT("This binding for"),
 718                quotes (ppr shadow),
 719                ptext SLIT("shadows an existing binding")]
 720
 721 unknownNameErr name
 722   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 723   where
 724     flavour = occNameFlavour (rdrNameOcc name)
 725
 726 qualNameErr descriptor (name,loc)
 727   = pushSrcLocRn loc $
 728     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 729                      quotes (ppr name),
 730                      ptext SLIT("in"),
 731                      descriptor])
 732
 733 dupNamesErr descriptor ((name,loc) : dup_things)
 734   = pushSrcLocRn loc $
 735     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 736               $$
 737               (ptext SLIT("in") <+> descriptor))
 738 \end{code}
 739