%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[RenameMonad4]{The monad used by the fourth renamer pass}
+\section[RnMonad4]{The monad used by the fourth renamer pass}
\begin{code}
#include "HsVersions.h"
-module RenameMonad4 (
+module RnMonad4 (
Rn4M(..),
initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
addErrRn4, failButContinueRn4, recoverQuietlyRn4,
pushSrcLocRn4,
getSrcLocRn4,
- getSwitchCheckerRn4,
lookupValue, lookupValueEvenIfInvisible,
lookupClassOp, lookupFixityOp,
lookupTyCon, lookupTyConEvenIfInvisible,
namesFromProtoNames,
TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
- lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
+ lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
-- for completeness
- Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..),
- Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch,
- GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc,
- Unique, SplitUniqSupply
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
+import Ubiq{-uitous-}
-import AbsSyn
-import Bag
-import CmdLineOpts ( GlobalSwitch(..) )
-import Errors ( dupNamesErr, unknownNameErr, shadowedNameErr,
- badClassOpErr, Error(..)
- )
-import FiniteMap ( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap )
-import Maybes ( Maybe(..), assocMaybe )
-import Name ( isTyConName, isClassName, isClassOpName,
- isUnboundName, invisibleName
+import Bag ( emptyBag, isEmptyBag, unionBags, snocBag, Bag )
+import CmdLineOpts ( opt_ShowPragmaNameErrs, opt_NameShadowingNotOK )
+import ErrUtils
+import FiniteMap ( emptyFM, addListToFM, addToFM, lookupFM )
+import Name ( invisibleName, isTyConName, isClassName,
+ isClassOpName, isUnboundName, Name(..)
)
-import NameTypes ( mkShortName, ShortName )
-import ProtoName -- lots of stuff
-import RenameAuxFuns -- oh, why not ... all of it
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import UniqSet
-import Unique
-import Util
+import NameTypes ( mkShortName, ShortName{-instances-} )
+import Outputable ( pprNonOp )
+import Pretty
+import ProtoName ( eqProtoName, cmpByLocalName, ProtoName(..) )
+import RnUtils ( dupNamesErr, GlobalNameMappers(..) )
+import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} )
+import UniqSet ( mkUniqSet, minusUniqSet, UniqSet(..) )
+import UniqSupply ( getUniques, splitUniqSupply )
+import Util ( assoc, removeDups, zipWithEqual, panic )
infixr 9 `thenRn4`, `thenRn4_`
\end{code}
%************************************************************************
%* *
-\subsection[RenameMonad]{Plain @Rename@ monadery}
+\subsection[RnMonad4]{Plain @Rename@ monadery for pass~4}
%* *
%************************************************************************
type ScopeStack = FiniteMap FAST_STRING Name
type Rn4M result
- = (GlobalSwitch -> Bool)
- -> GlobalNameFuns
+ = GlobalNameMappers
-> ScopeStack
-> Bag Error
- -> SplitUniqSupply
+ -> UniqSupply
-> SrcLoc
-> (result, Bag Error)
-#ifdef __GLASGOW_HASKELL__
{-# INLINE andRn4 #-}
{-# INLINE thenRn4 #-}
{-# INLINE thenLazilyRn4 #-}
{-# INLINE thenRn4_ #-}
{-# INLINE returnRn4 #-}
-#endif
-initRn4 :: (GlobalSwitch -> Bool)
- -> GlobalNameFuns
+initRn4 :: GlobalNameMappers
-> Rn4M result
- -> SplitUniqSupply
+ -> UniqSupply
-> (result, Bag Error)
-initRn4 sw_chkr gnfs renamer init_us
- = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
+initRn4 gnfs renamer init_us
+ = renamer gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
thenRn4, thenLazilyRn4
:: Rn4M a -> (a -> Rn4M b) -> Rn4M b
thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
-thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn
- = case (splitUniqSupply uniqs) of { (s1, s2) ->
- case (expr sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) ->
- case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+thenRn4 expr cont gnfs ss errs uniqs locn
+ = case (splitUniqSupply uniqs) of { (s1, s2) ->
+ case (expr gnfs ss errs s1 locn) of { (res1, errs1) ->
+ case (cont res1 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(res2, errs2) }}}
-thenLazilyRn4 expr cont sw_chkr gnfs ss errs uniqs locn
+thenLazilyRn4 expr cont gnfs ss errs uniqs locn
= let
(s1, s2) = splitUniqSupply uniqs
- (res1, errs1) = expr sw_chkr gnfs ss errs s1 locn
- (res2, errs2) = cont res1 sw_chkr gnfs ss errs1 s2 locn
+ (res1, errs1) = expr gnfs ss errs s1 locn
+ (res2, errs2) = cont res1 gnfs ss errs1 s2 locn
in
(res2, errs2)
-thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn
- = case (splitUniqSupply uniqs) of { (s1, s2) ->
- case (expr sw_chkr gnfs ss errs s1 locn) of { (_, errs1) ->
- case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+thenRn4_ expr cont gnfs ss errs uniqs locn
+ = case (splitUniqSupply uniqs) of { (s1, s2) ->
+ case (expr gnfs ss errs s1 locn) of { (_, errs1) ->
+ case (cont gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(res2, errs2) }}}
-andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (m1 sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) ->
- case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+andRn4 combiner m1 m2 gnfs ss errs us locn
+ = case (splitUniqSupply us) of { (s1, s2) ->
+ case (m1 gnfs ss errs s1 locn) of { (res1, errs1) ->
+ case (m2 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(combiner res1 res2, errs2) }}}
returnRn4 :: a -> Rn4M a
-returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn
+returnRn4 result gnfs ss errs_so_far uniqs locn
= (result, errs_so_far)
failButContinueRn4 :: a -> Error -> Rn4M a
-failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn
+failButContinueRn4 res err gnfs ss errs_so_far uniqs locn
= (res, errs_so_far `snocBag` err)
addErrRn4 :: Error -> Rn4M ()
-addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn
+addErrRn4 err gnfs ss errs_so_far uniqs locn
= ((), errs_so_far `snocBag` err)
\end{code}
\begin{code}
recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
-recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn
+recoverQuietlyRn4 use_this_if_err action gnfs ss errs_so_far uniqs locn
= let
(result, errs_out)
- = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of
+ = case (action gnfs ss emptyBag{-leav out errs-} uniqs locn) of
(result1, errs1) ->
if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
(result1, errs_so_far)
else -- give up; return *incoming* UniqueSupply...
(use_this_if_err,
- if sw_chkr ShowPragmaNameErrs
+ if opt_ShowPragmaNameErrs
then errs_so_far `unionBags` errs1
else errs_so_far) -- toss errs, otherwise
in
\begin{code}
pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
-pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn
- = exp sw_chkr gnfs ss errs_so_far uniq_supply locn
+pushSrcLocRn4 locn exp gnfs ss errs_so_far uniq_supply old_locn
+ = exp gnfs ss errs_so_far uniq_supply locn
getSrcLocRn4 :: Rn4M SrcLoc
-getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
- = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn
-
-getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool)
-
-getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
- = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn
+getSrcLocRn4 gnfs ss errs_so_far uniq_supply locn
+ = returnRn4 locn gnfs ss errs_so_far uniq_supply locn
\end{code}
\begin{code}
getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
-getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn
- = case (getSUniques n us) of { next_uniques ->
+getNextUniquesFromRn4 n gnfs ss errs_so_far us locn
+ = case (getUniques n us) of { next_uniques ->
(next_uniques, errs_so_far) }
\end{code}
\begin{code}
namesFromProtoNames :: String -- Documentation string
-> [(ProtoName, SrcLoc)]
- -> Rn4M [Name]
+ -> Rn4M [Name]
-namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn
+namesFromProtoNames kind pnames_w_src_loc gnfs ss errs_so_far us locn
= (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
mkNewNames goodies
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
where
(goodies, dups) = removeDups cmp pnames_w_src_loc
- -- We want to compare their local names rather than their
+ -- We want to compare their local names rather than their
-- full protonames. It probably doesn't matter here, but it
- -- does in Rename3.lhs!
+ -- does in RnPass3.lhs!
cmp (a, _) (b, _) = cmpByLocalName a b
\end{code}
@mkNewNames@ assumes the names are unique.
\begin{code}
-mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
+mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
mkNewNames pnames_w_locs
= getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
- returnRn4 (zipWith new_short_name uniqs pnames_w_locs)
+ returnRn4 (zipWithEqual new_short_name uniqs pnames_w_locs)
where
new_short_name uniq (Unk str, srcloc) -- gotta be an Unk...
= Short uniq (mkShortName str srcloc)
unboundName pn
= Unbound (grab_string pn)
where
- grab_string (Unk s) = s
+ grab_string (Unk s) = s
+ grab_string (Qunk _ s) = s
grab_string (Imp _ _ _ s) = s
\end{code}
@lookup_val@ is the help function to do the work.
\begin{code}
-lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+lookupValue v {-Rn4-} gnfs ss errs_so_far us locn
= (lookup_val v `thenLazilyRn4` \ name ->
if invisibleName name
then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
else returnRn4 name
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
lookupValueEvenIfInvisible v = lookup_val v
lookup_val :: ProtoName -> Rn4M Name
-lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookup_val pname@(Unk v) gnfs@(v_gnf, tc_gnf) ss a b locn
= case (lookupFM ss v) of
- Just name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name -> returnRn4 name gnfs ss a b locn
Nothing -> case (v_gnf pname) of
- Just name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name -> returnRn4 name gnfs ss a b locn
Nothing -> failButContinueRn4 (unboundName pname)
(unknownNameErr "value" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
+
+lookup_val (Qunk _ _) _ _ _ _ _ = panic "RnMonad4:lookup_val:Qunk"
-- If it ain't an Unk it must be in the global name fun; that includes
-- prelude things.
-lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookup_val pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case (v_gnf pname) of
- Just name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name -> returnRn4 name gnfs ss a b locn
Nothing -> failButContinueRn4 (unboundName pname)
(unknownNameErr "value" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
Looking up the operators in a fixity decl is done differently. We
so we nuke those, too.
\begin{code}
-lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing sw_chkr gnfs
-lookupFixityOp pname sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs
+lookupFixityOp (Prel _) gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing gnfs
+lookupFixityOp pname gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) gnfs
\end{code}
\begin{code}
lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
-- The global name funs handle Prel things
-lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+lookupTyCon tc {-Rn4-} gnfs ss errs_so_far us locn
= (lookup_tycon tc `thenLazilyRn4` \ name ->
if invisibleName name
then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
else returnRn4 name
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
lookupTyConEvenIfInvisible tc = lookup_tycon tc
-lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn
+lookup_tycon (Prel name) gnfs ss a b locn = returnRn4 name gnfs ss a b locn
-lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookup_tycon pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case (tc_gnf pname) of
- Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name | isTyConName name -> returnRn4 name gnfs ss a b locn
_ -> failButContinueRn4 (unboundName pname)
(unknownNameErr "type constructor" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
\begin{code}
lookupClass :: ProtoName -> Rn4M Name
-lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookupClass pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case (tc_gnf pname) of
- Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name | isClassName name -> returnRn4 name gnfs ss a b locn
_ -> failButContinueRn4 (unboundName pname)
(unknownNameErr "class" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
@lookupClassOp@ is used when looking up the lhs identifiers in a class
\begin{code}
lookupClassOp :: Name -> ProtoName -> Rn4M Name
-lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookupClassOp class_name pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case v_gnf pname of
Just op_name | isClassOpName class_name op_name
|| isUnboundName class_name -- avoid spurious errors
- -> returnRn4 op_name sw_chkr gnfs ss a b locn
+ -> returnRn4 op_name gnfs ss a b locn
other -> failButContinueRn4 (unboundName pname)
(badClassOpErr class_name pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
-> Rn4M a
-> Rn4M a
-extendSS binders expr sw_chkr gnfs ss errs us locn
- = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) ->
- expr sw_chkr gnfs new_ss new_errs us locn }
+extendSS binders expr gnfs ss errs us locn
+ = case (extend binders ss gnfs ss errs us locn) of { (new_ss, new_errs) ->
+ expr gnfs new_ss new_errs us locn }
where
extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
extend names ss
- = if (sw_chkr NameShadowingNotOK) then
+ = if opt_NameShadowingNotOK then
hard_way names ss
else -- ignore shadowing; blast 'em in
returnRn4 (
-> Rn4M (a, UniqSet Name)
-> Rn4M (a, UniqSet Name)
-extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn
- = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of
+extendSS2 binders expr gnfs ss errs_so_far us locn
+ = case (extendSS binders expr gnfs ss errs_so_far us locn) of
((e2, freevars), errs)
-> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
errs)
mkTyVarNamesEnv
:: SrcLoc
-> [ProtoName] -- The type variables
- -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars
+ -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars
-mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+mkTyVarNamesEnv src_loc tyvars {-Rn4-} gnfs ss errs_so_far us locn
= (namesFromProtoNames "type variable"
(tyvars `zip` repeat src_loc) `thenRn4` \ tyvars2 ->
tyvars2_in_orig_order = map snd tv_env
in
returnRn4 (tv_env, tyvars2_in_orig_order)
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
where
extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
extend [] ss = ss
\begin{code}
lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
-lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+lookupTyVarName env pname {-Rn4-} gnfs ss errs_so_far us locn
= (case (assoc_maybe env pname) of
Just name -> returnRn4 name
Nothing -> getSrcLocRn4 `thenRn4` \ loc ->
failButContinueRn4 (unboundName pname)
(unknownNameErr "type variable" pname loc)
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
where
assoc_maybe [] _ = Nothing
assoc_maybe ((tv,xxx) : tvs) key
= if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+badClassOpErr clas op locn
+ = addErrLoc locn "" ( \ sty ->
+ ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
+ ppr sty clas, ppStr "'."] )
+
+----------------------------
+-- dupNamesErr: from RnUtils
+
+---------------------------
+shadowedNameErr shadow locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "more than one value with the same name (shadowing): ",
+ ppr sty shadow] )
+
+------------------------------------------
+unknownNameErr descriptor undef_thing locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
+ pprNonOp sty undef_thing] )
+\end{code}
projects / ghc-hetmet.git / blobdiff