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