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