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, Avails, 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 -------------------------------------
 586 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
 587 addSysAvails avail          []  = avail
 588 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
 589
 590 -------------------------------------
 591 rdrAvailInfo :: AvailInfo -> RdrAvailInfo
 592 -- Used when building the avails we are going to put in an interface file
 593 -- We sort the components to reduce needless wobbling of interfaces
 594 rdrAvailInfo (Avail n)      = Avail   (nameOccName n)
 595 rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
 596
 597 -------------------------------------
 598 filterAvail :: RdrNameIE        -- Wanted
 599             -> AvailInfo        -- Available
 600             -> Maybe AvailInfo  -- Resulting available;
 601                                 -- Nothing if (any of the) wanted stuff isn't there
 602
 603 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 604   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 605   | otherwise    = Nothing
 606   where
 607     is_wanted name = nameOccName name `elem` wanted_occs
 608     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 609     avail_occs     = map nameOccName ns
 610     wanted_occs    = map rdrNameOcc (want:wants)
 611
 612 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 613                                                   Just (AvailTC n [n])
 614
 615 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 616
 617 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 618 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 619                                                 where
 620                                                   wanted n = nameOccName n == occ
 621                                                   occ      = rdrNameOcc v
 622         -- The second equation happens if we import a class op, thus
 623         --      import A( op )
 624         -- where op is a class operation
 625
 626 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 627         -- We don't complain even if the IE says T(..), but
 628         -- no constrs/class ops of T are available
 629         -- Instead that's caught with a warning by the caller
 630
 631 filterAvail ie avail = Nothing
 632
 633 -------------------------------------
 634 sortAvails :: Avails -> Avails
 635 sortAvails avails = sortLt lt avails
 636   where
 637     a1 `lt` a2 = mod1 < mod2 ||
 638                  (mod1 == mod2 && occ1 < occ2)
 639                where
 640                  name1 = availName a1
 641                  name2 = availName a2
 642                  mod1  = nameModule name1
 643                  mod2  = nameModule name2
 644                  occ1  = nameOccName name1
 645                  occ2  = nameOccName name2
 646
 647 -------------------------------------
 648 pprAvail :: AvailInfo -> SDoc
 649 pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
 650                                         []  -> empty
 651                                         ns' -> parens (hsep (punctuate comma (map ppr ns')))
 652
 653 pprAvail (Avail n) = ppr n
 654 \end{code}
 655
 656
 657 %************************************************************************
 658 %*                                                                      *
 659 \subsection{Free variable manipulation}
 660 %*                                                                      *
 661 %************************************************************************
 662
 663 \begin{code}
 664 type FreeVars   = NameSet
 665
 666 plusFV   :: FreeVars -> FreeVars -> FreeVars
 667 addOneFV :: FreeVars -> Name -> FreeVars
 668 unitFV   :: Name -> FreeVars
 669 emptyFVs :: FreeVars
 670 plusFVs  :: [FreeVars] -> FreeVars
 671 mkFVs    :: [Name] -> FreeVars
 672
 673 isEmptyFVs = isEmptyNameSet
 674 emptyFVs   = emptyNameSet
 675 plusFVs    = unionManyNameSets
 676 plusFV     = unionNameSets
 677 mkFVs      = mkNameSet
 678
 679 -- No point in adding implicitly imported names to the free-var set
 680 addOneFV s n = addOneToNameSet s n
 681 unitFV     n = unitNameSet n
 682
 683 -- A useful utility
 684 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 685                let
 686                   (ys, fvs_s) = unzip stuff
 687                in
 688                returnRn (ys, plusFVs fvs_s)
 689 \end{code}
 690
 691
 692 %************************************************************************
 693 %*                                                                      *
 694 \subsection{Envt utility functions}
 695 %*                                                                      *
 696 %************************************************************************
 697
 698 \begin{code}
 699 warnUnusedModules :: [ModuleName] -> RnM d ()
 700 warnUnusedModules mods
 701   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 702     if warn then mapRn_ (addWarnRn . unused_mod) mods
 703             else returnRn ()
 704   where
 705     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 706                            text "is imported, but nothing from it is used",
 707                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 708                                    quotes (ppr m))]
 709
 710 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 711 warnUnusedImports names
 712   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 713     if warn then warnUnusedBinds names else returnRn ()
 714
 715 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 716 warnUnusedLocalBinds names
 717   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 718     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 719             else returnRn ()
 720
 721 warnUnusedMatches names
 722   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 723     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 724             else returnRn ()
 725
 726 -------------------------
 727
 728 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 729 warnUnusedBinds names
 730   = mapRn_ warnUnusedGroup  groups
 731   where
 732         -- Group by provenance
 733    groups = equivClasses cmp names
 734    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 735
 736
 737 -------------------------
 738
 739 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 740 warnUnusedGroup names
 741   | null filtered_names  = returnRn ()
 742   | not is_local         = returnRn ()
 743   | otherwise
 744   = pushSrcLocRn def_loc        $
 745     addWarnRn                   $
 746     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 747   where
 748     filtered_names = filter reportable names
 749     (name1, prov1) = head filtered_names
 750     (is_local, def_loc, msg)
 751         = case prov1 of
 752                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 753
 754                 NonLocalDef (UserImport mod loc _) _
 755                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 756
 757     reportable (name,_) = case occNameUserString (nameOccName name) of
 758                                 ('_' : _) -> False
 759                                 zz_other  -> True
 760         -- Haskell 98 encourages compilers to suppress warnings about
 761         -- unused names in a pattern if they start with "_".
 762 \end{code}
 763
 764 \begin{code}
 765 addNameClashErrRn rdr_name (np1:nps)
 766   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 767                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 768   where
 769     msg1 = ptext  SLIT("either") <+> mk_ref np1
 770     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 771     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 772
 773 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 774   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 775         4 (vcat [ppr how_in_scope1,
 776                  ppr how_in_scope2])
 777
 778 shadowedNameWarn shadow
 779   = hsep [ptext SLIT("This binding for"),
 780                quotes (ppr shadow),
 781                ptext SLIT("shadows an existing binding")]
 782
 783 unknownNameErr name
 784   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 785   where
 786     flavour = occNameFlavour (rdrNameOcc name)
 787
 788 qualNameErr descriptor (name,loc)
 789   = pushSrcLocRn loc $
 790     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 791                      quotes (ppr name),
 792                      ptext SLIT("in"),
 793                      descriptor])
 794
 795 dupNamesErr descriptor ((name,loc) : dup_things)
 796   = pushSrcLocRn loc $
 797     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 798               $$
 799               (ptext SLIT("in") <+> descriptor))
 800 \end{code}