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