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