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