ghc/compiler/rename/RnEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnEnv]{Environment manipulation for the renamer monad}
   5
   6 \begin{code}
   7 module RnEnv where              -- Export everything
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn
  12 import RdrHsSyn         ( RdrNameIE )
  13 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
  14                           mkRdrUnqual, qualifyRdrName
  15                         )
  16 import HsTypes          ( hsTyVarName, replaceTyVarName )
  17 import HscTypes         ( Provenance(..), pprNameProvenance, hasBetterProv,
  18                           ImportReason(..), GlobalRdrEnv, AvailEnv,
  19                           AvailInfo, GenAvailInfo(..), RdrAvailInfo )
  20 import RnMonad
  21 import Name             ( Name, NamedThing(..),
  22                           getSrcLoc,
  23                           mkLocalName, mkImportedLocalName, mkGlobalName,
  24                           mkIPName, nameOccName, nameModule,
  25                           extendNameEnv_C, plusNameEnv_C, nameEnvElts,
  26                           setNameModuleAndLoc
  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, noSrcLoc )
  35 import Outputable
  36 import ListSetOps       ( removeDups, equivClasses )
  37 import Util             ( sortLt )
  38 import List             ( nub )
  39 import PrelNames        ( mkUnboundName )
  40 import CmdLineOpts
  41 \end{code}
  42
  43 %*********************************************************
  44 %*                                                      *
  45 \subsection{Making new names}
  46 %*                                                      *
  47 %*********************************************************
  48
  49 \begin{code}
  50 newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
  51 newTopBinder mod rdr_name loc
  52   =     -- First check the cache
  53     traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
  54
  55     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
  56     let
  57         occ = rdrNameOcc rdr_name
  58         key = (moduleName mod, occ)
  59     in
  60     case lookupFM cache key of
  61
  62         -- A hit in the cache!  We are at the binding site of the name, and
  63         -- this is the moment when we know all about
  64         --      a) the Name's host Module (in particular, which
  65         --         package it comes from)
  66         --      b) its defining SrcLoc
  67         -- So we update this info
  68
  69         Just name -> let
  70                         new_name  = setNameModuleAndLoc name mod loc
  71                         new_cache = addToFM cache key new_name
  72                      in
  73                      setNameSupplyRn (us, new_cache, ipcache)   `thenRn_`
  74                      traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
  75                      returnRn new_name
  76
  77         -- Miss in the cache!
  78         -- Build a completely new Name, and put it in the cache
  79         -- Even for locally-defined names we use implicitImportProvenance;
  80         -- updateProvenances will set it to rights
  81         Nothing -> let
  82                         (us', us1) = splitUniqSupply us
  83                         uniq       = uniqFromSupply us1
  84                         new_name   = mkGlobalName uniq mod occ loc
  85                         new_cache  = addToFM cache key new_name
  86                    in
  87                    setNameSupplyRn (us', new_cache, ipcache)    `thenRn_`
  88                    traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
  89                    returnRn new_name
  90
  91
  92 newGlobalName :: ModuleName -> OccName -> RnM d Name
  93   -- Used for *occurrences*.  We make a place-holder Name, really just
  94   -- to agree on its unique, which gets overwritten when we read in
  95   -- the binding occurence later (newTopBinder)
  96   -- The place-holder Name doesn't have the right SrcLoc, and its
  97   -- Module won't have the right Package either.
  98   --
  99   -- (We have to pass a ModuleName, not a Module, because we may be
 100   -- simply looking at an occurrence M.x in an interface file.)
 101   --
 102   -- This means that a renamed program may have incorrect info
 103   -- on implicitly-imported occurrences, but the correct info on the
 104   -- *binding* declaration. It's the type checker that propagates the
 105   -- correct information to all the occurrences.
 106   -- Since implicitly-imported names never occur in error messages,
 107   -- it doesn't matter that we get the correct info in place till later,
 108   -- (but since it affects DLL-ery it does matter that we get it right
 109   --  in the end).
 110 newGlobalName mod_name occ
 111   = getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 112     let
 113         key = (mod_name, occ)
 114     in
 115     case lookupFM cache key of
 116         Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
 117                      returnRn name
 118
 119         Nothing   -> setNameSupplyRn (us', new_cache, ipcache)          `thenRn_`
 120                      traceRn (text "newGlobalName: new" <+> ppr name)   `thenRn_`
 121                      returnRn name
 122                   where
 123                      (us', us1) = splitUniqSupply us
 124                      uniq       = uniqFromSupply us1
 125                      mod        = mkVanillaModule mod_name
 126                      name       = mkGlobalName uniq mod occ noSrcLoc
 127                      new_cache  = addToFM cache key name
 128
 129 newIPName rdr_name
 130   = getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 131     case lookupFM ipcache key of
 132         Just name -> returnRn name
 133         Nothing   -> setNameSupplyRn (us', cache, new_ipcache)  `thenRn_`
 134                      returnRn name
 135                   where
 136                      (us', us1)  = splitUniqSupply us
 137                      uniq        = uniqFromSupply us1
 138                      name        = mkIPName uniq key
 139                      new_ipcache = addToFM ipcache key name
 140     where key = (rdrNameOcc rdr_name)
 141 \end{code}
 142
 143 %*********************************************************
 144 %*                                                      *
 145 \subsection{Looking up names}
 146 %*                                                      *
 147 %*********************************************************
 148
 149 Looking up a name in the RnEnv.
 150
 151 \begin{code}
 152 lookupBndrRn rdr_name
 153   = getLocalNameEnv             `thenRn` \ local_env ->
 154     case lookupRdrEnv local_env rdr_name of
 155           Just name -> returnRn name
 156           Nothing   -> lookupTopBndrRn rdr_name
 157
 158 lookupTopBndrRn rdr_name
 159   = getModeRn   `thenRn` \ mode ->
 160     case mode of
 161         InterfaceMode ->        -- Look in the global name cache
 162                             lookupOrigName rdr_name
 163
 164         SourceMode    -> -- Source mode, so look up a *qualified* version
 165                          -- of the name, so that we get the right one even
 166                          -- if there are many with the same occ name
 167                          -- There must *be* a binding
 168                 getModuleRn             `thenRn` \ mod ->
 169                 getGlobalNameEnv        `thenRn` \ global_env ->
 170                 case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
 171                   Just ((name,_):rest) -> ASSERT( null rest )
 172                                           returnRn name
 173                   Nothing          ->   -- Almost always this case is a compiler bug.
 174                                         -- But consider a type signature that doesn't have
 175                                         -- a corresponding binder:
 176                                         --      module M where { f :: Int->Int }
 177                                         -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
 178                                         -- and we don't want to panic.  So we report an out-of-scope error
 179                                         failWithRn (mkUnboundName rdr_name)
 180                                                    (unknownNameErr rdr_name)
 181
 182 -- lookupSigOccRn is used for type signatures and pragmas
 183 -- Is this valid?
 184 --   module A
 185 --      import M( f )
 186 --      f :: Int -> Int
 187 --      f x = x
 188 -- It's clear that the 'f' in the signature must refer to A.f
 189 -- The Haskell98 report does not stipulate this, but it will!
 190 -- So we must treat the 'f' in the signature in the same way
 191 -- as the binding occurrence of 'f', using lookupBndrRn
 192 lookupSigOccRn :: RdrName -> RnMS Name
 193 lookupSigOccRn = lookupBndrRn
 194
 195 -- lookupOccRn looks up an occurrence of a RdrName
 196 lookupOccRn :: RdrName -> RnMS Name
 197 lookupOccRn rdr_name
 198   = getLocalNameEnv                     `thenRn` \ local_env ->
 199     case lookupRdrEnv local_env rdr_name of
 200           Just name -> returnRn name
 201           Nothing   -> lookupGlobalOccRn rdr_name
 202
 203 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 204 -- environment.  It's used only for
 205 --      record field names
 206 --      class op names in class and instance decls
 207 lookupGlobalOccRn rdr_name
 208   = getModeRn   `thenRn` \ mode ->
 209     case mode of {
 210                 -- When processing interface files, the global env
 211                 -- is always empty, so go straight to the name cache
 212         InterfaceMode -> lookupOrigName rdr_name ;
 213
 214         SourceMode ->
 215
 216     getGlobalNameEnv    `thenRn` \ global_env ->
 217     case lookupRdrEnv global_env rdr_name of
 218         Just [(name,_)]  -> returnRn name
 219         Just stuff@((name,_):_)
 220                 -> addNameClashErrRn rdr_name stuff     `thenRn_`
 221                    returnRn name
 222         Nothing ->      -- Not found when processing source code; so fail
 223                         failWithRn (mkUnboundName rdr_name)
 224                                    (unknownNameErr rdr_name)
 225     }
 226 \end{code}
 227 %
 228
 229 @lookupOrigName@ takes an RdrName representing an {\em original}
 230 name, and adds it to the occurrence pool so that it'll be loaded
 231 later.  This is used when language constructs (such as monad
 232 comprehensions, overloaded literals, or deriving clauses) require some
 233 stuff to be loaded that isn't explicitly mentioned in the code.
 234
 235 This doesn't apply in interface mode, where everything is explicit,
 236 but we don't check for this case: it does no harm to record an
 237 ``extra'' occurrence and @lookupOrigNames@ isn't used much in
 238 interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
 239 calls it at all I think).
 240
 241   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 242
 243 For List and Tuple types it's important to get the correct
 244 @isLocallyDefined@ flag, which is used in turn when deciding
 245 whether there are any instance decls in this module are ``special''.
 246 The name cache should have the correct provenance, though.
 247
 248 \begin{code}
 249 lookupOrigName :: RdrName -> RnM d Name
 250 lookupOrigName rdr_name
 251   | isQual rdr_name
 252   = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 253
 254   | otherwise
 255   =     -- An Unqual is allowed; interface files contain
 256         -- unqualified names for locally-defined things, such as
 257         -- constructors of a data type.
 258     getModuleRn                         `thenRn ` \ mod ->
 259     newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
 260
 261 lookupOrigNames :: [RdrName] -> RnM d NameSet
 262 lookupOrigNames rdr_names
 263   = mapRn lookupOrigName rdr_names      `thenRn` \ names ->
 264     returnRn (mkNameSet names)
 265 \end{code}
 266
 267 lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
 268 It ensures that the module is set correctly in the name cache, and sets the provenance
 269 on the returned name too.  The returned name will end up actually in the type, class,
 270 or instance.
 271
 272 \begin{code}
 273 lookupSysBinder rdr_name
 274   = ASSERT( isUnqual rdr_name )
 275     getModuleRn                         `thenRn` \ mod ->
 276     getSrcLocRn                         `thenRn` \ loc ->
 277     newTopBinder mod rdr_name loc
 278 \end{code}
 279
 280
 281
 282 %*********************************************************
 283 %*                                                      *
 284 \subsection{Binding}
 285 %*                                                      *
 286 %*********************************************************
 287
 288 \begin{code}
 289 newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name)
 290             -> [(RdrName,SrcLoc)]
 291             -> RnMS [Name]
 292 newLocalsRn mk_name rdr_names_w_loc
 293  =  getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 294     let
 295         n          = length rdr_names_w_loc
 296         (us', us1) = splitUniqSupply us
 297         uniqs      = uniqsFromSupply n us1
 298         names      = [ mk_name uniq (rdrNameOcc rdr_name) loc
 299                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 300                      ]
 301     in
 302     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 303     returnRn names
 304
 305
 306 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 307                     -> [(RdrName,SrcLoc)]
 308                     -> ([Name] -> RnMS a)
 309                     -> RnMS a
 310 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 311   = getModeRn                           `thenRn` \ mode ->
 312     getLocalNameEnv                     `thenRn` \ name_env ->
 313
 314         -- Check for duplicate names
 315     checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 316
 317     doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
 318
 319         -- Warn about shadowing, but only in source modules
 320     (case mode of
 321         SourceMode | warn_shadow -> 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 :: (Name,Provenance) -> (Name,Provenance) -> Bool
 512     is_duplicate (n1,LocalDef) (n2,LocalDef) = False
 513     is_duplicate (n1,_)        (n2,_)        = 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   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 684     if warn then mapRn_ (addWarnRn . unused_mod) mods
 685             else returnRn ()
 686   where
 687     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 688                            text "is imported, but nothing from it is used",
 689                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 690                                    quotes (ppr (moduleName m)))]
 691
 692 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 693 warnUnusedImports names
 694   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 695     if warn then warnUnusedBinds names else returnRn ()
 696
 697 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 698 warnUnusedLocalBinds names
 699   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 700     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 701             else returnRn ()
 702
 703 warnUnusedMatches names
 704   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 705     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 706             else returnRn ()
 707
 708 -------------------------
 709
 710 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 711 warnUnusedBinds names
 712   = mapRn_ warnUnusedGroup  groups
 713   where
 714         -- Group by provenance
 715    groups = equivClasses cmp names
 716    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 717
 718
 719 -------------------------
 720
 721 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 722 warnUnusedGroup names
 723   | null filtered_names  = returnRn ()
 724   | not is_local         = returnRn ()
 725   | otherwise
 726   = pushSrcLocRn def_loc        $
 727     addWarnRn                   $
 728     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 729   where
 730     filtered_names = filter reportable names
 731     (name1, prov1) = head filtered_names
 732     (is_local, def_loc, msg)
 733         = case prov1 of
 734                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 735
 736                 NonLocalDef (UserImport mod loc _) _
 737                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 738
 739     reportable (name,_) = case occNameUserString (nameOccName name) of
 740                                 ('_' : _) -> False
 741                                 zz_other  -> True
 742         -- Haskell 98 encourages compilers to suppress warnings about
 743         -- unused names in a pattern if they start with "_".
 744 \end{code}
 745
 746 \begin{code}
 747 addNameClashErrRn rdr_name (np1:nps)
 748   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 749                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 750   where
 751     msg1 = ptext  SLIT("either") <+> mk_ref np1
 752     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 753     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 754
 755 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 756   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 757         4 (vcat [ppr how_in_scope1,
 758                  ppr how_in_scope2])
 759
 760 shadowedNameWarn shadow
 761   = hsep [ptext SLIT("This binding for"),
 762                quotes (ppr shadow),
 763                ptext SLIT("shadows an existing binding")]
 764
 765 unknownNameErr name
 766   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 767   where
 768     flavour = occNameFlavour (rdrNameOcc name)
 769
 770 qualNameErr descriptor (name,loc)
 771   = pushSrcLocRn loc $
 772     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 773                      quotes (ppr name),
 774                      ptext SLIT("in"),
 775                      descriptor])
 776
 777 dupNamesErr descriptor ((name,loc) : dup_things)
 778   = pushSrcLocRn loc $
 779     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 780               $$
 781               (ptext SLIT("in") <+> descriptor))
 782 \end{code}