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