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