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