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