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