ghc/compiler/rename/RnEnv.lhs

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