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