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 CmdLineOpts      ( opt_WarnNameShadowing, opt_WarnUnusedMatches,
  12                           opt_WarnUnusedBinds, opt_WarnUnusedImports )
  13 import HsSyn
  14 import RdrHsSyn         ( RdrNameIE )
  15 import RnHsSyn          ( RenamedHsType )
  16 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
  17                           mkRdrUnqual, qualifyRdrName
  18                         )
  19 import HsTypes          ( getTyVarName, replaceTyVarName )
  20
  21 import RnMonad
  22 import Name             ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
  23                           ImportReason(..), getSrcLoc,
  24                           mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName,
  25                           nameOccName, setNameModule, nameModule,
  26                           pprOccName, isLocallyDefined, nameUnique, nameOccName,
  27                           occNameUserString,
  28                           setNameProvenance, getNameProvenance, pprNameProvenance
  29                         )
  30 import NameSet
  31 import OccName          ( OccName,
  32                           mkDFunOcc, occNameUserString, occNameString,
  33                           occNameFlavour
  34                         )
  35 import TysWiredIn       ( tupleTyCon, unboxedTupleTyCon, listTyCon )
  36 import Type             ( funTyCon )
  37 import Module           ( ModuleName, mkThisModule, mkVanillaModule, moduleName )
  38 import TyCon            ( TyCon )
  39 import FiniteMap
  40 import Unique           ( Unique, Uniquable(..) )
  41 import UniqFM           ( emptyUFM, listToUFM, plusUFM_C )
  42 import UniqSupply
  43 import SrcLoc           ( SrcLoc, noSrcLoc )
  44 import Outputable
  45 import Util             ( removeDups, equivClasses, thenCmp )
  46 import List             ( nub )
  47 import Maybes           ( mapMaybe )
  48 \end{code}
  49
  50
  51
  52 %*********************************************************
  53 %*                                                      *
  54 \subsection{Making new names}
  55 %*                                                      *
  56 %*********************************************************
  57
  58 \begin{code}
  59 newImportedGlobalName mod_name occ mod
  60   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  61     let
  62         key = (mod_name, occ)
  63     in
  64     case lookupFM cache key of
  65         Just name -> returnRn name
  66         Nothing   -> setNameSupplyRn (us', inst_ns, new_cache)  `thenRn_`
  67                      returnRn name
  68                   where
  69                      (us', us1) = splitUniqSupply us
  70                      uniq       = uniqFromSupply us1
  71                      name       = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False)
  72                      new_cache  = addToFM cache key name
  73
  74 updateProvenances :: [Name] -> RnM d ()
  75 updateProvenances names
  76   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  77     setNameSupplyRn (us, inst_ns, update cache names)
  78   where
  79     update cache []           = cache
  80     update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
  81                                 update (addToFM cache key name) names
  82                               where
  83                                 key = (moduleName (nameModule name), nameOccName name)
  84
  85 newImportedBinder :: Module -> RdrName -> RnM d Name
  86 newImportedBinder mod rdr_name
  87   = ASSERT2( isUnqual rdr_name, ppr rdr_name )
  88     newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod
  89
  90 -- Make an imported global name, checking first to see if it's in the cache
  91 mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
  92 mkImportedGlobalName mod_name occ
  93   = lookupModuleRn mod_name `thenRn` \ mod ->
  94     newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name)
  95
  96 mkImportedGlobalFromRdrName rdr_name
  97   | isQual rdr_name
  98   = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
  99
 100   | otherwise
 101   =     -- An Unqual is allowed; interface files contain
 102         -- unqualified names for locally-defined things, such as
 103         -- constructors of a data type.
 104     getModuleRn                         `thenRn ` \ mod_name ->
 105     mkImportedGlobalName mod_name (rdrNameOcc rdr_name)
 106
 107
 108 newLocalTopBinder :: Module -> OccName
 109                -> (Name -> ExportFlag) -> SrcLoc
 110                -> RnM d Name
 111 newLocalTopBinder mod occ rec_exp_fn loc
 112   =     -- First check the cache
 113     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 114     let
 115         key          = (moduleName mod,occ)
 116         mk_prov name = LocalDef loc (rec_exp_fn name)
 117         -- We must set the provenance of the thing in the cache
 118         -- correctly, particularly whether or not it is locally defined.
 119         --
 120         -- Since newLocallyDefinedGlobalName is used only
 121         -- at binding occurrences, we may as well get the provenance
 122         -- dead right first time; hence the rec_exp_fn passed in
 123     in
 124     case lookupFM cache key of
 125
 126         -- A hit in the cache!
 127         -- Overwrite whatever provenance is in the cache already;
 128         -- this updates WiredIn things and known-key things,
 129         -- which are there from the start, to LocalDef.
 130         --
 131         -- It also means that if there are two defns for the same thing
 132         -- in a module, then each gets a separate SrcLoc
 133         Just name -> let
 134                         new_name = setNameProvenance name (mk_prov new_name)
 135                         new_cache = addToFM cache key new_name
 136                      in
 137                      setNameSupplyRn (us, inst_ns, new_cache)           `thenRn_`
 138                      returnRn new_name
 139
 140         -- Miss in the cache!
 141         -- Build a new original name, and put it in the cache
 142         Nothing -> let
 143                         (us', us1) = splitUniqSupply us
 144                         uniq       = uniqFromSupply us1
 145                         new_name   = mkGlobalName uniq mod occ (mk_prov new_name)
 146                         new_cache  = addToFM cache key new_name
 147                    in
 148                    setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
 149                    returnRn new_name
 150 \end{code}
 151
 152 %*********************************************************
 153 %*                                                      *
 154 \subsection{Dfuns and default methods}
 155 %*                                                      *
 156 %*********************************************************
 157
 158 @newImplicitBinder@ is used for (a) dfuns
 159 (b) default methods, defined in this module.
 160
 161 \begin{code}
 162 newImplicitBinder occ src_loc
 163   = getModuleRn                         `thenRn` \ mod_name ->
 164     newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc
 165 \end{code}
 166
 167 Make a name for the dict fun for an instance decl
 168
 169 \begin{code}
 170 newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name
 171 newDFunName key@(cl_occ, tycon_occ) loc
 172   = newInstUniq string  `thenRn` \ inst_uniq ->
 173     newImplicitBinder (mkDFunOcc string inst_uniq) loc
 174   where
 175         -- Any string that is somewhat unique will do
 176     string = occNameString cl_occ ++ occNameString tycon_occ
 177 \end{code}
 178
 179 \begin{code}
 180 getDFunKey :: RenamedHsType -> (OccName, OccName)       -- Used to manufacture DFun names
 181 getDFunKey (HsForAllTy _ _ ty)     = getDFunKey ty
 182 getDFunKey (MonoFunTy _ ty)        = getDFunKey ty
 183 getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
 184
 185 get_tycon_key (MonoTyVar tv)   = nameOccName (getName tv)
 186 get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
 187 get_tycon_key (MonoTupleTy tys True)  = getOccName (tupleTyCon        (length tys))
 188 get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
 189 get_tycon_key (MonoListTy _)   = getOccName listTyCon
 190 get_tycon_key (MonoFunTy _ _)  = getOccName funTyCon
 191 \end{code}
 192
 193
 194 %*********************************************************
 195 %*                                                      *
 196 \subsection{Binding}
 197 %*                                                      *
 198 %*********************************************************
 199
 200 \begin{code}
 201 -------------------------------------
 202 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 203                     -> [(RdrName,SrcLoc)]
 204                     -> ([Name] -> RnMS a)
 205                     -> RnMS a
 206 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 207   = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 208
 209     getLocalNameEnv                     `thenRn` \ name_env ->
 210     (if opt_WarnNameShadowing
 211      then
 212         mapRn_ (check_shadow name_env) rdr_names_w_loc
 213      else
 214         returnRn ()
 215     )                                   `thenRn_`
 216
 217     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 218     getModeRn                   `thenRn` \ mode ->
 219     let
 220         n          = length rdr_names_w_loc
 221         (us', us1) = splitUniqSupply us
 222         uniqs      = uniqsFromSupply n us1
 223         names      = [ mk_name uniq (rdrNameOcc rdr_name) loc
 224                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 225                      ]
 226         mk_name    = case mode of
 227                         SourceMode    -> mkLocalName
 228                         InterfaceMode -> mkImportedLocalName
 229                      -- Keep track of whether the name originally came from
 230                      -- an interface file.
 231     in
 232     setNameSupplyRn (us', inst_ns, cache)       `thenRn_`
 233
 234     let
 235         new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 236     in
 237     setLocalNameEnv new_name_env (enclosed_scope names)
 238
 239   where
 240     check_shadow name_env (rdr_name,loc)
 241         = case lookupRdrEnv name_env rdr_name of
 242                 Nothing   -> returnRn ()
 243                 Just name -> pushSrcLocRn loc $
 244                              addWarnRn (shadowedNameWarn rdr_name)
 245
 246 bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
 247                   -> RnMS (a, FreeVars)
 248   -- A specialised variant when renaming stuff from interface
 249   -- files (of which there is a lot)
 250   --    * one at a time
 251   --    * no checks for shadowing
 252   --    * always imported
 253   --    * deal with free vars
 254 bindCoreLocalFVRn rdr_name enclosed_scope
 255   = getSrcLocRn                 `thenRn` \ loc ->
 256     getLocalNameEnv             `thenRn` \ name_env ->
 257     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 258     let
 259         (us', us1) = splitUniqSupply us
 260         uniq       = uniqFromSupply us1
 261         name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
 262     in
 263     setNameSupplyRn (us', inst_ns, cache)       `thenRn_`
 264     let
 265         new_name_env = extendRdrEnv name_env rdr_name name
 266     in
 267     setLocalNameEnv new_name_env (enclosed_scope name)  `thenRn` \ (result, fvs) ->
 268     returnRn (result, delFromNameSet fvs name)
 269
 270 bindCoreLocalsFVRn []     thing_inside = thing_inside []
 271 bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b    $ \ name' ->
 272                                          bindCoreLocalsFVRn bs  $ \ names' ->
 273                                          thing_inside (name':names')
 274
 275 -------------------------------------
 276 bindLocalRn doc rdr_name enclosed_scope
 277   = getSrcLocRn                                 `thenRn` \ loc ->
 278     bindLocatedLocalsRn doc [(rdr_name,loc)]    $ \ (n:ns) ->
 279     ASSERT( null ns )
 280     enclosed_scope n
 281
 282 bindLocalsRn doc rdr_names enclosed_scope
 283   = getSrcLocRn         `thenRn` \ loc ->
 284     bindLocatedLocalsRn doc
 285                         (rdr_names `zip` repeat loc)
 286                         enclosed_scope
 287
 288         -- binLocalsFVRn is the same as bindLocalsRn
 289         -- except that it deals with free vars
 290 bindLocalsFVRn doc rdr_names enclosed_scope
 291   = bindLocalsRn doc rdr_names          $ \ names ->
 292     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 293     returnRn (thing, delListFromNameSet fvs names)
 294
 295 -------------------------------------
 296 bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
 297 bindUVarRn = bindLocalRn
 298
 299 -------------------------------------
 300 extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 301         -- This tiresome function is used only in rnDecl on InstDecl
 302 extendTyVarEnvFVRn tyvars enclosed_scope
 303   = getLocalNameEnv             `thenRn` \ env ->
 304     let
 305         tyvar_names = map getTyVarName tyvars
 306         new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name)
 307                                       | name <- tyvar_names
 308                                       ]
 309     in
 310     setLocalNameEnv new_env enclosed_scope      `thenRn` \ (thing, fvs) ->
 311     returnRn (thing, delListFromNameSet fvs tyvar_names)
 312
 313 bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
 314               -> ([HsTyVar Name] -> RnMS a)
 315               -> RnMS a
 316 bindTyVarsRn doc_str tyvar_names enclosed_scope
 317   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 318     enclosed_scope tyvars
 319
 320 -- Gruesome name: return Names as well as HsTyVars
 321 bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
 322               -> ([Name] -> [HsTyVar Name] -> RnMS a)
 323               -> RnMS a
 324 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 325   = getSrcLocRn                                 `thenRn` \ loc ->
 326     let
 327         located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
 328     in
 329     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 330     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 331
 332 bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
 333               -> ([HsTyVar Name] -> RnMS (a, FreeVars))
 334               -> RnMS (a, FreeVars)
 335 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 336   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 337     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 338     returnRn (thing, delListFromNameSet fvs names)
 339
 340 bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
 341               -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars))
 342               -> RnMS (a, FreeVars)
 343 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 344   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 345     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 346     returnRn (thing, delListFromNameSet fvs names)
 347
 348
 349 -------------------------------------
 350 checkDupOrQualNames, checkDupNames :: SDoc
 351                                    -> [(RdrName, SrcLoc)]
 352                                    -> RnM d ()
 353         -- Works in any variant of the renamer monad
 354
 355 checkDupOrQualNames doc_str rdr_names_w_loc
 356   =     -- Check for use of qualified names
 357     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 358     checkDupNames doc_str rdr_names_w_loc
 359   where
 360     quals = filter (isQual.fst) rdr_names_w_loc
 361
 362 checkDupNames doc_str rdr_names_w_loc
 363   =     -- Check for duplicated names in a binding group
 364     mapRn_ (dupNamesErr doc_str) dups
 365   where
 366     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 367 \end{code}
 368
 369
 370 %*********************************************************
 371 %*                                                      *
 372 \subsection{Looking up names}
 373 %*                                                      *
 374 %*********************************************************
 375
 376 Looking up a name in the RnEnv.
 377
 378 \begin{code}
 379 lookupBndrRn rdr_name
 380   = getNameEnvs         `thenRn` \ (global_env, local_env) ->
 381
 382         -- Try local env
 383     case lookupRdrEnv local_env rdr_name of {
 384           Just name -> returnRn name ;
 385           Nothing   ->
 386
 387     getModeRn   `thenRn` \ mode ->
 388     case mode of
 389         InterfaceMode ->        -- Look in the global name cache
 390                             mkImportedGlobalFromRdrName rdr_name
 391
 392         SourceMode    -> -- Source mode, so look up a *qualified* version
 393                          -- of the name, so that we get the right one even
 394                          -- if there are many with the same occ name
 395                          -- There must *be* a binding
 396                 getModuleRn             `thenRn` \ mod ->
 397                 case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
 398                   Just (name:rest) -> ASSERT( null rest )
 399                                       returnRn name
 400                   Nothing          -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name)
 401     }
 402
 403 -- Just like lookupRn except that we record the occurrence too
 404 -- Perhaps surprisingly, even wired-in names are recorded.
 405 -- Why?  So that we know which wired-in names are referred to when
 406 -- deciding which instance declarations to import.
 407 lookupOccRn :: RdrName -> RnMS Name
 408 lookupOccRn rdr_name
 409   = getNameEnvs                         `thenRn` \ (global_env, local_env) ->
 410     lookup_occ global_env local_env rdr_name
 411
 412 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 413 -- environment.  It's used only for
 414 --      record field names
 415 --      class op names in class and instance decls
 416 lookupGlobalOccRn :: RdrName -> RnMS Name
 417 lookupGlobalOccRn rdr_name
 418   = getNameEnvs                         `thenRn` \ (global_env, local_env) ->
 419     lookup_global_occ global_env rdr_name
 420
 421 -- Look in both local and global env
 422 lookup_occ global_env local_env rdr_name
 423   = case lookupRdrEnv local_env rdr_name of
 424           Just name -> returnRn name
 425           Nothing   -> lookup_global_occ global_env rdr_name
 426
 427 -- Look in global env only
 428 lookup_global_occ global_env rdr_name
 429   = case lookupRdrEnv global_env rdr_name of
 430         Just [name]         -> returnRn name
 431         Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
 432                                returnRn name
 433         Nothing -> getModeRn    `thenRn` \ mode ->
 434                    case mode of
 435                         -- Not found when processing source code; so fail
 436                         SourceMode    -> failWithRn (mkUnboundName rdr_name)
 437                                                     (unknownNameErr rdr_name)
 438
 439                         -- Not found when processing an imported declaration,
 440                         -- so we create a new name for the purpose
 441                         InterfaceMode -> mkImportedGlobalFromRdrName rdr_name
 442 \end{code}
 443 %
 444 @lookupImplicitOccRn@ takes an RdrName representing an {\em original} name,
 445 and adds it to the occurrence pool so that it'll be loaded later.
 446 This is used when language constructs
 447 (such as monad comprehensions, overloaded literals, or deriving clauses)
 448 require some stuff to be loaded that isn't explicitly mentioned in the code.
 449
 450 This doesn't apply in interface mode, where everything is explicit,
 451 but we don't check for this case:
 452 it does no harm to record an ``extra'' occurrence
 453 and @lookupImplicitOccRn@ isn't used much in interface mode
 454 (it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think).
 455
 456   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 457
 458 For List and Tuple types it's important to get the correct
 459 @isLocallyDefined@ flag, which is used in turn when deciding
 460 whether there are any instance decls in this module are ``special''.
 461 The name cache should have the correct provenance, though.
 462
 463 \begin{code}
 464 lookupImplicitOccRn :: RdrName -> RnM d Name
 465 lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
 466 \end{code}
 467
 468 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 469 its unqualified name is in scope.  This is put as a boolean flag in
 470 the @Name@'s provenance to guide whether or not to print the name qualified
 471 in error messages.
 472
 473 \begin{code}
 474 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 475 unQualInScope env
 476   = lookup
 477   where
 478     lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
 479                            Just [name'] -> name == name'
 480                            other        -> False
 481 \end{code}
 482
 483 %************************************************************************
 484 %*                                                                      *
 485 \subsection{Envt utility functions}
 486 %*                                                                      *
 487 %************************************************************************
 488
 489 \subsubsection{NameEnv}%  ================
 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 -> 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]       -- Old
 502                 -> [Name]       -- New
 503                 -> [Name]
 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 ns      -- Eliminate duplicates
 508              | otherwise                   = n:ns
 509              where
 510                choose n' | n==n' && better_provenance n n' = n
 511                          | otherwise                       = n'
 512
 513 -- Choose
 514 --      a local thing                 over an   imported thing
 515 --      a user-imported thing         over a    non-user-imported thing
 516 --      an explicitly-imported thing  over an   implicitly imported thing
 517 better_provenance n1 n2
 518   = case (getNameProvenance n1, getNameProvenance n2) of
 519         (LocalDef _ _,                        _                           ) -> True
 520         (NonLocalDef (UserImport _ _ True) _, _                           ) -> True
 521         (NonLocalDef (UserImport _ _ _   ) _, NonLocalDef ImplicitImport _) -> True
 522         other                                                               -> False
 523
 524 is_duplicate :: Name -> Name -> Bool
 525 is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
 526                    | otherwise                                  = n1 == n2
 527 \end{code}
 528 We treat two bindings of a locally-defined name as a duplicate,
 529 because they might be two separate, local defns and we want to report
 530 and error for that, {\em not} eliminate a duplicate.
 531
 532 On the other hand, if you import the same name from two different
 533 import statements, we {\em d}* want to eliminate the duplicate, not report
 534 an error.
 535
 536 If a module imports itself then there might be a local defn and an imported
 537 defn of the same name; in this case the names will compare as equal, but
 538 will still have different provenances.
 539
 540
 541
 542 \subsubsection{ExportAvails}%  ================
 543
 544 \begin{code}
 545 mkEmptyExportAvails :: ModuleName -> ExportAvails
 546 mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
 547
 548 mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
 549 mkExportAvails mod_name unqual_imp name_env avails
 550   = (mod_avail_env, entity_avail_env)
 551   where
 552     mod_avail_env = unitFM mod_name unqual_avails
 553
 554         -- unqual_avails is the Avails that are visible in *unqualfied* form
 555         -- (1.4 Report, Section 5.1.1)
 556         -- For example, in
 557         --      import T hiding( f )
 558         -- we delete f from avails
 559
 560     unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
 561                   | otherwise      = mapMaybe prune avails
 562
 563     prune (Avail n) | unqual_in_scope n = Just (Avail n)
 564     prune (Avail n) | otherwise         = Nothing
 565     prune (AvailTC n ns) | null uqs     = Nothing
 566                          | otherwise    = Just (AvailTC n uqs)
 567                          where
 568                            uqs = filter unqual_in_scope ns
 569
 570     unqual_in_scope n = unQualInScope name_env n
 571
 572     entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
 573                                                   name  <- availNames avail]
 574
 575 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 576 plusExportAvails (m1, e1) (m2, e2)
 577   = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
 578         -- ToDo: wasteful: we do this once for each constructor!
 579 \end{code}
 580
 581
 582 \subsubsection{AvailInfo}%  ================
 583
 584 \begin{code}
 585 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 586 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
 587 -- Added SOF 4/97
 588 #ifdef DEBUG
 589 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 590 #endif
 591
 592 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 593 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 594
 595 availsToNameSet :: [AvailInfo] -> NameSet
 596 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 597
 598 availName :: AvailInfo -> Name
 599 availName (Avail n)     = n
 600 availName (AvailTC n _) = n
 601
 602 availNames :: AvailInfo -> [Name]
 603 availNames (Avail n)      = [n]
 604 availNames (AvailTC n ns) = ns
 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
 636 filterAvail ie avail = Nothing
 637
 638
 639 -- In interfaces, pprAvail gets given the OccName of the "host" thing
 640 pprAvail avail = getPprStyle $ \ sty ->
 641                  if ifaceStyle sty then
 642                     ppr_avail (pprOccName . nameOccName) avail
 643                  else
 644                     ppr_avail ppr avail
 645
 646 ppr_avail pp_name (AvailTC n ns) = hsep [
 647                                      pp_name n,
 648                                      parens  $ hsep $ punctuate comma $
 649                                      map pp_name ns
 650                                    ]
 651 ppr_avail pp_name (Avail n) = pp_name n
 652 \end{code}
 653
 654
 655
 656
 657 %************************************************************************
 658 %*                                                                      *
 659 \subsection{Free variable manipulation}
 660 %*                                                                      *
 661 %************************************************************************
 662
 663 \begin{code}
 664 type FreeVars   = NameSet
 665
 666 plusFV   :: FreeVars -> FreeVars -> FreeVars
 667 addOneFV :: FreeVars -> Name -> FreeVars
 668 unitFV   :: Name -> FreeVars
 669 emptyFVs :: FreeVars
 670 plusFVs  :: [FreeVars] -> FreeVars
 671
 672 isEmptyFVs = isEmptyNameSet
 673 emptyFVs   = emptyNameSet
 674 plusFVs    = unionManyNameSets
 675 plusFV     = unionNameSets
 676
 677 -- No point in adding implicitly imported names to the free-var set
 678 addOneFV s n = addOneToNameSet s n
 679 unitFV     n = unitNameSet n
 680
 681 -- A useful utility
 682 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 683                let
 684                   (ys, fvs_s) = unzip stuff
 685                in
 686                returnRn (ys, plusFVs fvs_s)
 687 \end{code}
 688
 689
 690 %************************************************************************
 691 %*                                                                      *
 692 \subsection{Envt utility functions}
 693 %*                                                                      *
 694 %************************************************************************
 695
 696
 697 \begin{code}
 698 warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d ()
 699
 700 warnUnusedTopNames names
 701   | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
 702   = returnRn ()         -- Don't force ns unless necessary
 703   | otherwise
 704   = warnUnusedBinds (\ is_local -> not is_local) names
 705
 706 warnUnusedLocalBinds ns
 707   | not opt_WarnUnusedBinds = returnRn ()
 708   | otherwise               = warnUnusedBinds (\ is_local -> is_local) ns
 709
 710 warnUnusedMatches names
 711   | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
 712   | otherwise             = returnRn ()
 713
 714 -------------------------
 715
 716 warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d ()
 717 warnUnusedBinds warn_when_local names
 718   = mapRn_ (warnUnusedGroup warn_when_local) groups
 719   where
 720         -- Group by provenance
 721    groups = equivClasses cmp names
 722    name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2
 723
 724    cmp_prov (LocalDef _ _) (NonLocalDef _ _)       = LT
 725    cmp_prov (LocalDef loc1 _) (LocalDef loc2 _)    = loc1 `compare` loc2
 726    cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
 727             (NonLocalDef (UserImport m2 loc2 _) _) =
 728          (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
 729    cmp_prov (NonLocalDef _ _) (LocalDef _ _)       = GT
 730                         -- In-scope NonLocalDefs must have UserImport info on them
 731
 732 -------------------------
 733
 734 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
 735 warnUnusedGroup emit_warning names
 736   | null filtered_names         = returnRn ()
 737   | not (emit_warning is_local) = returnRn ()
 738   | otherwise
 739   = pushSrcLocRn def_loc        $
 740     addWarnRn                   $
 741     sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
 742   where
 743     filtered_names = filter reportable names
 744     name1          = head filtered_names
 745     (is_local, def_loc, msg)
 746         = case getNameProvenance name1 of
 747                 LocalDef loc _                       -> (True, loc, text "Defined but not used")
 748                 NonLocalDef (UserImport mod loc _) _ ->
 749                  (True, loc, text "Imported from" <+> quotes (ppr mod) <+>
 750                                                       text "but not used")
 751                 other -> (False, getSrcLoc name1, text "Strangely defined but not used")
 752
 753     reportable name = case occNameUserString (nameOccName name) of
 754                         ('_' : _) -> False
 755                         zz_other  -> True
 756         -- Haskell 98 encourages compilers to suppress warnings about
 757         -- unused names in a pattern if they start with "_".
 758 \end{code}
 759
 760 \begin{code}
 761 addNameClashErrRn rdr_name (name1:names)
 762   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 763                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 764   where
 765     msg1 = ptext  SLIT("either") <+> mk_ref name1
 766     msgs = [ptext SLIT("    or") <+> mk_ref name | name <- names]
 767     mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name
 768
 769 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 770   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 771         4 (vcat [ppr how_in_scope1,
 772                  ppr how_in_scope2])
 773
 774 shadowedNameWarn shadow
 775   = hsep [ptext SLIT("This binding for"),
 776                quotes (ppr shadow),
 777                ptext SLIT("shadows an existing binding")]
 778
 779 unknownNameErr name
 780   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 781   where
 782     flavour = occNameFlavour (rdrNameOcc name)
 783
 784 qualNameErr descriptor (name,loc)
 785   = pushSrcLocRn loc $
 786     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 787                      quotes (ppr name),
 788                      ptext SLIT("in"),
 789                      descriptor])
 790
 791 dupNamesErr descriptor ((name,loc) : dup_things)
 792   = pushSrcLocRn loc $
 793     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 794               $$
 795               (ptext SLIT("in") <+> descriptor))
 796 \end{code}