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