ghc/compiler/rename/RnEnv.lhs

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