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