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