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