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