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