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