ghc/compiler/rename/RnEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnEnv]{Environment manipulation for the renamer monad}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnEnv where              -- Export everything
  10
  11 IMP_Ubiq()
  12
  13 import CmdLineOpts      ( opt_WarnNameShadowing, opt_IgnoreIfacePragmas )
  14 import HsSyn
  15 import RdrHsSyn         ( RdrName(..), SYN_IE(RdrNameIE),
  16                           rdrNameOcc, isQual, qual
  17                         )
  18 import HsTypes          ( getTyVarName, replaceTyVarName )
  19 import RnMonad
  20 import Name             ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..),
  21                           occNameString, occNameFlavour,
  22                           SYN_IE(NameSet), emptyNameSet, addListToNameSet,
  23                           mkLocalName, mkGlobalName, modAndOcc,
  24                           isLocalName, isWiredInName, nameOccName, setNameProvenance,
  25                           pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance
  26                         )
  27 import TyCon            ( TyCon )
  28 import TysWiredIn       ( tupleTyCon, listTyCon, charTyCon, intTyCon )
  29 import FiniteMap
  30 import Unique           ( Unique, unboundKey )
  31 import Maybes           ( maybeToBool )
  32 import UniqSupply
  33 import SrcLoc           ( SrcLoc, noSrcLoc )
  34 import Pretty
  35 import PprStyle         ( PprStyle(..) )
  36 import Util             ( panic, removeDups, pprTrace, assertPanic )
  37 \end{code}
  38
  39
  40
  41 %*********************************************************
  42 %*                                                      *
  43 \subsection{Making new names}
  44 %*                                                      *
  45 %*********************************************************
  46
  47 \begin{code}
  48 newGlobalName :: Module -> OccName -> RnM s d Name
  49 newGlobalName mod occ
  50   =     -- First check the cache
  51     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  52     case lookupFM cache (mod,occ) of
  53
  54         -- A hit in the cache!  Return it, but change the src loc
  55         -- of the thing we've found if this is a second definition site
  56         -- (that is, if loc /= NoSrcLoc)
  57         Just name ->  returnRn name
  58
  59         -- Miss in the cache, so build a new original name,
  60         -- and put it in the cache
  61         Nothing        ->
  62             let
  63                 (us', us1) = splitUniqSupply us
  64                 uniq       = getUnique us1
  65                 name       = mkGlobalName uniq mod occ VanillaDefn Implicit
  66                 cache'     = addToFM cache (mod,occ) name
  67             in
  68             setNameSupplyRn (us', inst_ns, cache')              `thenRn_`
  69             returnRn name
  70
  71 newLocallyDefinedGlobalName :: Module -> OccName
  72                             -> (Name -> ExportFlag) -> SrcLoc
  73                             -> RnM s d Name
  74 newLocallyDefinedGlobalName mod occ rec_exp_fn loc
  75   =     -- First check the cache
  76     getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
  77
  78         -- We are at the binding site for a locally-defined thing, so
  79         -- you might think it can't be in the cache, but it can if it's a
  80         -- wired in thing. In that case we need to use the correct unique etc...
  81         -- so all we do is replace its provenance.
  82         -- If it's not in the cache we put it there with the correct provenance.
  83         -- The idea is that, after all this, the cache
  84         -- will contain a Name with the correct Provenance (i.e. Local)
  85     let
  86         provenance = LocalDef (rec_exp_fn new_name) loc
  87         (us', us1) = splitUniqSupply us
  88         uniq       = getUnique us1
  89         new_name   = case lookupFM cache (mod,occ) of
  90                         Just name -> setNameProvenance name provenance
  91                         Nothing   -> mkGlobalName uniq mod occ VanillaDefn provenance
  92         cache'     = addToFM cache (mod,occ) new_name
  93     in
  94     setNameSupplyRn (us', inst_ns, cache')              `thenRn_`
  95     returnRn new_name
  96
  97 -- newDfunName is used to allocate a name for the dictionary function for
  98 -- a local instance declaration.  No need to put it in the cache (I think!).
  99 newDfunName ::  SrcLoc -> RnMS s Name
 100 newDfunName src_loc
 101   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 102     getModuleRn                 `thenRn` \ mod_name ->
 103     let
 104         (us', us1) = splitUniqSupply us
 105         uniq       = getUnique us1
 106         dfun_name  = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns)))
 107                                   VanillaDefn (LocalDef Exported src_loc)
 108    in
 109    setNameSupplyRn (us', inst_ns+1, cache)      `thenRn_`
 110    returnRn dfun_name
 111
 112
 113 newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
 114 newLocalNames rdr_names
 115   = getNameSupplyRn             `thenRn` \ (us, inst_ns, cache) ->
 116     let
 117         n          = length rdr_names
 118         (us', us1) = splitUniqSupply us
 119         uniqs      = getUniques n us1
 120         locals     = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 121                      | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
 122                      ]
 123     in
 124     setNameSupplyRn (us', inst_ns, cache)       `thenRn_`
 125     returnRn locals
 126
 127 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
 128 -- during compiler debugging.
 129 mkUnboundName :: RdrName -> Name
 130 mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
 131
 132 isUnboundName :: Name -> Bool
 133 isUnboundName name = uniqueOf name == unboundKey
 134 \end{code}
 135
 136 \begin{code}
 137 bindLocatedLocalsRn :: String           -- Documentation string for error message
 138                     -> [(RdrName,SrcLoc)]
 139                     -> ([Name] -> RnMS s a)
 140                     -> RnMS s a
 141 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 142   =     -- Check for use of qualified names
 143     mapRn (qualNameErr doc_str) quals   `thenRn_`
 144         -- Check for dupicated names in a binding group
 145     mapRn (dupNamesErr doc_str) dups    `thenRn_`
 146
 147     getNameEnv                  `thenRn` \ name_env ->
 148     (if opt_WarnNameShadowing
 149      then
 150         mapRn (check_shadow name_env) rdr_names_w_loc
 151      else
 152         returnRn []
 153     )                                   `thenRn_`
 154
 155     newLocalNames rdr_names_w_loc       `thenRn` \ names ->
 156     let
 157         new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
 158     in
 159     setNameEnv new_name_env (enclosed_scope names)
 160   where
 161     quals         = filter (isQual.fst) rdr_names_w_loc
 162     (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
 163     check_shadow name_env (rdr_name,loc)
 164         = case lookupFM name_env rdr_name of
 165                 Nothing   -> returnRn ()
 166                 Just name -> pushSrcLocRn loc $
 167                              addWarnRn (shadowedNameWarn rdr_name)
 168
 169 bindLocalsRn doc_str rdr_names enclosed_scope
 170   = getSrcLocRn         `thenRn` \ loc ->
 171     bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope
 172
 173 bindTyVarsRn doc_str tyvar_names enclosed_scope
 174   = getSrcLocRn                                 `thenRn` \ loc ->
 175     let
 176         located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
 177     in
 178     bindLocatedLocalsRn doc_str located_tyvars  $ \ names ->
 179     enclosed_scope (zipWith replaceTyVarName tyvar_names names)
 180 \end{code}
 181
 182
 183 %*********************************************************
 184 %*                                                      *
 185 \subsection{Looking up names}
 186 %*                                                      *
 187 %*********************************************************
 188
 189 Looking up a name in the RnEnv.
 190
 191 \begin{code}
 192 lookupRn :: RdrName -> RnMS s Name
 193 lookupRn rdr_name
 194   = getNameEnv          `thenRn` \ name_env ->
 195     case lookupFM name_env rdr_name of
 196
 197         -- Found it!
 198         Just name -> returnRn name
 199
 200         -- Not found
 201         Nothing -> getModeRn    `thenRn` \ mode ->
 202                    case mode of
 203                         -- Not found when processing source code; so fail
 204                         SourceMode    -> failWithRn (mkUnboundName rdr_name)
 205                                                     (unknownNameErr rdr_name)
 206
 207                         -- Not found when processing an imported declaration,
 208                         -- so we create a new name for the purpose
 209                         InterfaceMode ->
 210                             case rdr_name of
 211
 212                                 Qual mod_name occ -> newGlobalName mod_name occ
 213
 214                                 -- An Unqual is allowed; interface files contain
 215                                 -- unqualified names for locally-defined things, such as
 216                                 -- constructors of a data type.
 217                                 Unqual occ -> getModuleRn       `thenRn ` \ mod_name ->
 218                                               newGlobalName mod_name occ
 219
 220
 221 -- Just like lookupRn except that we record the occurrence too
 222 -- Perhaps surprisingly, even wired-in names are recorded.
 223 -- Why?  So that we know which wired-in names are referred to when
 224 -- deciding which instance declarations to import.
 225 lookupOccRn :: RdrName -> RnMS s Name
 226 lookupOccRn rdr_name
 227   = lookupRn rdr_name   `thenRn` \ name ->
 228     if isLocalName name then
 229         returnRn name
 230     else
 231         addOccurrenceName Compulsory name               `thenRn_`
 232         returnRn name
 233
 234 -- lookupOptionalOccRn is similar, but it's used in places where
 235 -- we don't *have* to find a definition for the thing.
 236 lookupOptionalOccRn :: RdrName -> RnMS s Name
 237 lookupOptionalOccRn rdr_name
 238   = lookupRn rdr_name   `thenRn` \ name ->
 239     if opt_IgnoreIfacePragmas || isLocalName name then
 240                 -- Never look for optional things if we're
 241                 -- ignoring optional input interface information
 242         returnRn name
 243     else
 244         addOccurrenceName Optional name         `thenRn_`
 245         returnRn name
 246
 247 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
 248 -- adds it to the occurrence pool so that it'll be loaded later.  This is
 249 -- used when language constructs (such as monad comprehensions, overloaded literals,
 250 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
 251 -- mentioned in the code.
 252 --
 253 -- This doesn't apply in interface mode, where everything is explicit, but
 254 -- we don't check for this case: it does no harm to record an "extra" occurrence
 255 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
 256 -- Nothing clause of rnDerivs that calls it at all I think.
 257 --
 258 -- For List and Tuple types it's important to get the correct
 259 -- isLocallyDefined flag, which is used in turn when deciding
 260 -- whether there are any instance decls in this module are "special".
 261 -- The name cache should have the correct provenance, though.
 262
 263 lookupImplicitOccRn :: RdrName -> RnMS s Name
 264 lookupImplicitOccRn (Qual mod occ)
 265  = newGlobalName mod occ                `thenRn` \ name ->
 266    addOccurrenceName Compulsory name    `thenRn_`
 267    returnRn name
 268
 269 addImplicitOccRn :: Name -> RnM s d ()
 270 addImplicitOccRn name = addOccurrenceName Compulsory name
 271
 272 addImplicitOccsRn :: [Name] -> RnM s d ()
 273 addImplicitOccsRn names = addOccurrenceNames Compulsory names
 274
 275 listType_RDR    = qual (modAndOcc listType_name)
 276 tupleType_RDR n = qual (modAndOcc (tupleType_name n))
 277
 278 charType_name    = getName charTyCon
 279 listType_name    = getName listTyCon
 280 tupleType_name n = getName (tupleTyCon n)
 281 \end{code}
 282
 283 \begin{code}
 284 lookupFixity :: RdrName -> RnMS s Fixity
 285 lookupFixity rdr_name
 286   = getFixityEnv        `thenRn` \ fixity_env ->
 287     returnRn (lookupFixityEnv fixity_env rdr_name)
 288 \end{code}
 289
 290
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{Envt utility functions}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 ===============  RnEnv  ================
 299 \begin{code}
 300 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
 301   = plusNameEnvRn n1 n2         `thenRn` \ n ->
 302     plusFixityEnvRn f1 f2       `thenRn` \ f ->
 303     returnRn (RnEnv n f)
 304 \end{code}
 305
 306 ===============  NameEnv  ================
 307 \begin{code}
 308 plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv
 309 plusNameEnvRn n1 n2
 310   = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2)              `thenRn_`
 311     returnRn (n1 `plusFM` n2)
 312
 313 addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
 314 addOneToNameEnvRn env rdr_name name
 315   = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name)   `thenRn_`
 316     returnRn (addToFM env rdr_name name)
 317
 318 lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
 319 lookupNameEnv = lookupFM
 320 \end{code}
 321
 322 ===============  FixityEnv  ================
 323 \begin{code}
 324 plusFixityEnvRn f1 f2
 325   = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2)         `thenRn_`
 326     returnRn (f1 `plusFM` f2)
 327
 328 addOneToFixityEnvRn env rdr_name fixity
 329   = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity)    `thenRn_`
 330     returnRn (addToFM env rdr_name fixity)
 331
 332 lookupFixityEnv env rdr_name
 333   = case lookupFM env rdr_name of
 334         Just (fixity,_) -> fixity
 335         Nothing         -> Fixity 9 InfixL              -- Default case
 336
 337 bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool
 338 bad_fix (f1,_) (f2,_) = f1 /= f2
 339
 340 pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty
 341 pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov
 342 \end{code}
 343
 344
 345
 346 ===============  Avails  ================
 347 \begin{code}
 348 emptyModuleAvails :: ModuleAvails
 349 plusModuleAvails ::  ModuleAvails ->  ModuleAvails ->  ModuleAvails
 350 lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo]
 351
 352 emptyModuleAvails = emptyFM
 353 plusModuleAvails  = plusFM_C (++)
 354 lookupModuleAvails = lookupFM
 355 \end{code}
 356
 357
 358 ===============  AvailInfo  ================
 359 \begin{code}
 360 plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2))
 361 plusAvail a NotAvailable = a
 362 plusAvail NotAvailable a = a
 363
 364 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 365 addAvailToNameSet names NotAvailable = names
 366 addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns)
 367
 368 availsToNameSet :: [AvailInfo] -> NameSet
 369 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
 370
 371 availNames :: AvailInfo -> [Name]
 372 availNames NotAvailable      = []
 373 availNames (Avail n ns) = n:ns
 374
 375 filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo
 376 filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable
 377 filterAvail (IEThingWith _ wanted) (Avail n ns)
 378   | sub_names_ok = Avail n (filter is_wanted ns)
 379   | otherwise    = NotAvailable
 380   where
 381     is_wanted name = nameOccName name `elem` wanted_occs
 382     sub_names_ok   = all (`elem` avail_occs) wanted_occs
 383     wanted_occs    = map rdrNameOcc wanted
 384     avail_occs     = map nameOccName ns
 385
 386
 387 filterAvail (IEThingAll _) avail        = avail
 388 filterAvail ie             (Avail n ns) = Avail n []            -- IEThingAbs and IEVar
 389
 390 -- pprAvail gets given the OccName of the "host" thing
 391 pprAvail sty NotAvailable = ppStr "NotAvailable"
 392 pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n),
 393                                    ppStr "(",
 394                                    ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
 395                                    ppStr ")"]
 396 \end{code}
 397
 398
 399
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsection{Finite map utilities}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407
 408 Generally useful function on finite maps to check for overlap.
 409
 410 \begin{code}
 411 conflictsFM :: Ord a
 412             => (b->b->Bool)             -- False <=> no conflict; you can pick either
 413             -> FiniteMap a b -> FiniteMap a b
 414             -> [(a,(b,b))]
 415 conflictsFM bad fm1 fm2
 416   = filter (\(a,(b1,b2)) -> bad b1 b2)
 417            (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
 418
 419 conflictFM :: Ord a
 420            => (b->b->Bool)
 421            -> FiniteMap a b -> a -> b
 422            -> [(a,(b,b))]
 423 conflictFM bad fm key elt
 424   = case lookupFM fm key of
 425         Just elt' | bad elt elt' -> [(key,(elt,elt'))]
 426         other                    -> []
 427 \end{code}
 428
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsection{Envt utility functions}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436
 437 \begin{code}
 438 nameClashErr (rdr_name, (name1,name2)) sty
 439   = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name])
 440         4 (ppAboves [pprNameProvenance sty name1,
 441                      pprNameProvenance sty name2])
 442
 443 fixityClashErr (rdr_name, (fp1,fp2)) sty
 444   = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name])
 445         4 (ppAboves [pprFixityProvenance sty fp1,
 446                      pprFixityProvenance sty fp2])
 447
 448 shadowedNameWarn shadow sty
 449   = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow]
 450
 451 unknownNameErr name sty
 452   = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name]
 453   where
 454     flavour = occNameFlavour (rdrNameOcc name)
 455
 456 qualNameErr descriptor (name,loc)
 457   = pushSrcLocRn loc $
 458     addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ",
 459                                  ppStr descriptor, ppStr ": ",
 460                                  pprNonSymOcc sty (rdrNameOcc name) ])
 461
 462 dupNamesErr descriptor ((name,loc) : dup_things)
 463   = pushSrcLocRn loc $
 464     addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `",
 465                                  ppr sty name, ppStr "' in ",
 466                                  ppStr descriptor])
 467 \end{code}
 468