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, 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
 269 \begin{code}
 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       = mkLocalName 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   = getLocalNameEnv             `thenRn` \ name_env ->
 375     setLocalNameEnv (addListToRdrEnv name_env pairs)
 376                     enclosed_scope
 377   where
 378     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 379
 380 bindLocalNamesFV names enclosed_scope
 381   = bindLocalNames names $
 382     enclosed_scope `thenRn` \ (thing, fvs) ->
 383     returnRn (thing, delListFromNameSet fvs names)
 384
 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 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 408         -- This tiresome function is used only in rnDecl on InstDecl
 409 extendTyVarEnvFVRn tyvars enclosed_scope
 410   = bindLocalNames tyvars enclosed_scope        `thenRn` \ (thing, fvs) ->
 411     returnRn (thing, delListFromNameSet fvs tyvars)
 412
 413 bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
 414               -> ([HsTyVarBndr Name] -> RnMS a)
 415               -> RnMS a
 416 bindTyVarsRn doc_str tyvar_names enclosed_scope
 417   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 418     enclosed_scope tyvars
 419
 420 -- Gruesome name: return Names as well as HsTyVars
 421 bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
 422               -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
 423               -> RnMS a
 424 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 425   = getSrcLocRn                                 `thenRn` \ loc ->
 426     let
 427         located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
 428     in
 429     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 430     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 431
 432 bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
 433               -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
 434               -> RnMS (a, FreeVars)
 435 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 436   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 437     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 438     returnRn (thing, delListFromNameSet fvs names)
 439
 440 bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
 441               -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
 442               -> RnMS (a, FreeVars)
 443 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 444   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 445     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 446     returnRn (thing, delListFromNameSet fvs names)
 447
 448 bindNakedTyVarsFVRn :: SDoc -> [RdrName]
 449                     -> ([Name] -> RnMS (a, FreeVars))
 450                     -> RnMS (a, FreeVars)
 451 bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
 452   = getSrcLocRn                                 `thenRn` \ loc ->
 453     let
 454         located_tyvars = [(tv, loc) | tv <- tyvar_names]
 455     in
 456     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 457     enclosed_scope names                        `thenRn` \ (thing, fvs) ->
 458     returnRn (thing, delListFromNameSet fvs names)
 459
 460
 461 -------------------------------------
 462 checkDupOrQualNames, checkDupNames :: SDoc
 463                                    -> [(RdrName, SrcLoc)]
 464                                    -> RnM d ()
 465         -- Works in any variant of the renamer monad
 466
 467 checkDupOrQualNames doc_str rdr_names_w_loc
 468   =     -- Check for use of qualified names
 469     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 470     checkDupNames doc_str rdr_names_w_loc
 471   where
 472     quals = filter (isQual . fst) rdr_names_w_loc
 473
 474 checkDupNames doc_str rdr_names_w_loc
 475   =     -- Check for duplicated names in a binding group
 476     mapRn_ (dupNamesErr doc_str) dups
 477   where
 478     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{GlobalRdrEnv}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 490 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 491
 492 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv
 493 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 494
 495 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 496 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 497
 498 combine_globals :: [(Name,Provenance)]  -- Old
 499                 -> [(Name,Provenance)]  -- New
 500                 -> [(Name,Provenance)]
 501 combine_globals ns_old ns_new   -- ns_new is often short
 502   = foldr add ns_old ns_new
 503   where
 504     add n ns | any (is_duplicate n) ns_old = map (choose n) ns  -- Eliminate duplicates
 505              | otherwise                   = n:ns
 506
 507     choose n m | n `beats` m = n
 508                | otherwise   = m
 509
 510     (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
 511
 512     is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
 513     is_duplicate (n1,LocalDef) (n2,LocalDef) = False
 514     is_duplicate (n1,_)        (n2,_)        = n1 == n2
 515 \end{code}
 516
 517 We treat two bindings of a locally-defined name as a duplicate,
 518 because they might be two separate, local defns and we want to report
 519 and error for that, {\em not} eliminate a duplicate.
 520
 521 On the other hand, if you import the same name from two different
 522 import statements, we {\em do} want to eliminate the duplicate, not report
 523 an error.
 524
 525 If a module imports itself then there might be a local defn and an imported
 526 defn of the same name; in this case the names will compare as equal, but
 527 will still have different provenances.
 528
 529
 530 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 531 its unqualified name is in scope.  This is put as a boolean flag in
 532 the @Name@'s provenance to guide whether or not to print the name qualified
 533 in error messages.
 534
 535 \begin{code}
 536 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 537 unQualInScope env
 538   = (`elemNameSet` unqual_names)
 539   where
 540     unqual_names :: NameSet
 541     unqual_names = foldRdrEnv add emptyNameSet env
 542     add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
 543     add _        _          unquals                     = unquals
 544 \end{code}
 545
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection{Avails}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 \begin{code}
 554 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 555 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 556 -- Added SOF 4/97
 557 #ifdef DEBUG
 558 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 559 #endif
 560
 561 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 562 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 563
 564 emptyAvailEnv = emptyNameEnv
 565 unitAvailEnv :: AvailInfo -> AvailEnv
 566 unitAvailEnv a = unitNameEnv (availName a) a
 567
 568 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 569 plusAvailEnv = plusNameEnv_C plusAvail
 570
 571 availEnvElts = nameEnvElts
 572
 573 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 574 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 575
 576 availsToNameSet :: [AvailInfo] -> NameSet
 577 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 578
 579 availName :: GenAvailInfo name -> name
 580 availName (Avail n)     = n
 581 availName (AvailTC n _) = n
 582
 583 availNames :: GenAvailInfo name -> [name]
 584 availNames (Avail n)      = [n]
 585 availNames (AvailTC n ns) = ns
 586
 587 -------------------------------------
 588 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
 589 addSysAvails avail          []  = avail
 590 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
 591
 592 -------------------------------------
 593 filterAvail :: RdrNameIE        -- Wanted
 594             -> AvailInfo        -- Available
 595             -> Maybe AvailInfo  -- Resulting available;
 596                                 -- Nothing if (any of the) wanted stuff isn't there
 597
 598 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 599   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 600   | otherwise    = Nothing
 601   where
 602     is_wanted name = nameOccName name `elem` wanted_occs
 603     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 604     avail_occs     = map nameOccName ns
 605     wanted_occs    = map rdrNameOcc (want:wants)
 606
 607 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 608                                                   Just (AvailTC n [n])
 609
 610 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 611
 612 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 613 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 614                                                 where
 615                                                   wanted n = nameOccName n == occ
 616                                                   occ      = rdrNameOcc v
 617         -- The second equation happens if we import a class op, thus
 618         --      import A( op )
 619         -- where op is a class operation
 620
 621 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 622         -- We don't complain even if the IE says T(..), but
 623         -- no constrs/class ops of T are available
 624         -- Instead that's caught with a warning by the caller
 625
 626 filterAvail ie avail = Nothing
 627
 628 -------------------------------------
 629 groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
 630   -- Group by module and sort by occurrence
 631   -- This keeps the list in canonical order
 632 groupAvails this_mod avails
 633   = [ (mkSysModuleNameFS fs, sortLt lt avails)
 634     | (fs,avails) <- fmToList groupFM
 635     ]
 636   where
 637     groupFM :: FiniteMap FastString Avails
 638         -- Deliberately use the FastString so we
 639         -- get a canonical ordering
 640     groupFM = foldl add emptyFM avails
 641
 642     add env avail = addToFM_C combine env mod_fs [avail']
 643                   where
 644                     mod_fs = moduleNameFS (moduleName avail_mod)
 645                     avail_mod = case nameModule_maybe (availName avail) of
 646                                           Just m  -> m
 647                                           Nothing -> this_mod
 648                     combine old _ = avail':old
 649                     avail'        = sortAvail avail
 650
 651     a1 `lt` a2 = occ1 < occ2
 652                where
 653                  occ1  = nameOccName (availName a1)
 654                  occ2  = nameOccName (availName a2)
 655
 656 sortAvail :: AvailInfo -> AvailInfo
 657 -- Sort the sub-names into canonical order.
 658 -- The canonical order has the "main name" at the beginning
 659 -- (if it's there at all)
 660 sortAvail (Avail n) = Avail n
 661 sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
 662                          | otherwise   = AvailTC n (    sortLt lt ns)
 663                          where
 664                            n1 `lt` n2 = nameOccName n1 < nameOccName n2
 665 \end{code}
 666
 667
 668 %************************************************************************
 669 %*                                                                      *
 670 \subsection{Free variable manipulation}
 671 %*                                                                      *
 672 %************************************************************************
 673
 674 \begin{code}
 675 -- A useful utility
 676 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 677                let
 678                   (ys, fvs_s) = unzip stuff
 679                in
 680                returnRn (ys, plusFVs fvs_s)
 681 \end{code}
 682
 683
 684 %************************************************************************
 685 %*                                                                      *
 686 \subsection{Envt utility functions}
 687 %*                                                                      *
 688 %************************************************************************
 689
 690 \begin{code}
 691 warnUnusedModules :: [ModuleName] -> RnM d ()
 692 warnUnusedModules mods
 693   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 694     if warn then mapRn_ (addWarnRn . unused_mod) mods
 695             else returnRn ()
 696   where
 697     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 698                            text "is imported, but nothing from it is used",
 699                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 700                                    quotes (ppr m))]
 701
 702 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 703 warnUnusedImports names
 704   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 705     if warn then warnUnusedBinds names else returnRn ()
 706
 707 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 708 warnUnusedLocalBinds names
 709   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 710     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 711             else returnRn ()
 712
 713 warnUnusedMatches names
 714   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 715     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 716             else returnRn ()
 717
 718 -------------------------
 719
 720 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 721 warnUnusedBinds names
 722   = mapRn_ warnUnusedGroup  groups
 723   where
 724         -- Group by provenance
 725    groups = equivClasses cmp names
 726    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 727
 728
 729 -------------------------
 730
 731 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 732 warnUnusedGroup names
 733   | null filtered_names  = returnRn ()
 734   | not is_local         = returnRn ()
 735   | otherwise
 736   = pushSrcLocRn def_loc        $
 737     addWarnRn                   $
 738     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 739   where
 740     filtered_names = filter reportable names
 741     (name1, prov1) = head filtered_names
 742     (is_local, def_loc, msg)
 743         = case prov1 of
 744                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 745
 746                 NonLocalDef (UserImport mod loc _)
 747                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 748
 749     reportable (name,_) = case occNameUserString (nameOccName name) of
 750                                 ('_' : _) -> False
 751                                 zz_other  -> True
 752         -- Haskell 98 encourages compilers to suppress warnings about
 753         -- unused names in a pattern if they start with "_".
 754 \end{code}
 755
 756 \begin{code}
 757 addNameClashErrRn rdr_name (np1:nps)
 758   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 759                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 760   where
 761     msg1 = ptext  SLIT("either") <+> mk_ref np1
 762     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 763     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 764
 765 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 766   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 767         4 (vcat [ppr how_in_scope1,
 768                  ppr how_in_scope2])
 769
 770 shadowedNameWarn shadow
 771   = hsep [ptext SLIT("This binding for"),
 772                quotes (ppr shadow),
 773                ptext SLIT("shadows an existing binding")]
 774
 775 unknownNameErr name
 776   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 777   where
 778     flavour = occNameFlavour (rdrNameOcc name)
 779
 780 qualNameErr descriptor (name,loc)
 781   = pushSrcLocRn loc $
 782     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 783                      quotes (ppr name),
 784                      ptext SLIT("in"),
 785                      descriptor])
 786
 787 dupNamesErr descriptor ((name,loc) : dup_things)
 788   = pushSrcLocRn loc $
 789     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 790               $$
 791               (ptext SLIT("in") <+> descriptor))
 792 \end{code}