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 HsSyn
  12 import RdrHsSyn         ( RdrNameIE )
  13 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
  14                           mkRdrUnqual, qualifyRdrName
  15                         )
  16 import HsTypes          ( hsTyVarName, hsTyVarNames, replaceTyVarName )
  17 import HscTypes         ( Provenance(..), pprNameProvenance, hasBetterProv,
  18                           ImportReason(..), GlobalRdrEnv, Avails, AvailEnv,
  19                           AvailInfo, GenAvailInfo(..), RdrAvailInfo )
  20 import RnMonad
  21 import Name             ( Name, NamedThing(..),
  22                           getSrcLoc,
  23                           mkLocalName, mkImportedLocalName, mkGlobalName,
  24                           mkIPName, isLocallyDefined,
  25                           nameOccName, nameModule,
  26                           extendNameEnv_C, plusNameEnv_C, nameEnvElts,
  27                           setNameModuleAndLoc
  28                         )
  29 import NameSet
  30 import OccName          ( OccName, occNameUserString, occNameFlavour )
  31 import Module           ( ModuleName, moduleName, mkVanillaModule )
  32 import FiniteMap
  33 import Unique           ( Unique )
  34 import UniqSupply
  35 import SrcLoc           ( SrcLoc, noSrcLoc )
  36 import Outputable
  37 import ListSetOps       ( removeDups, equivClasses )
  38 import Util             ( thenCmp, sortLt )
  39 import List             ( nub )
  40 import PrelNames        ( mkUnboundName )
  41 import CmdLineOpts
  42 \end{code}
  43
  44 %*********************************************************
  45 %*                                                      *
  46 \subsection{Making new names}
  47 %*                                                      *
  48 %*********************************************************
  49
  50 \begin{code}
  51 newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
  52 newTopBinder mod rdr_name loc
  53   =     -- First check the cache
  54     traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
  55
  56     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
  57     let
  58         occ = rdrNameOcc rdr_name
  59         key = (moduleName mod, occ)
  60     in
  61     case lookupFM cache key of
  62
  63         -- A hit in the cache!  We are at the binding site of the name, and
  64         -- this is the moment when we know all about
  65         --      a) the Name's host Module (in particular, which
  66         --         package it comes from)
  67         --      b) its defining SrcLoc
  68         -- So we update this info
  69
  70         Just name -> let
  71                         new_name  = setNameModuleAndLoc name mod loc
  72                         new_cache = addToFM cache key new_name
  73                      in
  74                      setNameSupplyRn (us, new_cache, ipcache)   `thenRn_`
  75                      traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
  76                      returnRn new_name
  77
  78         -- Miss in the cache!
  79         -- Build a completely new Name, and put it in the cache
  80         -- Even for locally-defined names we use implicitImportProvenance;
  81         -- updateProvenances will set it to rights
  82         Nothing -> let
  83                         (us', us1) = splitUniqSupply us
  84                         uniq       = uniqFromSupply us1
  85                         new_name   = mkGlobalName uniq mod occ loc
  86                         new_cache  = addToFM cache key new_name
  87                    in
  88                    setNameSupplyRn (us', new_cache, ipcache)    `thenRn_`
  89                    traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
  90                    returnRn new_name
  91
  92
  93 newGlobalName :: ModuleName -> OccName -> RnM d Name
  94   -- Used for *occurrences*.  We make a place-holder Name, really just
  95   -- to agree on its unique, which gets overwritten when we read in
  96   -- the binding occurence later (newTopBinder)
  97   -- The place-holder Name doesn't have the right SrcLoc, and its
  98   -- Module won't have the right Package either.
  99   --
 100   -- (We have to pass a ModuleName, not a Module, because we may be
 101   -- simply looking at an occurrence M.x in an interface file.)
 102   --
 103   -- This means that a renamed program may have incorrect info
 104   -- on implicitly-imported occurrences, but the correct info on the
 105   -- *binding* declaration. It's the type checker that propagates the
 106   -- correct information to all the occurrences.
 107   -- Since implicitly-imported names never occur in error messages,
 108   -- it doesn't matter that we get the correct info in place till later,
 109   -- (but since it affects DLL-ery it does matter that we get it right
 110   --  in the end).
 111 newGlobalName mod_name occ
 112   = getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 113     let
 114         key = (mod_name, occ)
 115     in
 116     case lookupFM cache key of
 117         Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
 118                      returnRn name
 119
 120         Nothing   -> setNameSupplyRn (us', new_cache, ipcache)          `thenRn_`
 121                      traceRn (text "newGlobalName: new" <+> ppr name)   `thenRn_`
 122                      returnRn name
 123                   where
 124                      (us', us1) = splitUniqSupply us
 125                      uniq       = uniqFromSupply us1
 126                      mod        = mkVanillaModule mod_name
 127                      name       = mkGlobalName uniq mod occ noSrcLoc
 128                      new_cache  = addToFM cache key name
 129
 130 newIPName rdr_name
 131   = getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 132     case lookupFM ipcache key of
 133         Just name -> returnRn name
 134         Nothing   -> setNameSupplyRn (us', cache, new_ipcache)  `thenRn_`
 135                      returnRn name
 136                   where
 137                      (us', us1)  = splitUniqSupply us
 138                      uniq        = uniqFromSupply us1
 139                      name        = mkIPName uniq key
 140                      new_ipcache = addToFM ipcache key name
 141     where key = (rdrNameOcc rdr_name)
 142 \end{code}
 143
 144 %*********************************************************
 145 %*                                                      *
 146 \subsection{Looking up names}
 147 %*                                                      *
 148 %*********************************************************
 149
 150 Looking up a name in the RnEnv.
 151
 152 \begin{code}
 153 lookupBndrRn rdr_name
 154   = getLocalNameEnv             `thenRn` \ local_env ->
 155     case lookupRdrEnv local_env rdr_name of
 156           Just name -> returnRn name
 157           Nothing   -> lookupTopBndrRn rdr_name
 158
 159 lookupTopBndrRn rdr_name
 160   = getModeRn   `thenRn` \ mode ->
 161     case mode of
 162         InterfaceMode ->        -- Look in the global name cache
 163                             lookupOrigName rdr_name
 164
 165         SourceMode    -> -- Source mode, so look up a *qualified* version
 166                          -- of the name, so that we get the right one even
 167                          -- if there are many with the same occ name
 168                          -- There must *be* a binding
 169                 getModuleRn             `thenRn` \ mod ->
 170                 getGlobalNameEnv        `thenRn` \ global_env ->
 171                 case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
 172                   Just ((name,_):rest) -> ASSERT( null rest )
 173                                           returnRn name
 174                   Nothing          ->   -- Almost always this case is a compiler bug.
 175                                         -- But consider a type signature that doesn't have
 176                                         -- a corresponding binder:
 177                                         --      module M where { f :: Int->Int }
 178                                         -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
 179                                         -- and we don't want to panic.  So we report an out-of-scope error
 180                                         failWithRn (mkUnboundName rdr_name)
 181                                                    (unknownNameErr rdr_name)
 182
 183 -- lookupSigOccRn is used for type signatures and pragmas
 184 -- Is this valid?
 185 --   module A
 186 --      import M( f )
 187 --      f :: Int -> Int
 188 --      f x = x
 189 -- It's clear that the 'f' in the signature must refer to A.f
 190 -- The Haskell98 report does not stipulate this, but it will!
 191 -- So we must treat the 'f' in the signature in the same way
 192 -- as the binding occurrence of 'f', using lookupBndrRn
 193 lookupSigOccRn :: RdrName -> RnMS Name
 194 lookupSigOccRn = lookupBndrRn
 195
 196 -- lookupOccRn looks up an occurrence of a RdrName
 197 lookupOccRn :: RdrName -> RnMS Name
 198 lookupOccRn rdr_name
 199   = getLocalNameEnv                     `thenRn` \ local_env ->
 200     case lookupRdrEnv local_env rdr_name of
 201           Just name -> returnRn name
 202           Nothing   -> lookupGlobalOccRn rdr_name
 203
 204 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 205 -- environment.  It's used only for
 206 --      record field names
 207 --      class op names in class and instance decls
 208 lookupGlobalOccRn rdr_name
 209   = getModeRn   `thenRn` \ mode ->
 210     case mode of {
 211                 -- When processing interface files, the global env
 212                 -- is always empty, so go straight to the name cache
 213         InterfaceMode -> lookupOrigName rdr_name ;
 214
 215         SourceMode ->
 216
 217     getGlobalNameEnv    `thenRn` \ global_env ->
 218     case lookupRdrEnv global_env rdr_name of
 219         Just [(name,_)]  -> returnRn name
 220         Just stuff@((name,_):_)
 221                 -> addNameClashErrRn rdr_name stuff     `thenRn_`
 222                    returnRn name
 223         Nothing ->      -- Not found when processing source code; so fail
 224                         failWithRn (mkUnboundName rdr_name)
 225                                    (unknownNameErr rdr_name)
 226     }
 227 \end{code}
 228 %
 229
 230 @lookupOrigName@ takes an RdrName representing an {\em original}
 231 name, and adds it to the occurrence pool so that it'll be loaded
 232 later.  This is used when language constructs (such as monad
 233 comprehensions, overloaded literals, or deriving clauses) require some
 234 stuff to be loaded that isn't explicitly mentioned in the code.
 235
 236 This doesn't apply in interface mode, where everything is explicit,
 237 but we don't check for this case: it does no harm to record an
 238 ``extra'' occurrence and @lookupOrigNames@ isn't used much in
 239 interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
 240 calls it at all I think).
 241
 242   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 243
 244 For List and Tuple types it's important to get the correct
 245 @isLocallyDefined@ flag, which is used in turn when deciding
 246 whether there are any instance decls in this module are ``special''.
 247 The name cache should have the correct provenance, though.
 248
 249 \begin{code}
 250 lookupOrigName :: RdrName -> RnM d Name
 251 lookupOrigName rdr_name
 252   | isQual rdr_name
 253   = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 254
 255   | otherwise
 256   =     -- An Unqual is allowed; interface files contain
 257         -- unqualified names for locally-defined things, such as
 258         -- constructors of a data type.
 259     getModuleRn                         `thenRn ` \ mod ->
 260     newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
 261
 262 lookupOrigNames :: [RdrName] -> RnM d NameSet
 263 lookupOrigNames rdr_names
 264   = mapRn lookupOrigName rdr_names      `thenRn` \ names ->
 265     returnRn (mkNameSet names)
 266 \end{code}
 267
 268 lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
 269 It ensures that the module is set correctly in the name cache, and sets the provenance
 270 on the returned name too.  The returned name will end up actually in the type, class,
 271 or instance.
 272
 273 \begin{code}
 274 lookupSysBinder rdr_name
 275   = ASSERT( isUnqual rdr_name )
 276     getModuleRn                         `thenRn` \ mod ->
 277     getSrcLocRn                         `thenRn` \ loc ->
 278     newTopBinder mod rdr_name loc
 279 \end{code}
 280
 281
 282
 283 %*********************************************************
 284 %*                                                      *
 285 \subsection{Binding}
 286 %*                                                      *
 287 %*********************************************************
 288
 289 \begin{code}
 290 newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name)
 291             -> [(RdrName,SrcLoc)]
 292             -> RnMS [Name]
 293 newLocalsRn mk_name rdr_names_w_loc
 294  =  getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 295     let
 296         n          = length rdr_names_w_loc
 297         (us', us1) = splitUniqSupply us
 298         uniqs      = uniqsFromSupply n us1
 299         names      = [ mk_name uniq (rdrNameOcc rdr_name) loc
 300                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 301                      ]
 302     in
 303     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 304     returnRn names
 305
 306
 307 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 308                     -> [(RdrName,SrcLoc)]
 309                     -> ([Name] -> RnMS a)
 310                     -> RnMS a
 311 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 312   = getModeRn                           `thenRn` \ mode ->
 313     getLocalNameEnv                     `thenRn` \ name_env ->
 314
 315         -- Check for duplicate names
 316     checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 317
 318     doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
 319
 320         -- Warn about shadowing, but only in source modules
 321     (case mode of
 322         SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
 323         other                              -> returnRn ()
 324     )                                   `thenRn_`
 325
 326     let
 327         mk_name    = case mode of
 328                         SourceMode    -> mkLocalName
 329                         InterfaceMode -> mkImportedLocalName
 330                      -- Keep track of whether the name originally came from
 331                      -- an interface file.
 332     in
 333     newLocalsRn mk_name rdr_names_w_loc         `thenRn` \ names ->
 334     let
 335         new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 336     in
 337     setLocalNameEnv new_local_env (enclosed_scope names)
 338
 339   where
 340     check_shadow name_env (rdr_name,loc)
 341         = case lookupRdrEnv name_env rdr_name of
 342                 Nothing   -> returnRn ()
 343                 Just name -> pushSrcLocRn loc $
 344                              addWarnRn (shadowedNameWarn rdr_name)
 345
 346 bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
 347                   -> RnMS (a, FreeVars)
 348   -- A specialised variant when renaming stuff from interface
 349   -- files (of which there is a lot)
 350   --    * one at a time
 351   --    * no checks for shadowing
 352   --    * always imported
 353   --    * deal with free vars
 354 bindCoreLocalFVRn rdr_name enclosed_scope
 355   = getSrcLocRn                 `thenRn` \ loc ->
 356     getLocalNameEnv             `thenRn` \ name_env ->
 357     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 358     let
 359         (us', us1) = splitUniqSupply us
 360         uniq       = uniqFromSupply us1
 361         name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
 362     in
 363     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 364     let
 365         new_name_env = extendRdrEnv name_env rdr_name name
 366     in
 367     setLocalNameEnv new_name_env (enclosed_scope name)  `thenRn` \ (result, fvs) ->
 368     returnRn (result, delFromNameSet fvs name)
 369
 370 bindCoreLocalsFVRn []     thing_inside = thing_inside []
 371 bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b    $ \ name' ->
 372                                          bindCoreLocalsFVRn bs  $ \ names' ->
 373                                          thing_inside (name':names')
 374
 375 bindLocalNames names enclosed_scope
 376   = getLocalNameEnv             `thenRn` \ name_env ->
 377     setLocalNameEnv (addListToRdrEnv name_env pairs)
 378                     enclosed_scope
 379   where
 380     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 381
 382 -------------------------------------
 383 bindLocalRn doc rdr_name enclosed_scope
 384   = getSrcLocRn                                 `thenRn` \ loc ->
 385     bindLocatedLocalsRn doc [(rdr_name,loc)]    $ \ (n:ns) ->
 386     ASSERT( null ns )
 387     enclosed_scope n
 388
 389 bindLocalsRn doc rdr_names enclosed_scope
 390   = getSrcLocRn         `thenRn` \ loc ->
 391     bindLocatedLocalsRn doc
 392                         (rdr_names `zip` repeat loc)
 393                         enclosed_scope
 394
 395         -- binLocalsFVRn is the same as bindLocalsRn
 396         -- except that it deals with free vars
 397 bindLocalsFVRn doc rdr_names enclosed_scope
 398   = bindLocalsRn doc rdr_names          $ \ names ->
 399     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 400     returnRn (thing, delListFromNameSet fvs names)
 401
 402 -------------------------------------
 403 bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
 404 bindUVarRn = bindLocalRn
 405
 406 -------------------------------------
 407 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 408         -- This tiresome function is used only in rnDecl on InstDecl
 409 extendTyVarEnvFVRn tyvars enclosed_scope
 410   = bindLocalNames tyvars enclosed_scope        `thenRn` \ (thing, fvs) ->
 411     returnRn (thing, delListFromNameSet fvs tyvars)
 412
 413 bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
 414               -> ([HsTyVarBndr Name] -> RnMS a)
 415               -> RnMS a
 416 bindTyVarsRn doc_str tyvar_names enclosed_scope
 417   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 418     enclosed_scope tyvars
 419
 420 -- Gruesome name: return Names as well as HsTyVars
 421 bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
 422               -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
 423               -> RnMS a
 424 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 425   = getSrcLocRn                                 `thenRn` \ loc ->
 426     let
 427         located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
 428     in
 429     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 430     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 431
 432 bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
 433               -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
 434               -> RnMS (a, FreeVars)
 435 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 436   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 437     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 438     returnRn (thing, delListFromNameSet fvs names)
 439
 440 bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
 441               -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
 442               -> RnMS (a, FreeVars)
 443 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 444   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 445     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 446     returnRn (thing, delListFromNameSet fvs names)
 447
 448 bindNakedTyVarsFVRn :: SDoc -> [RdrName]
 449                     -> ([Name] -> RnMS (a, FreeVars))
 450                     -> RnMS (a, FreeVars)
 451 bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
 452   = getSrcLocRn                                 `thenRn` \ loc ->
 453     let
 454         located_tyvars = [(tv, loc) | tv <- tyvar_names]
 455     in
 456     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 457     enclosed_scope names                        `thenRn` \ (thing, fvs) ->
 458     returnRn (thing, delListFromNameSet fvs names)
 459
 460
 461 -------------------------------------
 462 checkDupOrQualNames, checkDupNames :: SDoc
 463                                    -> [(RdrName, SrcLoc)]
 464                                    -> RnM d ()
 465         -- Works in any variant of the renamer monad
 466
 467 checkDupOrQualNames doc_str rdr_names_w_loc
 468   =     -- Check for use of qualified names
 469     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 470     checkDupNames doc_str rdr_names_w_loc
 471   where
 472     quals = filter (isQual.fst) rdr_names_w_loc
 473
 474 checkDupNames doc_str rdr_names_w_loc
 475   =     -- Check for duplicated names in a binding group
 476     mapRn_ (dupNamesErr doc_str) dups
 477   where
 478     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{GlobalRdrEnv}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 490 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 491
 492 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv
 493 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 494
 495 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 496 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 497
 498 combine_globals :: [(Name,Provenance)]  -- Old
 499                 -> [(Name,Provenance)]  -- New
 500                 -> [(Name,Provenance)]
 501 combine_globals ns_old ns_new   -- ns_new is often short
 502   = foldr add ns_old ns_new
 503   where
 504     add n ns | any (is_duplicate n) ns_old = map (choose n) ns  -- Eliminate duplicates
 505              | otherwise                   = n:ns
 506
 507     choose n m | n `beats` m = n
 508                | otherwise   = m
 509
 510     (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
 511
 512     is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
 513     is_duplicate (n1,LocalDef) (n2,LocalDef) = False
 514     is_duplicate (n1,_)        (n2,_)        = n1 == n2
 515 \end{code}
 516
 517 We treat two bindings of a locally-defined name as a duplicate,
 518 because they might be two separate, local defns and we want to report
 519 and error for that, {\em not} eliminate a duplicate.
 520
 521 On the other hand, if you import the same name from two different
 522 import statements, we {\em do} want to eliminate the duplicate, not report
 523 an error.
 524
 525 If a module imports itself then there might be a local defn and an imported
 526 defn of the same name; in this case the names will compare as equal, but
 527 will still have different provenances.
 528
 529
 530 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 531 its unqualified name is in scope.  This is put as a boolean flag in
 532 the @Name@'s provenance to guide whether or not to print the name qualified
 533 in error messages.
 534
 535 \begin{code}
 536 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 537 unQualInScope env
 538   = lookup
 539   where
 540     lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
 541                            Just [(name',_)] -> name == name'
 542                            other            -> False
 543 \end{code}
 544
 545
 546 %************************************************************************
 547 %*                                                                      *
 548 \subsection{Avails}
 549 %*                                                                      *
 550 %************************************************************************
 551
 552 \begin{code}
 553 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 554 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 555 -- Added SOF 4/97
 556 #ifdef DEBUG
 557 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 558 #endif
 559
 560 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 561 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 562
 563 emptyAvailEnv = emptyNameEnv
 564 unitAvailEnv :: AvailInfo -> AvailEnv
 565 unitAvailEnv a = unitNameEnv (availName a) a
 566
 567 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 568 plusAvailEnv = plusNameEnv_C plusAvail
 569
 570 availEnvElts = nameEnvElts
 571
 572 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 573 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 574
 575 availsToNameSet :: [AvailInfo] -> NameSet
 576 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 577
 578 availName :: GenAvailInfo name -> name
 579 availName (Avail n)     = n
 580 availName (AvailTC n _) = n
 581
 582 availNames :: GenAvailInfo name -> [name]
 583 availNames (Avail n)      = [n]
 584 availNames (AvailTC n ns) = ns
 585
 586 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
 587 addSysAvails avail          []  = avail
 588 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
 589
 590 rdrAvailInfo :: AvailInfo -> RdrAvailInfo
 591 -- Used when building the avails we are going to put in an interface file
 592 -- We sort the components to reduce needless wobbling of interfaces
 593 rdrAvailInfo (Avail n)      = Avail   (nameOccName n)
 594 rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
 595
 596 filterAvail :: RdrNameIE        -- Wanted
 597             -> AvailInfo        -- Available
 598             -> Maybe AvailInfo  -- Resulting available;
 599                                 -- Nothing if (any of the) wanted stuff isn't there
 600
 601 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 602   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 603   | otherwise    = Nothing
 604   where
 605     is_wanted name = nameOccName name `elem` wanted_occs
 606     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 607     avail_occs     = map nameOccName ns
 608     wanted_occs    = map rdrNameOcc (want:wants)
 609
 610 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 611                                                   Just (AvailTC n [n])
 612
 613 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 614
 615 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 616 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 617                                                 where
 618                                                   wanted n = nameOccName n == occ
 619                                                   occ      = rdrNameOcc v
 620         -- The second equation happens if we import a class op, thus
 621         --      import A( op )
 622         -- where op is a class operation
 623
 624 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 625         -- We don't complain even if the IE says T(..), but
 626         -- no constrs/class ops of T are available
 627         -- Instead that's caught with a warning by the caller
 628
 629 filterAvail ie avail = Nothing
 630
 631 pprAvail :: AvailInfo -> SDoc
 632 pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
 633                                         []  -> empty
 634                                         ns' -> parens (hsep (punctuate comma (map ppr ns')))
 635
 636 pprAvail (Avail n) = ppr n
 637 \end{code}
 638
 639
 640 %************************************************************************
 641 %*                                                                      *
 642 \subsection{Free variable manipulation}
 643 %*                                                                      *
 644 %************************************************************************
 645
 646 \begin{code}
 647 type FreeVars   = NameSet
 648
 649 plusFV   :: FreeVars -> FreeVars -> FreeVars
 650 addOneFV :: FreeVars -> Name -> FreeVars
 651 unitFV   :: Name -> FreeVars
 652 emptyFVs :: FreeVars
 653 plusFVs  :: [FreeVars] -> FreeVars
 654 mkFVs    :: [Name] -> FreeVars
 655
 656 isEmptyFVs = isEmptyNameSet
 657 emptyFVs   = emptyNameSet
 658 plusFVs    = unionManyNameSets
 659 plusFV     = unionNameSets
 660 mkFVs      = mkNameSet
 661
 662 -- No point in adding implicitly imported names to the free-var set
 663 addOneFV s n = addOneToNameSet s n
 664 unitFV     n = unitNameSet n
 665
 666 -- A useful utility
 667 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 668                let
 669                   (ys, fvs_s) = unzip stuff
 670                in
 671                returnRn (ys, plusFVs fvs_s)
 672 \end{code}
 673
 674
 675 %************************************************************************
 676 %*                                                                      *
 677 \subsection{Envt utility functions}
 678 %*                                                                      *
 679 %************************************************************************
 680
 681 \begin{code}
 682 warnUnusedModules :: [Module] -> RnM d ()
 683 warnUnusedModules mods
 684   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 685     if warn then mapRn_ (addWarnRn . unused_mod) mods
 686             else returnRn ()
 687   where
 688     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 689                            text "is imported, but nothing from it is used",
 690                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 691                                    quotes (ppr (moduleName m)))]
 692
 693 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 694 warnUnusedImports names
 695   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 696     if warn then warnUnusedBinds names else returnRn ()
 697
 698 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 699 warnUnusedLocalBinds names
 700   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 701     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 702             else returnRn ()
 703
 704 warnUnusedMatches names
 705   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 706     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 707             else returnRn ()
 708
 709 -------------------------
 710
 711 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 712 warnUnusedBinds names
 713   = mapRn_ warnUnusedGroup  groups
 714   where
 715         -- Group by provenance
 716    groups = equivClasses cmp names
 717    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 718
 719
 720 -------------------------
 721
 722 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 723 warnUnusedGroup names
 724   | null filtered_names  = returnRn ()
 725   | not is_local         = returnRn ()
 726   | otherwise
 727   = pushSrcLocRn def_loc        $
 728     addWarnRn                   $
 729     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 730   where
 731     filtered_names = filter reportable names
 732     (name1, prov1) = head filtered_names
 733     (is_local, def_loc, msg)
 734         = case prov1 of
 735                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 736
 737                 NonLocalDef (UserImport mod loc _) _
 738                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 739
 740     reportable (name,_) = case occNameUserString (nameOccName name) of
 741                                 ('_' : _) -> False
 742                                 zz_other  -> True
 743         -- Haskell 98 encourages compilers to suppress warnings about
 744         -- unused names in a pattern if they start with "_".
 745 \end{code}
 746
 747 \begin{code}
 748 addNameClashErrRn rdr_name (np1:nps)
 749   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 750                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 751   where
 752     msg1 = ptext  SLIT("either") <+> mk_ref np1
 753     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 754     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 755
 756 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 757   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 758         4 (vcat [ppr how_in_scope1,
 759                  ppr how_in_scope2])
 760
 761 shadowedNameWarn shadow
 762   = hsep [ptext SLIT("This binding for"),
 763                quotes (ppr shadow),
 764                ptext SLIT("shadows an existing binding")]
 765
 766 unknownNameErr name
 767   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 768   where
 769     flavour = occNameFlavour (rdrNameOcc name)
 770
 771 qualNameErr descriptor (name,loc)
 772   = pushSrcLocRn loc $
 773     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 774                      quotes (ppr name),
 775                      ptext SLIT("in"),
 776                      descriptor])
 777
 778 dupNamesErr descriptor ((name,loc) : dup_things)
 779   = pushSrcLocRn loc $
 780     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 781               $$
 782               (ptext SLIT("in") <+> descriptor))
 783 \end{code}