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 RnHsSyn          ( RenamedHsDecl )
  16 import RdrHsSyn         ( RdrNameIE )
  17 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
  18                           mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
  19                         )
  20 import HsTypes          ( hsTyVarName, replaceTyVarName )
  21 import HscTypes         ( Provenance(..), pprNameProvenance, hasBetterProv,
  22                           ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
  23                           AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
  24                           Deprecations(..), lookupDeprec
  25                         )
  26 import RnMonad
  27 import Name             ( Name,
  28                           getSrcLoc,
  29                           mkLocalName, mkGlobalName,
  30                           mkIPName, nameOccName, nameModule_maybe,
  31                           setNameModuleAndLoc, mkNameEnv
  32                         )
  33 import Name             ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
  34 import NameSet
  35 import OccName          ( OccName, occNameUserString, occNameFlavour )
  36 import Module           ( ModuleName, moduleName, mkVanillaModule,
  37                           mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
  38 import TysWiredIn       ( unitTyCon, intTyCon, boolTyCon, integerTyCon )
  39 import Type             ( funTyCon )
  40 import PrelNames        ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap,
  41                           derivingOccurrences,
  42                           mAIN_Name, pREL_MAIN_Name,
  43                           ioTyConName, printName,
  44                           unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
  45                           eqStringName
  46                         )
  47 import FiniteMap
  48 import UniqSupply
  49 import SrcLoc           ( SrcLoc, noSrcLoc )
  50 import Outputable
  51 import ListSetOps       ( removeDups, equivClasses )
  52 import Util             ( sortLt )
  53 import List             ( nub )
  54 import UniqFM           ( lookupWithDefaultUFM )
  55 import Maybes           ( orElse )
  56 import CmdLineOpts
  57 import FastString       ( FastString )
  58 \end{code}
  59
  60 %*********************************************************
  61 %*                                                      *
  62 \subsection{Making new names}
  63 %*                                                      *
  64 %*********************************************************
  65
  66 \begin{code}
  67 newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
  68         -- newTopBinder puts into the cache the binder with the
  69         -- module information set correctly.  When the decl is later renamed,
  70         -- the binding site will thereby get the correct module.
  71         -- There maybe occurrences that don't have the correct Module, but
  72         -- by the typechecker will propagate the binding definition to all
  73         -- the occurrences, so that doesn't matter
  74
  75 newTopBinder mod rdr_name loc
  76   =     -- First check the cache
  77
  78         -- There should never be a qualified name in a binding position (except in instance decls)
  79         -- The parser doesn't check this because the same parser parses instance decls
  80     (if isQual rdr_name then
  81         qualNameErr (text "its declaration") (rdr_name,loc)
  82      else
  83         returnRn ()
  84     )                           `thenRn_`
  85
  86     getNameSupplyRn             `thenRn` \ name_supply ->
  87     let
  88         occ = rdrNameOcc rdr_name
  89         key = (moduleName mod, occ)
  90         cache = nsNames name_supply
  91     in
  92     case lookupFM cache key of
  93
  94         -- A hit in the cache!  We are at the binding site of the name, and
  95         -- this is the moment when we know all about
  96         --      a) the Name's host Module (in particular, which
  97         --         package it comes from)
  98         --      b) its defining SrcLoc
  99         -- So we update this info
 100
 101         Just name -> let
 102                         new_name  = setNameModuleAndLoc name mod loc
 103                         new_cache = addToFM cache key new_name
 104                      in
 105                      setNameSupplyRn (name_supply {nsNames = new_cache})        `thenRn_`
 106 --                   traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
 107                      returnRn new_name
 108
 109         -- Miss in the cache!
 110         -- Build a completely new Name, and put it in the cache
 111         -- Even for locally-defined names we use implicitImportProvenance;
 112         -- updateProvenances will set it to rights
 113         Nothing -> let
 114                         (us', us1) = splitUniqSupply (nsUniqs name_supply)
 115                         uniq       = uniqFromSupply us1
 116                         new_name   = mkGlobalName uniq mod occ loc
 117                         new_cache  = addToFM cache key new_name
 118                    in
 119                    setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache})   `thenRn_`
 120 --                 traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
 121                    returnRn new_name
 122
 123
 124 newGlobalName :: ModuleName -> OccName -> RnM d Name
 125   -- Used for *occurrences*.  We make a place-holder Name, really just
 126   -- to agree on its unique, which gets overwritten when we read in
 127   -- the binding occurence later (newTopBinder)
 128   -- The place-holder Name doesn't have the right SrcLoc, and its
 129   -- Module won't have the right Package either.
 130   --
 131   -- (We have to pass a ModuleName, not a Module, because we may be
 132   -- simply looking at an occurrence M.x in an interface file.)
 133   --
 134   -- This means that a renamed program may have incorrect info
 135   -- on implicitly-imported occurrences, but the correct info on the
 136   -- *binding* declaration. It's the type checker that propagates the
 137   -- correct information to all the occurrences.
 138   -- Since implicitly-imported names never occur in error messages,
 139   -- it doesn't matter that we get the correct info in place till later,
 140   -- (but since it affects DLL-ery it does matter that we get it right
 141   --  in the end).
 142 newGlobalName mod_name occ
 143   = getNameSupplyRn             `thenRn` \ name_supply ->
 144     let
 145         key = (mod_name, occ)
 146         cache = nsNames name_supply
 147     in
 148     case lookupFM cache key of
 149         Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
 150                      returnRn name
 151
 152         Nothing   -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache})  `thenRn_`
 153                      -- traceRn (text "newGlobalName: new" <+> ppr name)                  `thenRn_`
 154                      returnRn name
 155                   where
 156                      (us', us1) = splitUniqSupply (nsUniqs name_supply)
 157                      uniq       = uniqFromSupply us1
 158                      mod        = mkVanillaModule mod_name
 159                      name       = mkGlobalName uniq mod occ noSrcLoc
 160                      new_cache  = addToFM cache key name
 161
 162 newIPName rdr_name
 163   = getNameSupplyRn             `thenRn` \ name_supply ->
 164     let
 165         ipcache = nsIPs name_supply
 166     in
 167     case lookupFM ipcache key of
 168         Just name -> returnRn name
 169         Nothing   -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
 170                      returnRn name
 171                   where
 172                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 173                      uniq        = uniqFromSupply us1
 174                      name        = mkIPName uniq key
 175                      new_ipcache = addToFM ipcache key name
 176     where key = (rdrNameOcc rdr_name)
 177 \end{code}
 178
 179 %*********************************************************
 180 %*                                                      *
 181 \subsection{Looking up names}
 182 %*                                                      *
 183 %*********************************************************
 184
 185 Looking up a name in the RnEnv.
 186
 187 \begin{code}
 188 lookupBndrRn rdr_name
 189   = getLocalNameEnv             `thenRn` \ local_env ->
 190     case lookupRdrEnv local_env rdr_name of
 191           Just name -> returnRn name
 192           Nothing   -> lookupTopBndrRn rdr_name
 193
 194 lookupTopBndrRn rdr_name
 195   = getModeRn   `thenRn` \ mode ->
 196     if isInterfaceMode mode
 197         then lookupIfaceName rdr_name
 198         else     -- Source mode, so look up a *qualified* version
 199                  -- of the name, so that we get the right one even
 200                  -- if there are many with the same occ name
 201                  -- There must *be* a binding
 202                 getModuleRn             `thenRn` \ mod ->
 203                 getGlobalNameEnv        `thenRn` \ global_env ->
 204                 lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
 205
 206 -- lookupSigOccRn is used for type signatures and pragmas
 207 -- Is this valid?
 208 --   module A
 209 --      import M( f )
 210 --      f :: Int -> Int
 211 --      f x = x
 212 -- It's clear that the 'f' in the signature must refer to A.f
 213 -- The Haskell98 report does not stipulate this, but it will!
 214 -- So we must treat the 'f' in the signature in the same way
 215 -- as the binding occurrence of 'f', using lookupBndrRn
 216 lookupSigOccRn :: RdrName -> RnMS Name
 217 lookupSigOccRn = lookupBndrRn
 218
 219 -- lookupOccRn looks up an occurrence of a RdrName
 220 lookupOccRn :: RdrName -> RnMS Name
 221 lookupOccRn rdr_name
 222   = getLocalNameEnv                     `thenRn` \ local_env ->
 223     case lookupRdrEnv local_env rdr_name of
 224           Just name -> returnRn name
 225           Nothing   -> lookupGlobalOccRn rdr_name
 226
 227 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 228 -- environment.  It's used only for
 229 --      record field names
 230 --      class op names in class and instance decls
 231
 232 lookupGlobalOccRn rdr_name
 233   = getModeRn           `thenRn` \ mode ->
 234     if (isInterfaceMode mode)
 235         then lookupIfaceName rdr_name
 236         else
 237
 238     getGlobalNameEnv    `thenRn` \ global_env ->
 239     case mode of
 240         SourceMode -> lookupSrcName global_env rdr_name
 241
 242         CmdLineMode
 243          | not (isQual rdr_name) ->
 244                 lookupSrcName global_env rdr_name
 245
 246                 -- We allow qualified names on the command line to refer to
 247                 -- *any* name exported by any module in scope, just as if
 248                 -- there was an "import qualified M" declaration for every
 249                 -- module.
 250                 --
 251                 -- First look up the name in the normal environment.  If
 252                 -- it isn't there, we manufacture a new occurrence of an
 253                 -- original name.
 254          | otherwise ->
 255                 case lookupRdrEnv global_env rdr_name of
 256                        Just _  -> lookupSrcName global_env rdr_name
 257                        Nothing -> lookupQualifiedName rdr_name
 258
 259 -- a qualified name on the command line can refer to any module at all: we
 260 -- try to load the interface if we don't already have it.
 261 lookupQualifiedName :: RdrName -> RnM d Name
 262 lookupQualifiedName rdr_name
 263  = let
 264        mod = rdrNameModule rdr_name
 265        occ = rdrNameOcc rdr_name
 266    in
 267    loadInterface (ppr rdr_name) mod ImportBySystem `thenRn` \ iface ->
 268    case  [ name | (_,avails) <- mi_exports iface,
 269            avail             <- avails,
 270            name              <- availNames avail,
 271            nameOccName name == occ ] of
 272       (n:ns) -> ASSERT (null ns) returnRn n
 273       _      -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name)
 274
 275 lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
 276 -- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
 277 lookupSrcName global_env rdr_name
 278   | isOrig rdr_name     -- Can occur in source code too
 279   = lookupOrigName rdr_name
 280
 281   | otherwise
 282   = case lookupRdrEnv global_env rdr_name of
 283         Just [GRE name _ Nothing]       -> returnRn name
 284         Just [GRE name _ (Just deprec)] -> warnDeprec name deprec       `thenRn_`
 285                                            returnRn name
 286         Just stuff@(GRE name _ _ : _)   -> addNameClashErrRn rdr_name stuff     `thenRn_`
 287                                            returnRn name
 288         Nothing                         -> failWithRn (mkUnboundName rdr_name)
 289                                                       (unknownNameErr rdr_name)
 290
 291 lookupOrigName :: RdrName -> RnM d Name
 292 lookupOrigName rdr_name
 293   = ASSERT( isOrig rdr_name )
 294     newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 295
 296 lookupIfaceUnqual :: RdrName -> RnM d Name
 297 lookupIfaceUnqual rdr_name
 298   = ASSERT( isUnqual rdr_name )
 299         -- An Unqual is allowed; interface files contain
 300         -- unqualified names for locally-defined things, such as
 301         -- constructors of a data type.
 302     getModuleRn                         `thenRn ` \ mod ->
 303     newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
 304
 305 lookupIfaceName :: RdrName -> RnM d Name
 306 lookupIfaceName rdr_name
 307   | isUnqual rdr_name = lookupIfaceUnqual rdr_name
 308   | otherwise         = lookupOrigName rdr_name
 309 \end{code}
 310
 311 @lookupOrigName@ takes an RdrName representing an {\em original}
 312 name, and adds it to the occurrence pool so that it'll be loaded
 313 later.  This is used when language constructs (such as monad
 314 comprehensions, overloaded literals, or deriving clauses) require some
 315 stuff to be loaded that isn't explicitly mentioned in the code.
 316
 317 This doesn't apply in interface mode, where everything is explicit,
 318 but we don't check for this case: it does no harm to record an
 319 ``extra'' occurrence and @lookupOrigNames@ isn't used much in
 320 interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
 321 calls it at all I think).
 322
 323   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 324
 325 \begin{code}
 326 lookupOrigNames :: [RdrName] -> RnM d NameSet
 327 lookupOrigNames rdr_names
 328   = mapRn lookupOrigName rdr_names      `thenRn` \ names ->
 329     returnRn (mkNameSet names)
 330 \end{code}
 331
 332 lookupSysBinder is used for the "system binders" of a type, class, or
 333 instance decl.  It ensures that the module is set correctly in the
 334 name cache, and sets the provenance on the returned name too.  The
 335 returned name will end up actually in the type, class, or instance.
 336
 337 \begin{code}
 338 lookupSysBinder rdr_name
 339   = ASSERT( isUnqual rdr_name )
 340     getModuleRn                         `thenRn` \ mod ->
 341     getSrcLocRn                         `thenRn` \ loc ->
 342     newTopBinder mod rdr_name loc
 343 \end{code}
 344
 345
 346 %*********************************************************
 347 %*                                                      *
 348 \subsection{Implicit free vars and sugar names}
 349 %*                                                      *
 350 %*********************************************************
 351
 352 @addImplicitFVs@ forces the renamer to slurp in some things which aren't
 353 mentioned explicitly, but which might be needed by the type checker.
 354
 355 \begin{code}
 356 addImplicitFVs :: GlobalRdrEnv
 357                -> Maybe (ModuleName, [RenamedHsDecl])   -- Nothing when compling an expression
 358                -> FreeVars                              -- Free in the source
 359                -> RnMG (FreeVars, SyntaxMap)            -- Augmented source free vars
 360
 361 addImplicitFVs gbl_env maybe_mod source_fvs
 362   =     -- Find out what re-bindable names to use for desugaring
 363      rnSyntaxNames gbl_env source_fvs           `thenRn` \ (source_fvs1, sugar_map) ->
 364
 365         -- Find implicit FVs thade
 366     extra_implicits maybe_mod           `thenRn` \ extra_fvs ->
 367
 368     let
 369         implicit_fvs = ubiquitousNames `plusFV` extra_fvs
 370         slurp_fvs    = implicit_fvs `plusFV` source_fvs1
 371                 -- It's important to do the "plus" this way round, so that
 372                 -- when compiling the prelude, locally-defined (), Bool, etc
 373                 -- override the implicit ones.
 374     in
 375     returnRn (slurp_fvs, sugar_map)
 376
 377   where
 378     extra_implicits Nothing             -- Compiling an expression
 379       = returnRn (unitFV printName)     -- print :: a -> IO () may be needed later
 380
 381     extra_implicits (Just (mod_name, decls))    -- Compiling a module
 382       = lookupOrigNames deriv_occs              `thenRn` \ deriving_names ->
 383         returnRn (deriving_names `plusFV` implicit_main)
 384       where
 385         -- Add occurrences for IO or PrimIO
 386         implicit_main |  mod_name == mAIN_Name
 387                       || mod_name == pREL_MAIN_Name = unitFV ioTyConName
 388                       |  otherwise                  = emptyFVs
 389
 390         deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
 391                             cls <- deriv_classes,
 392                             occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
 393
 394 -- ubiquitous_names are loaded regardless, because
 395 -- they are needed in virtually every program
 396 ubiquitousNames
 397   = mkFVs [unpackCStringName, unpackCStringFoldrName,
 398            unpackCStringUtf8Name, eqStringName]
 399         -- Virtually every program has error messages in it somewhere
 400
 401   `plusFV`
 402     mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon, integerTyCon])
 403         -- Add occurrences for Integer, and (), because they
 404         -- are the types to which ambigious type variables may be defaulted by
 405         -- the type checker; so they won't always appear explicitly.
 406         -- [The () one is a GHC extension for defaulting CCall results.]
 407         -- ALSO: funTyCon, since it occurs implicitly everywhere!
 408         --       (we don't want to be bothered with making funTyCon a
 409         --        free var at every function application!)
 410         -- Double is dealt with separately in getGates
 411 \end{code}
 412
 413 \begin{code}
 414 rnSyntaxNames :: GlobalRdrEnv -> FreeVars -> RnMG (FreeVars, SyntaxMap)
 415 -- Look up the re-bindable syntactic sugar names
 416 -- Any errors arising from these lookups may surprise the
 417 -- programmer, since they aren't explicitly mentioned, and
 418 -- the src line will be unhelpful (ToDo)
 419
 420 rnSyntaxNames gbl_env source_fvs
 421   = doptRn Opt_NoImplicitPrelude        `thenRn` \ no_prelude ->
 422     if not no_prelude then
 423         returnRn (source_fvs, vanillaSyntaxMap)
 424     else
 425
 426         -- There's a -fno-implicit-prelude flag,
 427         -- so build the re-mapping function
 428     let
 429         reqd_syntax_list = filter is_reqd syntaxList
 430         is_reqd (n,_)    = n `elemNameSet` source_fvs
 431         lookup (n,rn)    = lookupSrcName gbl_env rn     `thenRn` \ rn' ->
 432                            returnRn (n,rn')
 433     in
 434     mapRn lookup reqd_syntax_list       `thenRn` \ rn_syntax_list ->
 435     let
 436         -- Delete the proxies and add the actuals
 437         proxies = map fst rn_syntax_list
 438         actuals = map snd rn_syntax_list
 439         new_source_fvs = (proxies `delFVs` source_fvs) `plusFV` mkFVs actuals
 440
 441         syntax_env   = mkNameEnv rn_syntax_list
 442         syntax_map n = lookupNameEnv syntax_env n `orElse` n
 443     in
 444     returnRn (new_source_fvs, syntax_map)
 445 \end{code}
 446
 447
 448 %*********************************************************
 449 %*                                                      *
 450 \subsection{Binding}
 451 %*                                                      *
 452 %*********************************************************
 453
 454 \begin{code}
 455 newLocalsRn :: [(RdrName,SrcLoc)]
 456             -> RnMS [Name]
 457 newLocalsRn rdr_names_w_loc
 458  =  getNameSupplyRn             `thenRn` \ name_supply ->
 459     let
 460         n          = length rdr_names_w_loc
 461         (us', us1) = splitUniqSupply (nsUniqs name_supply)
 462         uniqs      = uniqsFromSupply n us1
 463         names      = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 464                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 465                      ]
 466     in
 467     setNameSupplyRn (name_supply {nsUniqs = us'})       `thenRn_`
 468     returnRn names
 469
 470
 471 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 472                     -> [(RdrName,SrcLoc)]
 473                     -> ([Name] -> RnMS a)
 474                     -> RnMS a
 475 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 476   = getModeRn                           `thenRn` \ mode ->
 477     getLocalNameEnv                     `thenRn` \ name_env ->
 478
 479         -- Check for duplicate names
 480     checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 481
 482     doptRn Opt_WarnNameShadowing                `thenRn` \ warn_shadow ->
 483
 484         -- Warn about shadowing, but only in source modules
 485     (case mode of
 486         SourceMode | warn_shadow -> 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 (addListToRdrEnv name_env pairs)
 533                     enclosed_scope
 534   where
 535     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 536
 537 bindLocalNamesFV names enclosed_scope
 538   = bindLocalNames names $
 539     enclosed_scope `thenRn` \ (thing, fvs) ->
 540     returnRn (thing, delListFromNameSet fvs names)
 541
 542
 543 -------------------------------------
 544 bindLocalRn doc rdr_name enclosed_scope
 545   = getSrcLocRn                                 `thenRn` \ loc ->
 546     bindLocatedLocalsRn doc [(rdr_name,loc)]    $ \ (n:ns) ->
 547     ASSERT( null ns )
 548     enclosed_scope n
 549
 550 bindLocalsRn doc rdr_names enclosed_scope
 551   = getSrcLocRn         `thenRn` \ loc ->
 552     bindLocatedLocalsRn doc
 553                         (rdr_names `zip` repeat loc)
 554                         enclosed_scope
 555
 556         -- binLocalsFVRn is the same as bindLocalsRn
 557         -- except that it deals with free vars
 558 bindLocalsFVRn doc rdr_names enclosed_scope
 559   = bindLocalsRn doc rdr_names          $ \ names ->
 560     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 561     returnRn (thing, delListFromNameSet fvs names)
 562
 563 -------------------------------------
 564 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 565         -- This tiresome function is used only in rnSourceDecl on InstDecl
 566 extendTyVarEnvFVRn tyvars enclosed_scope
 567   = bindLocalNames tyvars enclosed_scope        `thenRn` \ (thing, fvs) ->
 568     returnRn (thing, delListFromNameSet fvs tyvars)
 569
 570 bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
 571               -> ([HsTyVarBndr Name] -> RnMS a)
 572               -> RnMS a
 573 bindTyVarsRn doc_str tyvar_names enclosed_scope
 574   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 575     enclosed_scope tyvars
 576
 577 -- Gruesome name: return Names as well as HsTyVars
 578 bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
 579               -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
 580               -> RnMS a
 581 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 582   = getSrcLocRn                                 `thenRn` \ loc ->
 583     let
 584         located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
 585     in
 586     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 587     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 588
 589 bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
 590               -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
 591               -> RnMS (a, FreeVars)
 592 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 593   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 594     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 595     returnRn (thing, delListFromNameSet fvs names)
 596
 597 bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
 598               -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
 599               -> RnMS (a, FreeVars)
 600 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 601   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 602     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 603     returnRn (thing, delListFromNameSet fvs names)
 604
 605 bindNakedTyVarsFVRn :: SDoc -> [RdrName]
 606                     -> ([Name] -> RnMS (a, FreeVars))
 607                     -> RnMS (a, FreeVars)
 608 bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
 609   = getSrcLocRn                                 `thenRn` \ loc ->
 610     let
 611         located_tyvars = [(tv, loc) | tv <- tyvar_names]
 612     in
 613     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 614     enclosed_scope names                        `thenRn` \ (thing, fvs) ->
 615     returnRn (thing, delListFromNameSet fvs names)
 616
 617
 618 -------------------------------------
 619 checkDupOrQualNames, checkDupNames :: SDoc
 620                                    -> [(RdrName, SrcLoc)]
 621                                    -> RnM d ()
 622         -- Works in any variant of the renamer monad
 623
 624 checkDupOrQualNames doc_str rdr_names_w_loc
 625   =     -- Check for use of qualified names
 626     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 627     checkDupNames doc_str rdr_names_w_loc
 628   where
 629     quals = filter (isQual . fst) rdr_names_w_loc
 630
 631 checkDupNames doc_str rdr_names_w_loc
 632   =     -- Check for duplicated names in a binding group
 633     mapRn_ (dupNamesErr doc_str) dups
 634   where
 635     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 636 \end{code}
 637
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsection{GlobalRdrEnv}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 \begin{code}
 646 mkGlobalRdrEnv :: ModuleName            -- Imported module (after doing the "as M" name change)
 647                -> Bool                  -- True <=> want unqualified import
 648                -> Bool                  -- True <=> want qualified import
 649                -> [AvailInfo]           -- What's to be hidden (but only the unqualified
 650                                         --      version is hidden)
 651                -> (Name -> Provenance)
 652                -> Avails                -- Whats imported and how
 653                -> Deprecations
 654                -> GlobalRdrEnv
 655
 656 mkGlobalRdrEnv this_mod unqual_imp qual_imp hides
 657                mk_provenance avails deprecs
 658   = gbl_env2
 659   where
 660         -- Make the name environment.  We're talking about a
 661         -- single module here, so there must be no name clashes.
 662         -- In practice there only ever will be if it's the module
 663         -- being compiled.
 664
 665         -- Add the things that are available
 666     gbl_env1 = foldl add_avail emptyRdrEnv avails
 667
 668         -- Delete things that are hidden
 669     gbl_env2 = foldl del_avail gbl_env1 hides
 670
 671     add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
 672     add_avail env avail = foldl add_name env (availNames avail)
 673
 674     add_name env name
 675         | qual_imp && unqual_imp = env3
 676         | unqual_imp             = env2
 677         | qual_imp               = env1
 678         | otherwise              = env
 679         where
 680           env1 = addOneToGlobalRdrEnv env  (mkRdrQual this_mod occ) elt
 681           env2 = addOneToGlobalRdrEnv env  (mkRdrUnqual occ)        elt
 682           env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ)        elt
 683           occ  = nameOccName name
 684           elt  = GRE name (mk_provenance name) (lookupDeprec deprecs name)
 685
 686     del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
 687                         where
 688                           rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
 689
 690 mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv
 691 -- Used to construct a GlobalRdrEnv for an interface that we've
 692 -- read from a .hi file.  We can't construct the original top-level
 693 -- environment because we don't have enough info, but we compromise
 694 -- by making an environment from its exports
 695 mkIfaceGlobalRdrEnv m_avails
 696   = foldl add emptyRdrEnv m_avails
 697   where
 698     add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False []
 699                                                                 (\n -> LocalDef) avails NoDeprecs)
 700                 -- The NoDeprecs is a bit of a hack I suppose
 701 \end{code}
 702
 703 \begin{code}
 704 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 705 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 706
 707 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv
 708 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 709
 710 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 711 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 712
 713 combine_globals :: [GlobalRdrElt]       -- Old
 714                 -> [GlobalRdrElt]       -- New
 715                 -> [GlobalRdrElt]
 716 combine_globals ns_old ns_new   -- ns_new is often short
 717   = foldr add ns_old ns_new
 718   where
 719     add n ns | any (is_duplicate n) ns_old = map (choose n) ns  -- Eliminate duplicates
 720              | otherwise                   = n:ns
 721
 722     choose n m | n `beats` m = n
 723                | otherwise   = m
 724
 725     (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm
 726
 727     is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool
 728     is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False
 729     is_duplicate (GRE n1 _        _) (GRE n2 _        _) = n1 == n2
 730 \end{code}
 731
 732 We treat two bindings of a locally-defined name as a duplicate,
 733 because they might be two separate, local defns and we want to report
 734 and error for that, {\em not} eliminate a duplicate.
 735
 736 On the other hand, if you import the same name from two different
 737 import statements, we {\em do} want to eliminate the duplicate, not report
 738 an error.
 739
 740 If a module imports itself then there might be a local defn and an imported
 741 defn of the same name; in this case the names will compare as equal, but
 742 will still have different provenances.
 743
 744
 745 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 746 its unqualified name is in scope.  This is put as a boolean flag in
 747 the @Name@'s provenance to guide whether or not to print the name qualified
 748 in error messages.
 749
 750 \begin{code}
 751 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 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   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 904     if warn then mapRn_ (addWarnRn . unused_mod) mods
 905             else returnRn ()
 906   where
 907     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 908                            text "is imported, but nothing from it is used",
 909                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 910                                    quotes (ppr m))]
 911
 912 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 913 warnUnusedImports names
 914   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 915     if warn then warnUnusedBinds names else returnRn ()
 916
 917 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 918 warnUnusedLocalBinds names
 919   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 920     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 921             else returnRn ()
 922
 923 warnUnusedMatches names
 924   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 925     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 926             else returnRn ()
 927
 928 -------------------------
 929
 930 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 931 warnUnusedBinds names
 932   = mapRn_ warnUnusedGroup  groups
 933   where
 934         -- Group by provenance
 935    groups = equivClasses cmp names
 936    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 937
 938
 939 -------------------------
 940
 941 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 942 warnUnusedGroup names
 943   | null filtered_names  = returnRn ()
 944   | not is_local         = returnRn ()
 945   | otherwise
 946   = pushSrcLocRn def_loc        $
 947     addWarnRn                   $
 948     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 949   where
 950     filtered_names = filter reportable names
 951     (name1, prov1) = head filtered_names
 952     (is_local, def_loc, msg)
 953         = case prov1 of
 954                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 955
 956                 NonLocalDef (UserImport mod loc _)
 957                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 958
 959     reportable (name,_) = case occNameUserString (nameOccName name) of
 960                                 ('_' : _) -> False
 961                                 zz_other  -> True
 962         -- Haskell 98 encourages compilers to suppress warnings about
 963         -- unused names in a pattern if they start with "_".
 964 \end{code}
 965
 966 \begin{code}
 967 addNameClashErrRn rdr_name (np1:nps)
 968   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 969                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 970   where
 971     msg1 = ptext  SLIT("either") <+> mk_ref np1
 972     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 973     mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 974
 975 shadowedNameWarn shadow
 976   = hsep [ptext SLIT("This binding for"),
 977                quotes (ppr shadow),
 978                ptext SLIT("shadows an existing binding")]
 979
 980 unknownNameErr name
 981   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 982   where
 983     flavour = occNameFlavour (rdrNameOcc name)
 984
 985 qualNameErr descriptor (name,loc)
 986   = pushSrcLocRn loc $
 987     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 988                      quotes (ppr name),
 989                      ptext SLIT("in"),
 990                      descriptor])
 991
 992 dupNamesErr descriptor ((name,loc) : dup_things)
 993   = pushSrcLocRn loc $
 994     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 995               $$
 996               (ptext SLIT("in") <+> descriptor))
 997
 998 warnDeprec :: Name -> DeprecTxt -> RnM d ()
 999 warnDeprec name txt
1000   = doptRn Opt_WarnDeprecations                         `thenRn` \ warn_drs ->
1001     if not warn_drs then returnRn () else
1002     addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+>
1003                      quotes (ppr name) <+> text "is deprecated:",
1004                      nest 4 (ppr txt) ])
1005 \end{code}