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