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 filterAvail :: RdrNameIE        -- Wanted
 589             -> AvailInfo        -- Available
 590             -> Maybe AvailInfo  -- Resulting available;
 591                                 -- Nothing if (any of the) wanted stuff isn't there
 592
 593 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 594   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 595   | otherwise    = Nothing
 596   where
 597     is_wanted name = nameOccName name `elem` wanted_occs
 598     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 599     avail_occs     = map nameOccName ns
 600     wanted_occs    = map rdrNameOcc (want:wants)
 601
 602 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 603                                                   Just (AvailTC n [n])
 604
 605 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 606
 607 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 608 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 609                                                 where
 610                                                   wanted n = nameOccName n == occ
 611                                                   occ      = rdrNameOcc v
 612         -- The second equation happens if we import a class op, thus
 613         --      import A( op )
 614         -- where op is a class operation
 615
 616 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 617         -- We don't complain even if the IE says T(..), but
 618         -- no constrs/class ops of T are available
 619         -- Instead that's caught with a warning by the caller
 620
 621 filterAvail ie avail = Nothing
 622
 623 -------------------------------------
 624 groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
 625   -- Group by module and sort by occurrence
 626   -- This keeps the list in canonical order
 627 groupAvails this_mod avails
 628   = [ (mkSysModuleNameFS fs, sortLt lt avails)
 629     | (fs,avails) <- fmToList groupFM
 630     ]
 631   where
 632     groupFM :: FiniteMap FastString Avails
 633         -- Deliberately use the FastString so we
 634         -- get a canonical ordering
 635     groupFM = foldl add emptyFM avails
 636
 637     add env avail = addToFM_C combine env mod_fs [avail']
 638                   where
 639                     mod_fs = moduleNameFS (moduleName avail_mod)
 640                     avail_mod = case nameModule_maybe (availName avail) of
 641                                           Just m  -> m
 642                                           Nothing -> this_mod
 643                     combine old _ = avail':old
 644                     avail'        = sortAvail avail
 645
 646     a1 `lt` a2 = occ1 < occ2
 647                where
 648                  occ1  = nameOccName (availName a1)
 649                  occ2  = nameOccName (availName a2)
 650
 651 sortAvail :: AvailInfo -> AvailInfo
 652 -- Sort the sub-names into canonical order.
 653 -- The canonical order has the "main name" at the beginning
 654 -- (if it's there at all)
 655 sortAvail (Avail n) = Avail n
 656 sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
 657                          | otherwise   = AvailTC n (    sortLt lt ns)
 658                          where
 659                            n1 `lt` n2 = nameOccName n1 < nameOccName n2
 660 \end{code}
 661
 662
 663 %************************************************************************
 664 %*                                                                      *
 665 \subsection{Free variable manipulation}
 666 %*                                                                      *
 667 %************************************************************************
 668
 669 \begin{code}
 670 -- A useful utility
 671 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 672                let
 673                   (ys, fvs_s) = unzip stuff
 674                in
 675                returnRn (ys, plusFVs fvs_s)
 676 \end{code}
 677
 678
 679 %************************************************************************
 680 %*                                                                      *
 681 \subsection{Envt utility functions}
 682 %*                                                                      *
 683 %************************************************************************
 684
 685 \begin{code}
 686 warnUnusedModules :: [ModuleName] -> RnM d ()
 687 warnUnusedModules mods
 688   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 689     if warn then mapRn_ (addWarnRn . unused_mod) mods
 690             else returnRn ()
 691   where
 692     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 693                            text "is imported, but nothing from it is used",
 694                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 695                                    quotes (ppr m))]
 696
 697 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 698 warnUnusedImports names
 699   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 700     if warn then warnUnusedBinds names else returnRn ()
 701
 702 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 703 warnUnusedLocalBinds names
 704   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 705     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 706             else returnRn ()
 707
 708 warnUnusedMatches names
 709   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 710     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 711             else returnRn ()
 712
 713 -------------------------
 714
 715 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 716 warnUnusedBinds names
 717   = mapRn_ warnUnusedGroup  groups
 718   where
 719         -- Group by provenance
 720    groups = equivClasses cmp names
 721    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 722
 723
 724 -------------------------
 725
 726 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 727 warnUnusedGroup names
 728   | null filtered_names  = returnRn ()
 729   | not is_local         = returnRn ()
 730   | otherwise
 731   = pushSrcLocRn def_loc        $
 732     addWarnRn                   $
 733     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 734   where
 735     filtered_names = filter reportable names
 736     (name1, prov1) = head filtered_names
 737     (is_local, def_loc, msg)
 738         = case prov1 of
 739                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 740
 741                 NonLocalDef (UserImport mod loc _)
 742                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 743
 744     reportable (name,_) = case occNameUserString (nameOccName name) of
 745                                 ('_' : _) -> False
 746                                 zz_other  -> True
 747         -- Haskell 98 encourages compilers to suppress warnings about
 748         -- unused names in a pattern if they start with "_".
 749 \end{code}
 750
 751 \begin{code}
 752 addNameClashErrRn rdr_name (np1:nps)
 753   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 754                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 755   where
 756     msg1 = ptext  SLIT("either") <+> mk_ref np1
 757     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 758     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 759
 760 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 761   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 762         4 (vcat [ppr how_in_scope1,
 763                  ppr how_in_scope2])
 764
 765 shadowedNameWarn shadow
 766   = hsep [ptext SLIT("This binding for"),
 767                quotes (ppr shadow),
 768                ptext SLIT("shadows an existing binding")]
 769
 770 unknownNameErr name
 771   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 772   where
 773     flavour = occNameFlavour (rdrNameOcc name)
 774
 775 qualNameErr descriptor (name,loc)
 776   = pushSrcLocRn loc $
 777     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 778                      quotes (ppr name),
 779                      ptext SLIT("in"),
 780                      descriptor])
 781
 782 dupNamesErr descriptor ((name,loc) : dup_things)
 783   = pushSrcLocRn loc $
 784     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 785               $$
 786               (ptext SLIT("in") <+> descriptor))
 787 \end{code}