ghc/compiler/rename/RnEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnEnv]{Environment manipulation for the renamer monad}
   5
   6 \begin{code}
   7 module RnEnv where              -- Export everything
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn
  12 import RdrHsSyn         ( RdrNameIE )
  13 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
  14                           mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
  15                         )
  16 import HsTypes          ( hsTyVarName, replaceTyVarName )
  17 import HscTypes         ( Provenance(..), pprNameProvenance, hasBetterProv,
  18                           ImportReason(..), GlobalRdrEnv, AvailEnv,
  19                           AvailInfo, Avails, GenAvailInfo(..) )
  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 isQual 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   = getModeRn   `thenRn` \ mode ->
 175     case mode of
 176         InterfaceMode -> lookupIfaceName rdr_name
 177
 178         SourceMode    -> -- Source mode, so look up a *qualified* version
 179                          -- of the name, so that we get the right one even
 180                          -- if there are many with the same occ name
 181                          -- There must *be* a binding
 182                 getModuleRn             `thenRn` \ mod ->
 183                 getGlobalNameEnv        `thenRn` \ global_env ->
 184                 lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
 185
 186 -- lookupSigOccRn is used for type signatures and pragmas
 187 -- Is this valid?
 188 --   module A
 189 --      import M( f )
 190 --      f :: Int -> Int
 191 --      f x = x
 192 -- It's clear that the 'f' in the signature must refer to A.f
 193 -- The Haskell98 report does not stipulate this, but it will!
 194 -- So we must treat the 'f' in the signature in the same way
 195 -- as the binding occurrence of 'f', using lookupBndrRn
 196 lookupSigOccRn :: RdrName -> RnMS Name
 197 lookupSigOccRn = lookupBndrRn
 198
 199 -- lookupOccRn looks up an occurrence of a RdrName
 200 lookupOccRn :: RdrName -> RnMS Name
 201 lookupOccRn rdr_name
 202   = getLocalNameEnv                     `thenRn` \ local_env ->
 203     case lookupRdrEnv local_env rdr_name of
 204           Just name -> returnRn name
 205           Nothing   -> lookupGlobalOccRn rdr_name
 206
 207 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 208 -- environment.  It's used only for
 209 --      record field names
 210 --      class op names in class and instance decls
 211
 212 lookupGlobalOccRn rdr_name
 213   = getModeRn           `thenRn` \ mode ->
 214     case mode of
 215         SourceMode    -> getGlobalNameEnv                       `thenRn` \ global_env ->
 216                          lookupSrcName global_env rdr_name
 217
 218         InterfaceMode -> lookupIfaceName rdr_name
 219
 220 lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
 221 -- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
 222 lookupSrcName global_env rdr_name
 223   | isOrig rdr_name     -- Can occur in source code too
 224   = lookupOrigName rdr_name
 225
 226   | otherwise
 227   = case lookupRdrEnv global_env rdr_name of
 228         Just [(name,_)]         -> returnRn name
 229         Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
 230                                    returnRn name
 231         Nothing                 -> failWithRn (mkUnboundName rdr_name)
 232                                               (unknownNameErr rdr_name)
 233
 234 lookupOrigName :: RdrName -> RnM d Name
 235 lookupOrigName rdr_name
 236   = ASSERT( isOrig rdr_name )
 237     newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 238
 239 lookupIfaceUnqual :: RdrName -> RnM d Name
 240 lookupIfaceUnqual rdr_name
 241   = ASSERT( isUnqual rdr_name )
 242         -- An Unqual is allowed; interface files contain
 243         -- unqualified names for locally-defined things, such as
 244         -- constructors of a data type.
 245     getModuleRn                         `thenRn ` \ mod ->
 246     newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
 247
 248 lookupIfaceName :: RdrName -> RnM d Name
 249 lookupIfaceName rdr_name
 250   | isUnqual rdr_name = lookupIfaceUnqual rdr_name
 251   | otherwise         = lookupOrigName rdr_name
 252 \end{code}
 253
 254 @lookupOrigName@ takes an RdrName representing an {\em original}
 255 name, and adds it to the occurrence pool so that it'll be loaded
 256 later.  This is used when language constructs (such as monad
 257 comprehensions, overloaded literals, or deriving clauses) require some
 258 stuff to be loaded that isn't explicitly mentioned in the code.
 259
 260 This doesn't apply in interface mode, where everything is explicit,
 261 but we don't check for this case: it does no harm to record an
 262 ``extra'' occurrence and @lookupOrigNames@ isn't used much in
 263 interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
 264 calls it at all I think).
 265
 266   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 267
 268 For List and Tuple types it's important to get the correct
 269 @isLocallyDefined@ flag, which is used in turn when deciding
 270 whether there are any instance decls in this module are ``special''.
 271 The name cache should have the correct provenance, though.
 272
 273 \begin{code}
 274 lookupOrigNames :: [RdrName] -> RnM d NameSet
 275 lookupOrigNames rdr_names
 276   = mapRn lookupOrigName rdr_names      `thenRn` \ names ->
 277     returnRn (mkNameSet names)
 278 \end{code}
 279
 280 lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
 281 It ensures that the module is set correctly in the name cache, and sets the provenance
 282 on the returned name too.  The returned name will end up actually in the type, class,
 283 or instance.
 284
 285 \begin{code}
 286 lookupSysBinder rdr_name
 287   = ASSERT( isUnqual rdr_name )
 288     getModuleRn                         `thenRn` \ mod ->
 289     getSrcLocRn                         `thenRn` \ loc ->
 290     newTopBinder mod rdr_name loc
 291 \end{code}
 292
 293
 294
 295 %*********************************************************
 296 %*                                                      *
 297 \subsection{Binding}
 298 %*                                                      *
 299 %*********************************************************
 300
 301 \begin{code}
 302 newLocalsRn :: [(RdrName,SrcLoc)]
 303             -> RnMS [Name]
 304 newLocalsRn rdr_names_w_loc
 305  =  getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 306     let
 307         n          = length rdr_names_w_loc
 308         (us', us1) = splitUniqSupply us
 309         uniqs      = uniqsFromSupply n us1
 310         names      = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 311                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 312                      ]
 313     in
 314     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 315     returnRn names
 316
 317
 318 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 319                     -> [(RdrName,SrcLoc)]
 320                     -> ([Name] -> RnMS a)
 321                     -> RnMS a
 322 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 323   = getModeRn                           `thenRn` \ mode ->
 324     getLocalNameEnv                     `thenRn` \ name_env ->
 325
 326         -- Check for duplicate names
 327     checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 328
 329     doptRn Opt_WarnNameShadowing                `thenRn` \ warn_shadow ->
 330
 331         -- Warn about shadowing, but only in source modules
 332     (case mode of
 333         SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
 334         other                              -> returnRn ()
 335     )                                   `thenRn_`
 336
 337     newLocalsRn rdr_names_w_loc         `thenRn` \ names ->
 338     let
 339         new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 340     in
 341     setLocalNameEnv new_local_env (enclosed_scope names)
 342
 343   where
 344     check_shadow name_env (rdr_name,loc)
 345         = case lookupRdrEnv name_env rdr_name of
 346                 Nothing   -> returnRn ()
 347                 Just name -> pushSrcLocRn loc $
 348                              addWarnRn (shadowedNameWarn rdr_name)
 349
 350 bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
 351   -- A specialised variant when renaming stuff from interface
 352   -- files (of which there is a lot)
 353   --    * one at a time
 354   --    * no checks for shadowing
 355   --    * always imported
 356   --    * deal with free vars
 357 bindCoreLocalRn rdr_name enclosed_scope
 358   = getSrcLocRn                 `thenRn` \ loc ->
 359     getLocalNameEnv             `thenRn` \ name_env ->
 360     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 361     let
 362         (us', us1) = splitUniqSupply us
 363         uniq       = uniqFromSupply us1
 364         name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
 365     in
 366     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 367     let
 368         new_name_env = extendRdrEnv name_env rdr_name name
 369     in
 370     setLocalNameEnv new_name_env (enclosed_scope name)
 371
 372 bindCoreLocalsRn []     thing_inside = thing_inside []
 373 bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b        $ \ name' ->
 374                                        bindCoreLocalsRn bs      $ \ names' ->
 375                                        thing_inside (name':names')
 376
 377 bindLocalNames names enclosed_scope
 378   = getLocalNameEnv             `thenRn` \ name_env ->
 379     setLocalNameEnv (addListToRdrEnv name_env pairs)
 380                     enclosed_scope
 381   where
 382     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 383
 384 bindLocalNamesFV names enclosed_scope
 385   = bindLocalNames names $
 386     enclosed_scope `thenRn` \ (thing, fvs) ->
 387     returnRn (thing, delListFromNameSet fvs names)
 388
 389
 390 -------------------------------------
 391 bindLocalRn doc rdr_name enclosed_scope
 392   = getSrcLocRn                                 `thenRn` \ loc ->
 393     bindLocatedLocalsRn doc [(rdr_name,loc)]    $ \ (n:ns) ->
 394     ASSERT( null ns )
 395     enclosed_scope n
 396
 397 bindLocalsRn doc rdr_names enclosed_scope
 398   = getSrcLocRn         `thenRn` \ loc ->
 399     bindLocatedLocalsRn doc
 400                         (rdr_names `zip` repeat loc)
 401                         enclosed_scope
 402
 403         -- binLocalsFVRn is the same as bindLocalsRn
 404         -- except that it deals with free vars
 405 bindLocalsFVRn doc rdr_names enclosed_scope
 406   = bindLocalsRn doc rdr_names          $ \ names ->
 407     enclosed_scope names                `thenRn` \ (thing, fvs) ->
 408     returnRn (thing, delListFromNameSet fvs names)
 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 (isQual . 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   = (`elemNameSet` unqual_names)
 543   where
 544     unqual_names :: NameSet
 545     unqual_names = foldRdrEnv add emptyNameSet env
 546     add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
 547     add _        _          unquals                     = unquals
 548 \end{code}
 549
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsection{Avails}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 \begin{code}
 558 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 559 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 560 -- Added SOF 4/97
 561 #ifdef DEBUG
 562 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 563 #endif
 564
 565 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 566 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 567
 568 emptyAvailEnv = emptyNameEnv
 569 unitAvailEnv :: AvailInfo -> AvailEnv
 570 unitAvailEnv a = unitNameEnv (availName a) a
 571
 572 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 573 plusAvailEnv = plusNameEnv_C plusAvail
 574
 575 availEnvElts = nameEnvElts
 576
 577 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 578 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 579
 580 availsToNameSet :: [AvailInfo] -> NameSet
 581 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 582
 583 availName :: GenAvailInfo name -> name
 584 availName (Avail n)     = n
 585 availName (AvailTC n _) = n
 586
 587 availNames :: GenAvailInfo name -> [name]
 588 availNames (Avail n)      = [n]
 589 availNames (AvailTC n ns) = ns
 590
 591 -------------------------------------
 592 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
 593 addSysAvails avail          []  = avail
 594 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
 595
 596 -------------------------------------
 597 filterAvail :: RdrNameIE        -- Wanted
 598             -> AvailInfo        -- Available
 599             -> Maybe AvailInfo  -- Resulting available;
 600                                 -- Nothing if (any of the) wanted stuff isn't there
 601
 602 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 603   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 604   | otherwise    = Nothing
 605   where
 606     is_wanted name = nameOccName name `elem` wanted_occs
 607     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 608     avail_occs     = map nameOccName ns
 609     wanted_occs    = map rdrNameOcc (want:wants)
 610
 611 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 612                                                   Just (AvailTC n [n])
 613
 614 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 615
 616 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 617 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 618                                                 where
 619                                                   wanted n = nameOccName n == occ
 620                                                   occ      = rdrNameOcc v
 621         -- The second equation happens if we import a class op, thus
 622         --      import A( op )
 623         -- where op is a class operation
 624
 625 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 626         -- We don't complain even if the IE says T(..), but
 627         -- no constrs/class ops of T are available
 628         -- Instead that's caught with a warning by the caller
 629
 630 filterAvail ie avail = Nothing
 631
 632 -------------------------------------
 633 groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
 634   -- Group by module and sort by occurrence
 635   -- This keeps the list in canonical order
 636 groupAvails this_mod avails
 637   = [ (mkSysModuleNameFS fs, sortLt lt avails)
 638     | (fs,avails) <- fmToList groupFM
 639     ]
 640   where
 641     groupFM :: FiniteMap FastString Avails
 642         -- Deliberately use the FastString so we
 643         -- get a canonical ordering
 644     groupFM = foldl add emptyFM avails
 645
 646     add env avail = addToFM_C combine env mod_fs [avail']
 647                   where
 648                     mod_fs = moduleNameFS (moduleName avail_mod)
 649                     avail_mod = case nameModule_maybe (availName avail) of
 650                                           Just m  -> m
 651                                           Nothing -> this_mod
 652                     combine old _ = avail':old
 653                     avail'        = sortAvail avail
 654
 655     a1 `lt` a2 = occ1 < occ2
 656                where
 657                  occ1  = nameOccName (availName a1)
 658                  occ2  = nameOccName (availName a2)
 659
 660 sortAvail :: AvailInfo -> AvailInfo
 661 -- Sort the sub-names into canonical order.
 662 -- The canonical order has the "main name" at the beginning
 663 -- (if it's there at all)
 664 sortAvail (Avail n) = Avail n
 665 sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
 666                          | otherwise   = AvailTC n (    sortLt lt ns)
 667                          where
 668                            n1 `lt` n2 = nameOccName n1 < nameOccName n2
 669 \end{code}
 670
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection{Free variable manipulation}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 \begin{code}
 679 -- A useful utility
 680 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 681                let
 682                   (ys, fvs_s) = unzip stuff
 683                in
 684                returnRn (ys, plusFVs fvs_s)
 685 \end{code}
 686
 687
 688 %************************************************************************
 689 %*                                                                      *
 690 \subsection{Envt utility functions}
 691 %*                                                                      *
 692 %************************************************************************
 693
 694 \begin{code}
 695 warnUnusedModules :: [ModuleName] -> RnM d ()
 696 warnUnusedModules mods
 697   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 698     if warn then mapRn_ (addWarnRn . unused_mod) mods
 699             else returnRn ()
 700   where
 701     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 702                            text "is imported, but nothing from it is used",
 703                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 704                                    quotes (ppr m))]
 705
 706 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 707 warnUnusedImports names
 708   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 709     if warn then warnUnusedBinds names else returnRn ()
 710
 711 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 712 warnUnusedLocalBinds names
 713   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 714     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 715             else returnRn ()
 716
 717 warnUnusedMatches names
 718   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 719     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 720             else returnRn ()
 721
 722 -------------------------
 723
 724 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 725 warnUnusedBinds names
 726   = mapRn_ warnUnusedGroup  groups
 727   where
 728         -- Group by provenance
 729    groups = equivClasses cmp names
 730    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 731
 732
 733 -------------------------
 734
 735 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 736 warnUnusedGroup names
 737   | null filtered_names  = returnRn ()
 738   | not is_local         = returnRn ()
 739   | otherwise
 740   = pushSrcLocRn def_loc        $
 741     addWarnRn                   $
 742     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 743   where
 744     filtered_names = filter reportable names
 745     (name1, prov1) = head filtered_names
 746     (is_local, def_loc, msg)
 747         = case prov1 of
 748                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 749
 750                 NonLocalDef (UserImport mod loc _)
 751                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 752
 753     reportable (name,_) = case occNameUserString (nameOccName name) of
 754                                 ('_' : _) -> False
 755                                 zz_other  -> True
 756         -- Haskell 98 encourages compilers to suppress warnings about
 757         -- unused names in a pattern if they start with "_".
 758 \end{code}
 759
 760 \begin{code}
 761 addNameClashErrRn rdr_name (np1:nps)
 762   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 763                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 764   where
 765     msg1 = ptext  SLIT("either") <+> mk_ref np1
 766     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 767     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 768
 769 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 770   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 771         4 (vcat [ppr how_in_scope1,
 772                  ppr how_in_scope2])
 773
 774 shadowedNameWarn shadow
 775   = hsep [ptext SLIT("This binding for"),
 776                quotes (ppr shadow),
 777                ptext SLIT("shadows an existing binding")]
 778
 779 unknownNameErr name
 780   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 781   where
 782     flavour = occNameFlavour (rdrNameOcc name)
 783
 784 qualNameErr descriptor (name,loc)
 785   = pushSrcLocRn loc $
 786     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 787                      quotes (ppr name),
 788                      ptext SLIT("in"),
 789                      descriptor])
 790
 791 dupNamesErr descriptor ((name,loc) : dup_things)
 792   = pushSrcLocRn loc $
 793     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 794               $$
 795               (ptext SLIT("in") <+> descriptor))
 796 \end{code}