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