ghc/compiler/rename/RnEnv.lhs

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