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