#include "HsVersions.h"
module RnMonad (
- RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
+ SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R,
initRn, thenRn, thenRn_, andRn, returnRn,
- mapRn, mapAndUnzipRn,
+ mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
failButContinueRn, warnAndContinueRn,
- setExtraRn, getExtraRn,
+ setExtraRn, getExtraRn, getRnEnv,
getModuleRn, pushSrcLocRn, getSrcLocRn,
getSourceRn, getOccurrenceUpRn,
- getImplicitUpRn, ImplicitEnv(..),
+ getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv,
rnGetUnique, rnGetUniques,
newLocalNames,
- lookupValue, lookupValueMaybe,
- lookupTyCon, lookupClass, lookupClassOp,
+ lookupValue, lookupConstr, lookupField, lookupClassOp,
+ lookupTyCon, lookupClass, lookupTyConOrClass,
extendSS2, extendSS,
- TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
- lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
+ SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
+ lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
+
+ fixIO
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(GHCbase(fixIO))
import SST
import HsSyn ( FixityDecl )
import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
mkRnImplicitTyCon, mkRnImplicitClass,
- isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnClassOp,
- RenamedFixityDecl(..) )
-import RnUtils ( RnEnv(..), extendLocalRnEnv,
- lookupRnEnv, lookupTcRnEnv,
- unknownNameErr, badClassOpErr, qualNameErr,
- dupNamesErr, shadowedNameWarn )
+ isRnLocal, isRnWired, isRnTyCon, isRnClass,
+ isRnTyConOrClass, isRnConstr, isRnField,
+ isRnClassOp, RenamedFixityDecl(..) )
+import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv,
+ lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
+ qualNameErr, dupNamesErr
+ )
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import CmdLineOpts ( opt_WarnNameShadowing )
-import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
+import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
+ SYN_IE(Error), SYN_IE(Warning)
+ )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} )
import Maybes ( assocMaybe )
-import Name ( Module(..), RdrName(..), isQual,
- Name, mkLocalName, mkImplicitName
+import Name ( SYN_IE(Module), RdrName(..), isQual,
+ OrigName(..), Name, mkLocalName, mkImplicitName,
+ getOccName, pprNonSym
)
-import Outputable ( getOccName )
-import PprStyle ( PprStyle )
-import Pretty ( Pretty(..), PrettyRep )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelMods ( pRELUDE )
+--import PprStyle{-ToDo:rm-}
+--import Outputable{-ToDo:rm-}
+import Pretty
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
-import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
+import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
import Unique ( Unique )
import Util
= RnSource (MutableVar s (Bag (RnName, RdrName)))
-- Renaming source; returning occurences
- | RnIface (MutableVar s ImplicitEnv)
+ | RnIface BuiltinNames BuiltinKeys
+ (MutableVar s ImplicitEnv)
-- Renaming interface; creating and returning implicit names
- -- One map for Values and one for TyCons/Classes.
-
-type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
+ -- ImplicitEnv: one map for Values and one for TyCons/Classes.
+type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
+emptyImplicitEnv :: ImplicitEnv
+emptyImplicitEnv = (emptyFM, emptyFM)
--- With a builtin polymorphic type for _runSST the type for
--- initTc should use RnM s r instead of RnM _RealWorld r
+-- With a builtin polymorphic type for runSST the type for
+-- initTc should use RnM s r instead of RnM RealWorld r
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD GHCbuiltins.RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
initRn :: Bool -- True => Source; False => Iface
-> Module
-> RnEnv
-> UniqSupply
- -> RnM _RealWorld r
+ -> RnM REAL_WORLD r
-> (r, Bag Error, Bag Warning)
initRn source mod env us do_rn
- = _runSST (
+ = runSST (
newMutVarSST emptyBag `thenSST` \ occ_var ->
- newMutVarSST (emptyFM,emptyFM) `thenSST` \ imp_var ->
+ newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
newMutVarSST us `thenSST` \ us_var ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
let
mode = if source then
RnSource occ_var
else
- RnIface imp_var
+ RnIface builtinNameMaps builtinKeysMap imp_var
rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
in
= f x `thenRn` \ (r1, r2) ->
mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
returnRn (r1:rs1, r2:rs2)
+
+mapAndUnzip3Rn f [] = returnRn ([],[],[])
+mapAndUnzip3Rn f (x:xs)
+ = f x `thenRn` \ (r1, r2, r3) ->
+ mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
+ returnRn (r1:rs1, r2:rs2, r3:rs3)
\end{code}
For errors and warnings ...
\begin{code}
+getRnEnv :: RnMonad x s RnEnv
+getRnEnv (RnDown _ _ _ _ env _ _)
+ = returnSST env
+
setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
setExtraRn x m (RnDown _ mod locn mode env us errs)
= m (RnDown x mod locn mode env us errs)
= returnSST locn
getSourceRn :: RnMonad x s Bool
-getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
-getSourceRn (RnDown _ _ _ (RnIface _) _ _ _) = returnSST False
+getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
+getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
= readMutVarSST occ_var
-getOccurrenceUpRn (RnDown _ _ _ (RnIface _) _ _ _)
+getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
= panic "getOccurrenceUpRn:RnIface"
-getImplicitUpRn :: RnMonad x s (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
-getImplicitUpRn (RnDown _ _ _ (RnIface imp_var) _ _ _)
+getImplicitUpRn :: RnMonad x s ImplicitEnv
+getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
= readMutVarSST imp_var
getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
= panic "getImplicitUpRn:RnIface"
-> RnMonad x s [RnName]
newLocalNames str names_w_loc
- = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
- mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
+ = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
+ mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
mkLocalNames these
where
- quals = filter (isQual.fst) names_w_loc
+ quals = filter (isQual.fst) names_w_loc
(these, dups) = removeDups cmp_fst names_w_loc
cmp_fst (a,_) (b,_) = cmp a b
\end{code}
mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
mkLocalNames names_w_locs
= rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
- returnRn (zipWithEqual new_local uniqs names_w_locs)
+ returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
where
new_local uniq (Unqual str, srcloc)
- = mkRnName (mkLocalName uniq str srcloc)
+ = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
\end{code}
\begin{code}
lookupValue :: RdrName -> RnMonad x s RnName
+lookupConstr :: RdrName -> RnMonad x s RnName
+lookupField :: RdrName -> RnMonad x s RnName
lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
lookupValue rdr
- = lookup_val rdr (\ rn -> True) (unknownNameErr "value")
+ = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
+
+lookupConstr rdr
+ = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
+
+lookupField rdr
+ = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
lookupClassOp cls rdr
- = lookup_val rdr (isRnClassOp cls) (badClassOpErr cls)
+ = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
+-- Note: the lookup checks are only performed when renaming source
-lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
- = case lookupRnEnv env rdr of
+lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
+ = case lookup env rdr of
Just name | check name -> succ name
- | otherwise -> fail
+ | otherwise -> fail
Nothing -> fail
where
returnSST name
fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
-lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
- = case lookupRnEnv env rdr of
- Just name | check name -> returnSST name
- | otherwise -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
- Nothing -> lookup_or_create_implicit_val imp_var us_var rdr
-
-lookup_or_create_implicit_val imp_var us_var rdr
- = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
- case lookupFM implicit_val_fm rdr of
+lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
+ = case lookup env rdr of
+ Just name -> returnSST name
+ Nothing -> case rdr of
+ Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
+ Qual m n ->
+ lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
+
+lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
+ = case (lookupFM b_names orig) of
+ Just xx -> returnSST xx
+ Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
+
+lookup_or_create_implicit_val b_key imp_var us_var orig
+ = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
+ case (lookupFM implicit_val_fm orig) of
Just implicit -> returnSST implicit
Nothing ->
- get_unique us_var `thenSST` \ uniq ->
- let
- implicit = mkRnImplicit (mkImplicitName uniq rdr)
- new_val_fm = addToFM implicit_val_fm rdr implicit
- in
- writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
- returnSST implicit
-
-
-lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName)
-lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _)
- = returnSST (lookupRnEnv env rdr)
+ (case (lookupFM b_key orig) of
+ Just (u,_) -> returnSST u
+ _ -> get_unique us_var
+ ) `thenSST` \ uniq ->
+ let
+ implicit = mkRnImplicit (mkImplicitName uniq orig)
+ new_val_fm = addToFM implicit_val_fm orig implicit
+ in
+ writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
+ returnSST implicit
\end{code}
lookupClass rdr
= lookup_tc rdr isRnClass mkRnImplicitClass "class"
+lookupTyConOrClass rdr
+ = lookup_tc rdr isRnTyConOrClass
+ (panic "lookupTC:mk_implicit") "class or type constructor"
lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
= case lookupTcRnEnv env rdr of
returnSST name
fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
+lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
= case lookupTcRnEnv env rdr of
Just name | check name -> returnSST name
| otherwise -> fail
- Nothing -> lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
+ Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
where
fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
- = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
- case lookupFM implicit_tc_fm rdr of
+lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
+ = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
+ case (lookupFM b_names orig) of
+ Just xx -> returnSST xx
+ Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
+
+lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
+ = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
+ case (lookupFM implicit_tc_fm orig) of
Just implicit | check implicit -> returnSST implicit
| otherwise -> fail
Nothing ->
- get_unique us_var `thenSST` \ uniq ->
- let
- implicit = mk_implicit (mkImplicitName uniq rdr)
- new_tc_fm = addToFM implicit_tc_fm rdr implicit
- in
- writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
- returnSST implicit
+ (case (lookupFM b_key orig) of
+ Just (u,_) -> returnSST u
+ _ -> get_unique us_var
+ ) `thenSST` \ uniq ->
+ let
+ implicit = mk_implicit (mkImplicitName uniq orig)
+ new_tc_fm = addToFM implicit_tc_fm orig implicit
+ in
+ writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
+ returnSST implicit
\end{code}
failButContinueRn (mkRnUnbound occ)
(unknownNameErr "type variable" occ loc)
\end{code}
+
+
+\begin{code}
+#if __GLASGOW_HASKELL__ >= 200
+ -- can get it from GHCbase
+#else
+fixIO :: (a -> IO a) -> IO a
+
+fixIO k s = let
+ result = k loop s
+ (Right loop, _) = result
+ in
+ result
+#endif
+\end{code}
+
+*********************************************************
+* *
+\subsection{Errors used in RnMonad}
+* *
+*********************************************************
+
+\begin{code}
+unknownNameErr descriptor name locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
+
+badClassOpErr clas op locn
+ = addErrLoc locn "" $ \ sty ->
+ ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
+ ppr sty clas, ppStr "'"]
+
+shadowedNameWarn locn shadow
+ = addShortWarnLocLine locn $ \ sty ->
+ ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
+\end{code}
projects / ghc-hetmet.git / blobdiff