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