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,
  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 bindLocalNames names enclosed_scope
 326   = getLocalNameEnv             `thenRn` \ name_env ->
 327     setLocalNameEnv (addListToRdrEnv name_env pairs)
 328                     enclosed_scope
 329   where
 330     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 331
 332 -------------------------------------
 333 bindLocalRn doc rdr_name enclosed_scope
 334   = getSrcLocRn                                 `thenRn` \ loc ->
 335     bindLocatedLocalsRn doc [(rdr_name,loc)]    $ \ (n:ns) ->
 336     ASSERT( null ns )
 337     enclosed_scope n
 338
 339 bindLocalsRn doc rdr_names enclosed_scope
 340   = getSrcLocRn         `thenRn` \ loc ->
 341     bindLocatedLocalsRn doc
 342                         (rdr_names `zip` repeat loc)
 343                         enclosed_scope
 344
 345         -- binLocalsFVRn is the same as bindLocalsRn
 346         -- except that it deals with free vars
 347 bindLocalsFVRn doc rdr_names enclosed_scope
 348   = bindLocalsRn doc rdr_names          $ \ names ->
 349     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 350     returnRn (thing, delListFromNameSet fvs names)
 351
 352 -------------------------------------
 353 bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
 354 bindUVarRn = bindLocalRn
 355
 356 -------------------------------------
 357 extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 358         -- This tiresome function is used only in rnDecl on InstDecl
 359 extendTyVarEnvFVRn tyvars enclosed_scope
 360   = bindLocalNames tyvar_names enclosed_scope   `thenRn` \ (thing, fvs) ->
 361     returnRn (thing, delListFromNameSet fvs tyvar_names)
 362   where
 363     tyvar_names = hsTyVarNames tyvars
 364
 365 bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
 366               -> ([HsTyVarBndr Name] -> RnMS a)
 367               -> RnMS a
 368 bindTyVarsRn doc_str tyvar_names enclosed_scope
 369   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 370     enclosed_scope tyvars
 371
 372 -- Gruesome name: return Names as well as HsTyVars
 373 bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
 374               -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
 375               -> RnMS a
 376 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 377   = getSrcLocRn                                 `thenRn` \ loc ->
 378     let
 379         located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
 380     in
 381     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 382     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 383
 384 bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
 385               -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
 386               -> RnMS (a, FreeVars)
 387 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 388   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 389     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 390     returnRn (thing, delListFromNameSet fvs names)
 391
 392 bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
 393               -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
 394               -> RnMS (a, FreeVars)
 395 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 396   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 397     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 398     returnRn (thing, delListFromNameSet fvs names)
 399
 400
 401 -------------------------------------
 402 checkDupOrQualNames, checkDupNames :: SDoc
 403                                    -> [(RdrName, SrcLoc)]
 404                                    -> RnM d ()
 405         -- Works in any variant of the renamer monad
 406
 407 checkDupOrQualNames doc_str rdr_names_w_loc
 408   =     -- Check for use of qualified names
 409     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 410     checkDupNames doc_str rdr_names_w_loc
 411   where
 412     quals = filter (isQual.fst) rdr_names_w_loc
 413
 414 checkDupNames doc_str rdr_names_w_loc
 415   =     -- Check for duplicated names in a binding group
 416     mapRn_ (dupNamesErr doc_str) dups
 417   where
 418     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 419 \end{code}
 420
 421
 422 %*********************************************************
 423 %*                                                      *
 424 \subsection{Looking up names}
 425 %*                                                      *
 426 %*********************************************************
 427
 428 Looking up a name in the RnEnv.
 429
 430 \begin{code}
 431 lookupBndrRn rdr_name
 432   = traceRn (text "lookupBndrRn" <+> ppr rdr_name)      `thenRn_`
 433     getNameEnvs         `thenRn` \ (global_env, local_env) ->
 434
 435         -- Try local env
 436     case lookupRdrEnv local_env rdr_name of {
 437           Just name -> returnRn name ;
 438           Nothing   ->
 439
 440     getModeRn   `thenRn` \ mode ->
 441     case mode of
 442         InterfaceMode ->        -- Look in the global name cache
 443                             mkImportedGlobalFromRdrName rdr_name                `thenRn` \ n ->
 444                             traceRn (text "lookupBndrRn result:" <+> ppr n)     `thenRn_`
 445                             returnRn n
 446
 447         SourceMode    -> -- Source mode, so look up a *qualified* version
 448                          -- of the name, so that we get the right one even
 449                          -- if there are many with the same occ name
 450                          -- There must *be* a binding
 451                 getModuleRn             `thenRn` \ mod ->
 452                 case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
 453                   Just (name:rest) -> ASSERT( null rest )
 454                                       returnRn name
 455                   Nothing          -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name)
 456     }
 457
 458 -- lookupOccRn looks up an occurrence of a RdrName
 459 lookupOccRn :: RdrName -> RnMS Name
 460 lookupOccRn rdr_name
 461   = getNameEnvs                         `thenRn` \ (global_env, local_env) ->
 462     lookup_occ global_env local_env rdr_name
 463
 464 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 465 -- environment.  It's used only for
 466 --      record field names
 467 --      class op names in class and instance decls
 468 lookupGlobalOccRn :: RdrName -> RnMS Name
 469 lookupGlobalOccRn rdr_name
 470   = getNameEnvs                         `thenRn` \ (global_env, local_env) ->
 471     lookup_global_occ global_env rdr_name
 472
 473 -- lookupSigOccRn is used for type signatures and pragmas
 474 -- Is this valid?
 475 --   module A
 476 --      import M( f )
 477 --      f :: Int -> Int
 478 --      f x = x
 479 -- It's clear that the 'f' in the signature must refer to A.f
 480 -- The Haskell98 report does not stipulate this, but it will!
 481 -- So we must treat the 'f' in the signature in the same way
 482 -- as the binding occurrence of 'f', using lookupBndrRn
 483 lookupSigOccRn :: RdrName -> RnMS Name
 484 lookupSigOccRn = lookupBndrRn
 485
 486
 487 -- Look in both local and global env
 488 lookup_occ global_env local_env rdr_name
 489   = case lookupRdrEnv local_env rdr_name of
 490           Just name -> returnRn name
 491           Nothing   -> lookup_global_occ global_env rdr_name
 492
 493 -- Look in global env only
 494 lookup_global_occ global_env rdr_name
 495   = case lookupRdrEnv global_env rdr_name of
 496         Just [name]         -> returnRn name
 497         Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
 498                                returnRn name
 499         Nothing -> getModeRn    `thenRn` \ mode ->
 500                    case mode of
 501                         -- Not found when processing source code; so fail
 502                         SourceMode    -> failWithRn (mkUnboundName rdr_name)
 503                                                     (unknownNameErr rdr_name)
 504
 505                         -- Not found when processing an imported declaration,
 506                         -- so we create a new name for the purpose
 507                         InterfaceMode -> mkImportedGlobalFromRdrName rdr_name
 508 \end{code}
 509 %
 510 @lookupImplicitOccRn@ takes an RdrName representing an {\em original} name,
 511 and adds it to the occurrence pool so that it'll be loaded later.
 512 This is used when language constructs
 513 (such as monad comprehensions, overloaded literals, or deriving clauses)
 514 require some stuff to be loaded that isn't explicitly mentioned in the code.
 515
 516 This doesn't apply in interface mode, where everything is explicit,
 517 but we don't check for this case:
 518 it does no harm to record an ``extra'' occurrence
 519 and @lookupImplicitOccRn@ isn't used much in interface mode
 520 (it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think).
 521
 522   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 523
 524 For List and Tuple types it's important to get the correct
 525 @isLocallyDefined@ flag, which is used in turn when deciding
 526 whether there are any instance decls in this module are ``special''.
 527 The name cache should have the correct provenance, though.
 528
 529 \begin{code}
 530 lookupImplicitOccRn :: RdrName -> RnM d Name
 531 lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
 532
 533 lookupImplicitOccsRn :: [RdrName] -> RnM d NameSet
 534 lookupImplicitOccsRn rdr_names
 535   = mapRn lookupImplicitOccRn rdr_names `thenRn` \ names ->
 536     returnRn (mkNameSet names)
 537 \end{code}
 538
 539 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 540 its unqualified name is in scope.  This is put as a boolean flag in
 541 the @Name@'s provenance to guide whether or not to print the name qualified
 542 in error messages.
 543
 544 \begin{code}
 545 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 546 unQualInScope env
 547   = lookup
 548   where
 549     lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
 550                            Just [name'] -> name == name'
 551                            other        -> False
 552 \end{code}
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsection{Envt utility functions}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \subsubsection{NameEnv}%  ================
 561
 562 \begin{code}
 563 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 564 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 565
 566 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
 567 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 568
 569 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 570 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 571
 572 combine_globals :: [Name]       -- Old
 573                 -> [Name]       -- New
 574                 -> [Name]
 575 combine_globals ns_old ns_new   -- ns_new is often short
 576   = foldr add ns_old ns_new
 577   where
 578     add n ns | any (is_duplicate n) ns_old = map choose ns      -- Eliminate duplicates
 579              | otherwise                   = n:ns
 580              where
 581                choose m | n==m && n `hasBetterProv` m = n
 582                         | otherwise                   = m
 583
 584
 585 is_duplicate :: Name -> Name -> Bool
 586 is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
 587                    | otherwise                                  = n1 == n2
 588 \end{code}
 589 We treat two bindings of a locally-defined name as a duplicate,
 590 because they might be two separate, local defns and we want to report
 591 and error for that, {\em not} eliminate a duplicate.
 592
 593 On the other hand, if you import the same name from two different
 594 import statements, we {\em d}* want to eliminate the duplicate, not report
 595 an error.
 596
 597 If a module imports itself then there might be a local defn and an imported
 598 defn of the same name; in this case the names will compare as equal, but
 599 will still have different provenances.
 600
 601
 602
 603 \subsubsection{AvailInfo}%  ================
 604
 605 \begin{code}
 606 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 607 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 608 -- Added SOF 4/97
 609 #ifdef DEBUG
 610 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 611 #endif
 612
 613 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 614 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 615
 616 emptyAvailEnv = emptyNameEnv
 617 unitAvailEnv :: AvailInfo -> AvailEnv
 618 unitAvailEnv a = unitNameEnv (availName a) a
 619
 620 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 621 plusAvailEnv = plusNameEnv_C plusAvail
 622
 623 availEnvElts = nameEnvElts
 624
 625 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 626 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 627
 628 availsToNameSet :: [AvailInfo] -> NameSet
 629 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 630
 631 availName :: GenAvailInfo name -> name
 632 availName (Avail n)     = n
 633 availName (AvailTC n _) = n
 634
 635 availNames :: GenAvailInfo name -> [name]
 636 availNames (Avail n)      = [n]
 637 availNames (AvailTC n ns) = ns
 638
 639 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
 640 addSysAvails avail          []  = avail
 641 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
 642
 643 rdrAvailInfo :: AvailInfo -> RdrAvailInfo
 644 -- Used when building the avails we are going to put in an interface file
 645 -- We sort the components to reduce needless wobbling of interfaces
 646 rdrAvailInfo (Avail n)      = Avail   (nameOccName n)
 647 rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
 648
 649 filterAvail :: RdrNameIE        -- Wanted
 650             -> AvailInfo        -- Available
 651             -> Maybe AvailInfo  -- Resulting available;
 652                                 -- Nothing if (any of the) wanted stuff isn't there
 653
 654 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 655   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 656   | otherwise    = Nothing
 657   where
 658     is_wanted name = nameOccName name `elem` wanted_occs
 659     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 660     avail_occs     = map nameOccName ns
 661     wanted_occs    = map rdrNameOcc (want:wants)
 662
 663 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 664                                                   Just (AvailTC n [n])
 665
 666 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 667
 668 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 669 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 670                                                 where
 671                                                   wanted n = nameOccName n == occ
 672                                                   occ      = rdrNameOcc v
 673         -- The second equation happens if we import a class op, thus
 674         --      import A( op )
 675         -- where op is a class operation
 676
 677 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 678         -- We don't complain even if the IE says T(..), but
 679         -- no constrs/class ops of T are available
 680         -- Instead that's caught with a warning by the caller
 681
 682 filterAvail ie avail = Nothing
 683
 684 pprAvail :: AvailInfo -> SDoc
 685 pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
 686                                         []  -> empty
 687                                         ns' -> parens (hsep (punctuate comma (map ppr ns')))
 688
 689 pprAvail (Avail n) = ppr n
 690 \end{code}
 691
 692
 693
 694
 695 %************************************************************************
 696 %*                                                                      *
 697 \subsection{Free variable manipulation}
 698 %*                                                                      *
 699 %************************************************************************
 700
 701 \begin{code}
 702 type FreeVars   = NameSet
 703
 704 plusFV   :: FreeVars -> FreeVars -> FreeVars
 705 addOneFV :: FreeVars -> Name -> FreeVars
 706 unitFV   :: Name -> FreeVars
 707 emptyFVs :: FreeVars
 708 plusFVs  :: [FreeVars] -> FreeVars
 709
 710 isEmptyFVs = isEmptyNameSet
 711 emptyFVs   = emptyNameSet
 712 plusFVs    = unionManyNameSets
 713 plusFV     = unionNameSets
 714
 715 -- No point in adding implicitly imported names to the free-var set
 716 addOneFV s n = addOneToNameSet s n
 717 unitFV     n = unitNameSet n
 718
 719 -- A useful utility
 720 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 721                let
 722                   (ys, fvs_s) = unzip stuff
 723                in
 724                returnRn (ys, plusFVs fvs_s)
 725 \end{code}
 726
 727
 728 %************************************************************************
 729 %*                                                                      *
 730 \subsection{Envt utility functions}
 731 %*                                                                      *
 732 %************************************************************************
 733
 734
 735
 736 \begin{code}
 737 warnUnusedModules :: [ModuleName] -> RnM d ()
 738 warnUnusedModules mods
 739   | not opt_WarnUnusedImports = returnRn ()
 740   | otherwise                 = mapRn_ (addWarnRn . unused_mod) mods
 741   where
 742     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (pprModuleName m) <+>
 743                            text "is imported, but nothing from it is used",
 744                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 745                                    quotes (pprModuleName m))]
 746
 747 warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
 748 warnUnusedImports names
 749   | not opt_WarnUnusedImports
 750   = returnRn ()         -- Don't force names unless necessary
 751   | otherwise
 752   = warnUnusedBinds (const True) names
 753
 754 warnUnusedLocalBinds ns
 755   | not opt_WarnUnusedBinds = returnRn ()
 756   | otherwise               = warnUnusedBinds (const True) ns
 757
 758 warnUnusedMatches names
 759   | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
 760   | otherwise             = returnRn ()
 761
 762 -------------------------
 763
 764 warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d ()
 765 warnUnusedBinds warn_when_local names
 766   = mapRn_ (warnUnusedGroup warn_when_local) groups
 767   where
 768         -- Group by provenance
 769    groups = equivClasses cmp names
 770    name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2
 771
 772    cmp_prov (LocalDef _ _) (NonLocalDef _ _)       = LT
 773    cmp_prov (LocalDef loc1 _) (LocalDef loc2 _)    = loc1 `compare` loc2
 774    cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
 775             (NonLocalDef (UserImport m2 loc2 _) _) =
 776          (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
 777    cmp_prov (NonLocalDef _ _) (LocalDef _ _)       = GT
 778                         -- In-scope NonLocalDefs must have UserImport info on them
 779
 780 -------------------------
 781
 782 --      NOTE: the function passed to warnUnusedGroup is
 783 --      now always (const True) so we should be able to
 784 --      simplify the code slightly.  I'm leaving it there
 785 --      for now just in case I havn't realised why it was there.
 786 --      Looks highly bogus to me.  SLPJ Dec 99
 787
 788 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
 789 warnUnusedGroup emit_warning names
 790   | null filtered_names         = returnRn ()
 791   | not (emit_warning is_local) = returnRn ()
 792   | otherwise
 793   = pushSrcLocRn def_loc        $
 794     addWarnRn                   $
 795     sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
 796   where
 797     filtered_names = filter reportable names
 798     name1          = head filtered_names
 799     (is_local, def_loc, msg)
 800         = case getNameProvenance name1 of
 801                 LocalDef loc _                       -> (True, loc, text "Defined but not used")
 802                 NonLocalDef (UserImport mod loc _) _ ->
 803                  (True, loc, text "Imported from" <+> quotes (ppr mod) <+>
 804                                                       text "but not used")
 805                 other -> (False, getSrcLoc name1, text "Strangely defined but not used")
 806
 807     reportable name = case occNameUserString (nameOccName name) of
 808                         ('_' : _) -> False
 809                         zz_other  -> True
 810         -- Haskell 98 encourages compilers to suppress warnings about
 811         -- unused names in a pattern if they start with "_".
 812 \end{code}
 813
 814 \begin{code}
 815 addNameClashErrRn rdr_name (name1:names)
 816   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 817                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 818   where
 819     msg1 = ptext  SLIT("either") <+> mk_ref name1
 820     msgs = [ptext SLIT("    or") <+> mk_ref name | name <- names]
 821     mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name
 822
 823 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 824   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 825         4 (vcat [ppr how_in_scope1,
 826                  ppr how_in_scope2])
 827
 828 shadowedNameWarn shadow
 829   = hsep [ptext SLIT("This binding for"),
 830                quotes (ppr shadow),
 831                ptext SLIT("shadows an existing binding")]
 832
 833 unknownNameErr name
 834   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 835   where
 836     flavour = occNameFlavour (rdrNameOcc name)
 837
 838 qualNameErr descriptor (name,loc)
 839   = pushSrcLocRn loc $
 840     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 841                      quotes (ppr name),
 842                      ptext SLIT("in"),
 843                      descriptor])
 844
 845 dupNamesErr descriptor ((name,loc) : dup_things)
 846   = pushSrcLocRn loc $
 847     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 848               $$
 849               (ptext SLIT("in") <+> descriptor))
 850 \end{code}