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