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