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