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