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
  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                 lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
 184
 185 -- lookupSigOccRn is used for type signatures and pragmas
 186 -- Is this valid?
 187 --   module A
 188 --      import M( f )
 189 --      f :: Int -> Int
 190 --      f x = x
 191 -- It's clear that the 'f' in the signature must refer to A.f
 192 -- The Haskell98 report does not stipulate this, but it will!
 193 -- So we must treat the 'f' in the signature in the same way
 194 -- as the binding occurrence of 'f', using lookupBndrRn
 195 lookupSigOccRn :: RdrName -> RnMS Name
 196 lookupSigOccRn = lookupBndrRn
 197
 198 -- lookupOccRn looks up an occurrence of a RdrName
 199 lookupOccRn :: RdrName -> RnMS Name
 200 lookupOccRn rdr_name
 201   = getLocalNameEnv                     `thenRn` \ local_env ->
 202     case lookupRdrEnv local_env rdr_name of
 203           Just name -> returnRn name
 204           Nothing   -> lookupGlobalOccRn rdr_name
 205
 206 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 207 -- environment.  It's used only for
 208 --      record field names
 209 --      class op names in class and instance decls
 210
 211 lookupGlobalOccRn rdr_name
 212   | isOrig rdr_name     -- Can occur in source code too
 213   = lookupOrigName rdr_name
 214
 215   | otherwise
 216   = getModeRn           `thenRn` \ mode ->
 217     case mode of
 218         SourceMode    -> lookupSrcGlobalOcc rdr_name
 219         InterfaceMode -> lookupIfaceUnqual rdr_name
 220
 221 lookupSrcGlobalOcc rdr_name
 222   -- Lookup a source-code rdr-name; may be qualified or not
 223   = getGlobalNameEnv                    `thenRn` \ global_env ->
 224     case lookupRdrEnv global_env rdr_name of
 225         Just [(name,_)]         -> returnRn name
 226         Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
 227                                    returnRn name
 228         Nothing                 -> failWithRn (mkUnboundName rdr_name)
 229                                               (unknownNameErr rdr_name)
 230
 231 lookupOrigName :: RdrName -> RnM d Name
 232 lookupOrigName rdr_name
 233   = ASSERT( isOrig rdr_name )
 234     newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
 235
 236 lookupIfaceUnqual :: RdrName -> RnM d Name
 237 lookupIfaceUnqual rdr_name
 238   = ASSERT( isUnqual rdr_name )
 239         -- An Unqual is allowed; interface files contain
 240         -- unqualified names for locally-defined things, such as
 241         -- constructors of a data type.
 242     getModuleRn                         `thenRn ` \ mod ->
 243     newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
 244
 245 lookupIfaceName :: RdrName -> RnM d Name
 246 lookupIfaceName rdr_name
 247   | isUnqual rdr_name = lookupIfaceUnqual rdr_name
 248   | otherwise         = lookupOrigName rdr_name
 249
 250 lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
 251   -- Checks that there is exactly one
 252 lookupGlobalRn global_env rdr_name
 253   = case lookupRdrEnv global_env rdr_name of
 254         Just [(name,_)]         -> returnRn (Just name)
 255         Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
 256                                    returnRn (Just name)
 257         Nothing                 -> returnRn Nothing
 258 \end{code}
 259
 260 @lookupOrigName@ takes an RdrName representing an {\em original}
 261 name, and adds it to the occurrence pool so that it'll be loaded
 262 later.  This is used when language constructs (such as monad
 263 comprehensions, overloaded literals, or deriving clauses) require some
 264 stuff to be loaded that isn't explicitly mentioned in the code.
 265
 266 This doesn't apply in interface mode, where everything is explicit,
 267 but we don't check for this case: it does no harm to record an
 268 ``extra'' occurrence and @lookupOrigNames@ isn't used much in
 269 interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
 270 calls it at all I think).
 271
 272   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 273
 274 For List and Tuple types it's important to get the correct
 275 @isLocallyDefined@ flag, which is used in turn when deciding
 276 whether there are any instance decls in this module are ``special''.
 277 The name cache should have the correct provenance, though.
 278
 279 \begin{code}
 280 lookupOrigNames :: [RdrName] -> RnM d NameSet
 281 lookupOrigNames rdr_names
 282   = mapRn lookupOrigName rdr_names      `thenRn` \ names ->
 283     returnRn (mkNameSet names)
 284 \end{code}
 285
 286 lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
 287 It ensures that the module is set correctly in the name cache, and sets the provenance
 288 on the returned name too.  The returned name will end up actually in the type, class,
 289 or instance.
 290
 291 \begin{code}
 292 lookupSysBinder rdr_name
 293   = ASSERT( isUnqual rdr_name )
 294     getModuleRn                         `thenRn` \ mod ->
 295     getSrcLocRn                         `thenRn` \ loc ->
 296     newTopBinder mod rdr_name loc
 297 \end{code}
 298
 299
 300
 301 %*********************************************************
 302 %*                                                      *
 303 \subsection{Binding}
 304 %*                                                      *
 305 %*********************************************************
 306
 307 \begin{code}
 308 newLocalsRn :: [(RdrName,SrcLoc)]
 309             -> RnMS [Name]
 310 newLocalsRn rdr_names_w_loc
 311  =  getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 312     let
 313         n          = length rdr_names_w_loc
 314         (us', us1) = splitUniqSupply us
 315         uniqs      = uniqsFromSupply n us1
 316         names      = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 317                      | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 318                      ]
 319     in
 320     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 321     returnRn names
 322
 323
 324 bindLocatedLocalsRn :: SDoc     -- Documentation string for error message
 325                     -> [(RdrName,SrcLoc)]
 326                     -> ([Name] -> RnMS a)
 327                     -> RnMS a
 328 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 329   = getModeRn                           `thenRn` \ mode ->
 330     getLocalNameEnv                     `thenRn` \ name_env ->
 331
 332         -- Check for duplicate names
 333     checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
 334
 335     doptRn Opt_WarnNameShadowing                `thenRn` \ warn_shadow ->
 336
 337         -- Warn about shadowing, but only in source modules
 338     (case mode of
 339         SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
 340         other                              -> returnRn ()
 341     )                                   `thenRn_`
 342
 343     newLocalsRn rdr_names_w_loc         `thenRn` \ names ->
 344     let
 345         new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
 346     in
 347     setLocalNameEnv new_local_env (enclosed_scope names)
 348
 349   where
 350     check_shadow name_env (rdr_name,loc)
 351         = case lookupRdrEnv name_env rdr_name of
 352                 Nothing   -> returnRn ()
 353                 Just name -> pushSrcLocRn loc $
 354                              addWarnRn (shadowedNameWarn rdr_name)
 355
 356 bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
 357   -- A specialised variant when renaming stuff from interface
 358   -- files (of which there is a lot)
 359   --    * one at a time
 360   --    * no checks for shadowing
 361   --    * always imported
 362   --    * deal with free vars
 363 bindCoreLocalRn rdr_name enclosed_scope
 364   = getSrcLocRn                 `thenRn` \ loc ->
 365     getLocalNameEnv             `thenRn` \ name_env ->
 366     getNameSupplyRn             `thenRn` \ (us, cache, ipcache) ->
 367     let
 368         (us', us1) = splitUniqSupply us
 369         uniq       = uniqFromSupply us1
 370         name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
 371     in
 372     setNameSupplyRn (us', cache, ipcache)       `thenRn_`
 373     let
 374         new_name_env = extendRdrEnv name_env rdr_name name
 375     in
 376     setLocalNameEnv new_name_env (enclosed_scope name)
 377
 378 bindCoreLocalsRn []     thing_inside = thing_inside []
 379 bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b        $ \ name' ->
 380                                        bindCoreLocalsRn bs      $ \ names' ->
 381                                        thing_inside (name':names')
 382
 383 bindLocalNames names enclosed_scope
 384   = getLocalNameEnv             `thenRn` \ name_env ->
 385     setLocalNameEnv (addListToRdrEnv name_env pairs)
 386                     enclosed_scope
 387   where
 388     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 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 bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a
 412 bindUVarRn = bindCoreLocalRn
 413
 414 -------------------------------------
 415 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
 416         -- This tiresome function is used only in rnDecl on InstDecl
 417 extendTyVarEnvFVRn tyvars enclosed_scope
 418   = bindLocalNames tyvars enclosed_scope        `thenRn` \ (thing, fvs) ->
 419     returnRn (thing, delListFromNameSet fvs tyvars)
 420
 421 bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
 422               -> ([HsTyVarBndr Name] -> RnMS a)
 423               -> RnMS a
 424 bindTyVarsRn doc_str tyvar_names enclosed_scope
 425   = bindTyVars2Rn doc_str tyvar_names   $ \ names tyvars ->
 426     enclosed_scope tyvars
 427
 428 -- Gruesome name: return Names as well as HsTyVars
 429 bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
 430               -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
 431               -> RnMS a
 432 bindTyVars2Rn doc_str tyvar_names enclosed_scope
 433   = getSrcLocRn                                 `thenRn` \ loc ->
 434     let
 435         located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
 436     in
 437     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 438     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 439
 440 bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
 441               -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
 442               -> RnMS (a, FreeVars)
 443 bindTyVarsFVRn doc_str rdr_names enclosed_scope
 444   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 445     enclosed_scope tyvars               `thenRn` \ (thing, fvs) ->
 446     returnRn (thing, delListFromNameSet fvs names)
 447
 448 bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
 449               -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
 450               -> RnMS (a, FreeVars)
 451 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
 452   = bindTyVars2Rn doc_str rdr_names     $ \ names tyvars ->
 453     enclosed_scope names tyvars         `thenRn` \ (thing, fvs) ->
 454     returnRn (thing, delListFromNameSet fvs names)
 455
 456 bindNakedTyVarsFVRn :: SDoc -> [RdrName]
 457                     -> ([Name] -> RnMS (a, FreeVars))
 458                     -> RnMS (a, FreeVars)
 459 bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
 460   = getSrcLocRn                                 `thenRn` \ loc ->
 461     let
 462         located_tyvars = [(tv, loc) | tv <- tyvar_names]
 463     in
 464     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 465     enclosed_scope names                        `thenRn` \ (thing, fvs) ->
 466     returnRn (thing, delListFromNameSet fvs names)
 467
 468
 469 -------------------------------------
 470 checkDupOrQualNames, checkDupNames :: SDoc
 471                                    -> [(RdrName, SrcLoc)]
 472                                    -> RnM d ()
 473         -- Works in any variant of the renamer monad
 474
 475 checkDupOrQualNames doc_str rdr_names_w_loc
 476   =     -- Check for use of qualified names
 477     mapRn_ (qualNameErr doc_str) quals  `thenRn_`
 478     checkDupNames doc_str rdr_names_w_loc
 479   where
 480     quals = filter (isQual . fst) rdr_names_w_loc
 481
 482 checkDupNames doc_str rdr_names_w_loc
 483   =     -- Check for duplicated names in a binding group
 484     mapRn_ (dupNamesErr doc_str) dups
 485   where
 486     (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
 487 \end{code}
 488
 489
 490 %************************************************************************
 491 %*                                                                      *
 492 \subsection{GlobalRdrEnv}
 493 %*                                                                      *
 494 %************************************************************************
 495
 496 \begin{code}
 497 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 498 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 499
 500 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv
 501 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
 502
 503 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
 504 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
 505
 506 combine_globals :: [(Name,Provenance)]  -- Old
 507                 -> [(Name,Provenance)]  -- New
 508                 -> [(Name,Provenance)]
 509 combine_globals ns_old ns_new   -- ns_new is often short
 510   = foldr add ns_old ns_new
 511   where
 512     add n ns | any (is_duplicate n) ns_old = map (choose n) ns  -- Eliminate duplicates
 513              | otherwise                   = n:ns
 514
 515     choose n m | n `beats` m = n
 516                | otherwise   = m
 517
 518     (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
 519
 520     is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
 521     is_duplicate (n1,LocalDef) (n2,LocalDef) = False
 522     is_duplicate (n1,_)        (n2,_)        = n1 == n2
 523 \end{code}
 524
 525 We treat two bindings of a locally-defined name as a duplicate,
 526 because they might be two separate, local defns and we want to report
 527 and error for that, {\em not} eliminate a duplicate.
 528
 529 On the other hand, if you import the same name from two different
 530 import statements, we {\em do} want to eliminate the duplicate, not report
 531 an error.
 532
 533 If a module imports itself then there might be a local defn and an imported
 534 defn of the same name; in this case the names will compare as equal, but
 535 will still have different provenances.
 536
 537
 538 @unQualInScope@ returns a function that takes a @Name@ and tells whether
 539 its unqualified name is in scope.  This is put as a boolean flag in
 540 the @Name@'s provenance to guide whether or not to print the name qualified
 541 in error messages.
 542
 543 \begin{code}
 544 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 545 unQualInScope env
 546   = lookup
 547   where
 548     lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
 549                            Just [(name',_)] -> name == name'
 550                            other            -> False
 551 \end{code}
 552
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsection{Avails}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \begin{code}
 561 plusAvail (Avail n1)       (Avail n2)       = Avail n1
 562 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 563 -- Added SOF 4/97
 564 #ifdef DEBUG
 565 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 566 #endif
 567
 568 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 569 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 570
 571 emptyAvailEnv = emptyNameEnv
 572 unitAvailEnv :: AvailInfo -> AvailEnv
 573 unitAvailEnv a = unitNameEnv (availName a) a
 574
 575 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 576 plusAvailEnv = plusNameEnv_C plusAvail
 577
 578 availEnvElts = nameEnvElts
 579
 580 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 581 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 582
 583 availsToNameSet :: [AvailInfo] -> NameSet
 584 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 585
 586 availName :: GenAvailInfo name -> name
 587 availName (Avail n)     = n
 588 availName (AvailTC n _) = n
 589
 590 availNames :: GenAvailInfo name -> [name]
 591 availNames (Avail n)      = [n]
 592 availNames (AvailTC n ns) = ns
 593
 594 -------------------------------------
 595 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
 596 addSysAvails avail          []  = avail
 597 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
 598
 599 -------------------------------------
 600 filterAvail :: RdrNameIE        -- Wanted
 601             -> AvailInfo        -- Available
 602             -> Maybe AvailInfo  -- Resulting available;
 603                                 -- Nothing if (any of the) wanted stuff isn't there
 604
 605 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
 606   | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
 607   | otherwise    = Nothing
 608   where
 609     is_wanted name = nameOccName name `elem` wanted_occs
 610     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 611     avail_occs     = map nameOccName ns
 612     wanted_occs    = map rdrNameOcc (want:wants)
 613
 614 filterAvail (IEThingAbs _) (AvailTC n ns)       = ASSERT( n `elem` ns )
 615                                                   Just (AvailTC n [n])
 616
 617 filterAvail (IEThingAbs _) avail@(Avail n)      = Just avail            -- Type synonyms
 618
 619 filterAvail (IEVar _)      avail@(Avail n)      = Just avail
 620 filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
 621                                                 where
 622                                                   wanted n = nameOccName n == occ
 623                                                   occ      = rdrNameOcc v
 624         -- The second equation happens if we import a class op, thus
 625         --      import A( op )
 626         -- where op is a class operation
 627
 628 filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 629         -- We don't complain even if the IE says T(..), but
 630         -- no constrs/class ops of T are available
 631         -- Instead that's caught with a warning by the caller
 632
 633 filterAvail ie avail = Nothing
 634
 635 -------------------------------------
 636 groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
 637   -- Group by module and sort by occurrence
 638   -- This keeps the list in canonical order
 639 groupAvails this_mod avails
 640   = [ (mkSysModuleNameFS fs, sortLt lt avails)
 641     | (fs,avails) <- fmToList groupFM
 642     ]
 643   where
 644     groupFM :: FiniteMap FastString Avails
 645         -- Deliberately use the FastString so we
 646         -- get a canonical ordering
 647     groupFM = foldl add emptyFM avails
 648
 649     add env avail = addToFM_C combine env mod_fs [avail']
 650                   where
 651                     mod_fs = moduleNameFS (moduleName avail_mod)
 652                     avail_mod = case nameModule_maybe (availName avail) of
 653                                           Just m  -> m
 654                                           Nothing -> this_mod
 655                     combine old _ = avail':old
 656                     avail'        = sortAvail avail
 657
 658     a1 `lt` a2 = occ1 < occ2
 659                where
 660                  occ1  = nameOccName (availName a1)
 661                  occ2  = nameOccName (availName a2)
 662
 663 sortAvail :: AvailInfo -> AvailInfo
 664 -- Sort the sub-names into canonical order.
 665 -- The canonical order has the "main name" at the beginning
 666 -- (if it's there at all)
 667 sortAvail (Avail n) = Avail n
 668 sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
 669                          | otherwise   = AvailTC n (    sortLt lt ns)
 670                          where
 671                            n1 `lt` n2 = nameOccName n1 < nameOccName n2
 672 \end{code}
 673
 674
 675 %************************************************************************
 676 %*                                                                      *
 677 \subsection{Free variable manipulation}
 678 %*                                                                      *
 679 %************************************************************************
 680
 681 \begin{code}
 682 -- A useful utility
 683 mapFvRn f xs = mapRn f xs       `thenRn` \ stuff ->
 684                let
 685                   (ys, fvs_s) = unzip stuff
 686                in
 687                returnRn (ys, plusFVs fvs_s)
 688 \end{code}
 689
 690
 691 %************************************************************************
 692 %*                                                                      *
 693 \subsection{Envt utility functions}
 694 %*                                                                      *
 695 %************************************************************************
 696
 697 \begin{code}
 698 warnUnusedModules :: [ModuleName] -> RnM d ()
 699 warnUnusedModules mods
 700   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 701     if warn then mapRn_ (addWarnRn . unused_mod) mods
 702             else returnRn ()
 703   where
 704     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
 705                            text "is imported, but nothing from it is used",
 706                          parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
 707                                    quotes (ppr m))]
 708
 709 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 710 warnUnusedImports names
 711   = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
 712     if warn then warnUnusedBinds names else returnRn ()
 713
 714 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 715 warnUnusedLocalBinds names
 716   = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
 717     if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
 718             else returnRn ()
 719
 720 warnUnusedMatches names
 721   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
 722     if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
 723             else returnRn ()
 724
 725 -------------------------
 726
 727 warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
 728 warnUnusedBinds names
 729   = mapRn_ warnUnusedGroup  groups
 730   where
 731         -- Group by provenance
 732    groups = equivClasses cmp names
 733    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
 734
 735
 736 -------------------------
 737
 738 warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
 739 warnUnusedGroup names
 740   | null filtered_names  = returnRn ()
 741   | not is_local         = returnRn ()
 742   | otherwise
 743   = pushSrcLocRn def_loc        $
 744     addWarnRn                   $
 745     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
 746   where
 747     filtered_names = filter reportable names
 748     (name1, prov1) = head filtered_names
 749     (is_local, def_loc, msg)
 750         = case prov1 of
 751                 LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 752
 753                 NonLocalDef (UserImport mod loc _) _
 754                         -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 755
 756     reportable (name,_) = case occNameUserString (nameOccName name) of
 757                                 ('_' : _) -> False
 758                                 zz_other  -> True
 759         -- Haskell 98 encourages compilers to suppress warnings about
 760         -- unused names in a pattern if they start with "_".
 761 \end{code}
 762
 763 \begin{code}
 764 addNameClashErrRn rdr_name (np1:nps)
 765   = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 766                     ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
 767   where
 768     msg1 = ptext  SLIT("either") <+> mk_ref np1
 769     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
 770     mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
 771
 772 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
 773   = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
 774         4 (vcat [ppr how_in_scope1,
 775                  ppr how_in_scope2])
 776
 777 shadowedNameWarn shadow
 778   = hsep [ptext SLIT("This binding for"),
 779                quotes (ppr shadow),
 780                ptext SLIT("shadows an existing binding")]
 781
 782 unknownNameErr name
 783   = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
 784   where
 785     flavour = occNameFlavour (rdrNameOcc name)
 786
 787 qualNameErr descriptor (name,loc)
 788   = pushSrcLocRn loc $
 789     addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
 790                      quotes (ppr name),
 791                      ptext SLIT("in"),
 792                      descriptor])
 793
 794 dupNamesErr descriptor ((name,loc) : dup_things)
 795   = pushSrcLocRn loc $
 796     addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
 797               $$
 798               (ptext SLIT("in") <+> descriptor))
 799 \end{code}