Commit 90c0b29e authored by sof's avatar sof
Browse files

[project @ 1999-04-27 17:33:49 by sof]

Renamer changes:

 - for a toplevel type signature

	f :: ty

   the name 'f' refers to a local definition of 'f' - i.e., don't
   report 'f' as clashing with any imported 'f's.

 - tidied up the handling of fixity declarations - misplaced fixity
   declarations inside class decls, e.g.,

      class F a where
       infix 9 `f`
       g :: a -> Int

   are now caught and reported as errors. Robustified the renaming
   of class decls.
parent e7b901de
......@@ -253,11 +253,13 @@ sigsForMe f sigs
sig_for_me (SpecInstSig _ _) = False
sig_for_me (FixSig (FixitySig n _ _)) = f n
nonFixitySigs :: [Sig name] -> [Sig name]
nonFixitySigs sigs = filter not_fix sigs
where
not_fix (FixSig _) = False
not_fix other = True
isFixitySig :: Sig name -> Bool
isFixitySig (FixSig _) = True
isFixitySig _ = False
isClassOpSig :: Sig name -> Bool
isClassOpSig (ClassOpSig _ _ _ _) = True
isClassOpSig _ = False
\end{code}
\begin{code}
......
......@@ -304,7 +304,7 @@ reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentio
reportableUnusedName :: Name -> Bool
reportableUnusedName name
= explicitlyImported (getNameProvenance name) &&
= explicitlyImported (getNameProvenance name) &&
not (startsWithUnderscore (occNameUserString (nameOccName name)))
where
explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars
......
......@@ -12,7 +12,8 @@ they may be affected by renaming (which isn't fully worked out yet).
module RnBinds (
rnTopBinds, rnTopMonoBinds,
rnMethodBinds, renameSigs,
rnBinds, rnMonoBinds
rnBinds,
unknownSigErr
) where
#include "HsVersions.h"
......@@ -27,16 +28,21 @@ import RnMonad
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
isUnboundName, warnUnusedLocalBinds,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV
FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
failUnboundNameErrRn
)
import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( OccName, Name )
import Name ( OccName, Name, nameOccName )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
import Util ( thenCmp, removeDups )
import List ( partition )
import ListSetOps ( minusList )
import Bag ( bagToList )
import FiniteMap ( emptyFM, addListToFM, lookupFM )
import Maybe ( isJust )
import Outputable
\end{code}
......@@ -169,8 +175,20 @@ rnTopMonoBinds mbinds sigs
= mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
let
binder_set = mkNameSet binder_names
binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) binder_names)
-- the names appearing in the sigs have to be bound by
-- this group's binders.
lookup_occ_rn_sig rdr_name =
case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
Nothing -> failUnboundNameErrRn rdr_name
Just x -> returnRn x
in
rn_mono_binds TopLevel binder_set mbinds sigs
renameSigs opt_WarnMissingSigs binder_set lookup_occ_rn_sig sigs
`thenRn` \ (siglist, sig_fvs) ->
rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->
returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
where
binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
\end{code}
......@@ -197,7 +215,8 @@ rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
-- the parser doesn't produce other forms
rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
rnMonoBinds :: RdrNameMonoBinds
-> [RdrNameSig]
-> (RenamedHsBinds -> RnMS s (result, FreeVars))
-> RnMS s (result, FreeVars)
......@@ -209,15 +228,43 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
-- This also checks that the names form a set
bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders ->
let
binder_set = mkNameSet new_mbinders
binder_set = mkNameSet new_mbinders
-- Weed out the fixity declarations that do not
-- apply to any of the binders in this group.
(sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs
forLocalBind (FixSig sig@(FixitySig name _ _ )) =
isJust (lookupFM binder_occ_fm (rdrNameOcc name))
forLocalBind _ = True
binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) new_mbinders)
-- the names appearing in the sigs have to be bound by
-- this group's binders.
lookup_occ_rn_sig rdr_name =
case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
Nothing -> failUnboundNameErrRn rdr_name
Just x -> returnRn x
in
--
-- Report the fixity declarations in this group that
-- don't refer to any of the group's binders.
--
mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`
renameSigs False binder_set lookup_occ_rn_sig sigs_for_me
`thenRn` \ (siglist, sig_fvs) ->
let
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
in
rn_mono_binds NotTopLevel
binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
-- Install the fixity declarations that do apply here and go.
extendFixityEnv fixity_sigs (
rn_mono_binds siglist mbinds ) `thenRn` \ (binds, bind_fvs) ->
-- Now do the "thing inside", and deal with the free-variable calculations
thing_inside binds `thenRn` \ (result,result_fvs) ->
let
all_fvs = result_fvs `plusFV` bind_fvs
all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs
unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
in
warnUnusedLocalBinds unused_binders `thenRn_`
......@@ -233,41 +280,42 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
%* *
%************************************************************************
@rnMonoBinds@ is used by *both* top-level and nested bindings. It
@rn_mono_binds@ is used by *both* top-level and nested bindings. It
assumes that all variables bound in this group are already in scope.
This is done *either* by pass 3 (for the top-level bindings), *or* by
@rnNestedMonoBinds@ (for the nested ones).
@rnMonoBinds@ (for the nested ones).
\begin{code}
rn_mono_binds :: TopLevelFlag
-> NameSet -- Binders of this group
rn_mono_binds :: [RenamedSig] -- Signatures attached to this group
-> RdrNameMonoBinds
-> [RdrNameSig] -- Signatures attached to this group
-> RnMS s (RenamedHsBinds, --
FreeVars) -- Free variables
rn_mono_binds top_lev binders mbinds sigs
rn_mono_binds siglist mbinds
=
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
renameSigs top_lev False binders sigs `thenRn` \ (siglist, sig_fvs) ->
flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
-- Do the SCC analysis
let edges = mkEdges (mbinds_info `zip` [(0::Int)..])
let
edges = mkEdges (mbinds_info `zip` [(0::Int)..])
scc_result = stronglyConnComp edges
final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
-- Deal with bound and free-var calculation
rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
in
returnRn (final_binds, rhs_fvs `plusFV` sig_fvs)
returnRn (final_binds, rhs_fvs)
\end{code}
@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
unique ``vertex tags'' on its output; minor plumbing required.
Sigh - need to pass along the signatures for the group of bindings,
in case any of them
\begin{code}
flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds
......@@ -289,9 +337,7 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn)
names_bound_here = mkNameSet (collectPatBinders pat')
sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me]
in
extendFixityEnv fixity_sigs $
rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
returnRn
[(names_bound_here,
......@@ -302,25 +348,23 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn)
flattenMonoBinds sigs (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $
lookupBndrRn name `thenRn` \ name' ->
lookupBndrRn name `thenRn` \ new_name ->
let
sigs_for_me = sigsForMe (name' ==) sigs
sigs_for_me = sigsForMe (new_name ==) sigs
sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me]
in
extendFixityEnv fixity_sigs $
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
mapRn (checkPrecMatch inf name') new_matches `thenRn_`
mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_`
returnRn
[(unitNameSet name',
[(unitNameSet new_name,
plusFVs fv_lists `plusFV` sigs_fvs,
FunMonoBind name' inf new_matches locn,
FunMonoBind new_name inf new_matches locn,
sigs_for_me
)]
\end{code}
@rnMethodBinds@ is used for the method bindings of an instance
@rnMethodBinds@ is used for the method bindings of a class and an instance
declaration. like @rnMonoBinds@ but without dependency analysis.
\begin{code}
......@@ -340,7 +384,7 @@ rnMethodBinds (FunMonoBind name inf matches locn)
-- We use the selector name as the binder
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fvs_s) ->
mapRn (checkPrecMatch inf sel_name) new_matches `thenRn_`
mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`
returnRn (FunMonoBind sel_name inf new_matches locn, plusFVs fvs_s)
rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)
......@@ -436,19 +480,18 @@ mkEdges flat_info
flaggery, that all top-level things have type signatures.
At the moment we don't gather free-var info from the types in
sigatures. We'd only need this if we wanted to report unused tyvars.
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
renameSigs :: TopLevelFlag
-> Bool -- True <-> sigs for an instance decl
-- hence SPECIALISE instance prags ok
renameSigs :: Bool -- True => warn if (required) type signatures are missing.
-> NameSet -- Set of names bound in this group
-> (RdrName -> RnMS s Name)
-> [RdrNameSig]
-> RnMS s ([RenamedSig], FreeVars) -- List of Sig constructors
renameSigs top_lev inst_decl binders sigs
renameSigs sigs_required binders lookup_occ_nm sigs
= -- Rename the signatures
mapAndUnzipRn renameSig sigs `thenRn` \ (sigs', fvs_s) ->
mapAndUnzipRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs_s) ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
......@@ -456,30 +499,19 @@ renameSigs top_lev inst_decl binders sigs
let
(goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
type_sig_vars = [n | Sig n _ _ <- goodies]
fixes = [f | f@(FixSig _) <- goodies]
idecl_type_sigs = [s | s@(Sig _ _ _) <- goodies]
sigs_required = case top_lev of {TopLevel -> opt_WarnMissingSigs; NotTopLevel -> False}
un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
| otherwise = []
in
mapRn dupSigDeclErr dups `thenRn_`
mapRn unknownSigErr not_this_group `thenRn_`
(if not inst_decl then
mapRn unknownSigErr spec_inst_sigs
else
-- We're being strict here, outlawing the presence
-- of type signatures within an instance declaration.
mapRn unknownSigErr (fixes ++ idecl_type_sigs)
) `thenRn_`
mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
returnRn (sigs', plusFVs fvs_s) -- bad ones and all:
-- we need bindings of *some* sort for every name
mapRn_ dupSigDeclErr dups `thenRn_`
mapRn_ unknownSigErr not_this_group `thenRn_`
mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
returnRn (sigs', plusFVs fvs_s)
-- bad ones and all:
-- we need bindings of *some* sort for every name
-- We use lookupOccRn in the signatures, which is a little bit unsatisfactory
-- becuase this won't work for:
-- because this won't work for:
-- instance Foo T where
-- {-# INLINE op #-}
-- Baz.op = ...
......@@ -487,20 +519,20 @@ renameSigs top_lev inst_decl binders sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
renameSig (Sig v ty src_loc)
renameSig lookup_occ_nm (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookupOccRn v `thenRn` \ new_v ->
lookup_occ_nm v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (Sig new_v new_ty src_loc, fvs)
renameSig (SpecInstSig ty src_loc)
renameSig _ (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
returnRn (SpecInstSig new_ty src_loc, fvs)
renameSig (SpecSig v ty using src_loc)
renameSig lookup_occ_nm (SpecSig v ty using src_loc)
= pushSrcLocRn src_loc $
lookupOccRn v `thenRn` \ new_v ->
lookup_occ_nm v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs1) ->
rn_using using `thenRn` \ (new_using,fvs2) ->
returnRn (SpecSig new_v new_ty new_using src_loc, fvs1 `plusFV` fvs2)
......@@ -509,19 +541,19 @@ renameSig (SpecSig v ty using src_loc)
rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
returnRn (Just new_x, unitFV new_x)
renameSig (InlineSig v src_loc)
renameSig lookup_occ_nm (InlineSig v src_loc)
= pushSrcLocRn src_loc $
lookupOccRn v `thenRn` \ new_v ->
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc, emptyFVs)
renameSig (FixSig (FixitySig v fix src_loc))
renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
lookupOccRn v `thenRn` \ new_v ->
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc), emptyFVs)
renameSig (NoInlineSig v src_loc)
renameSig lookup_occ_nm (NoInlineSig v src_loc)
= pushSrcLocRn src_loc $
lookupOccRn v `thenRn` \ new_v ->
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v src_loc, emptyFVs)
\end{code}
......
......@@ -198,9 +198,9 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
getLocalNameEnv `thenRn` \ name_env ->
(if opt_WarnNameShadowing
then
mapRn (check_shadow name_env) rdr_names_w_loc
mapRn_ (check_shadow name_env) rdr_names_w_loc
else
returnRn []
returnRn ()
) `thenRn_`
newLocalNames rdr_names_w_loc `thenRn` \ names ->
......@@ -288,15 +288,14 @@ checkDupOrQualNames, checkDupNames :: SDoc
checkDupOrQualNames doc_str rdr_names_w_loc
= -- Check for use of qualified names
mapRn (qualNameErr doc_str) quals `thenRn_`
mapRn_ (qualNameErr doc_str) quals `thenRn_`
checkDupNames doc_str rdr_names_w_loc
where
quals = filter (isQual.fst) rdr_names_w_loc
checkDupNames doc_str rdr_names_w_loc
= -- Check for dupicated names in a binding group
mapRn (dupNamesErr doc_str) dups `thenRn_`
returnRn ()
= -- Check for duplicated names in a binding group
mapRn_ (dupNamesErr doc_str) dups
where
(_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
\end{code}
......@@ -370,8 +369,7 @@ lookup_global_occ global_env rdr_name
Nothing -> getModeRn `thenRn` \ mode ->
case mode of
-- Not found when processing source code; so fail
SourceMode -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
SourceMode -> failUnboundNameErrRn rdr_name
-- Not found when processing an imported declaration,
-- so we create a new name for the purpose
......@@ -661,8 +659,7 @@ warnUnusedMatches names
warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM s d ()
warnUnusedBinds warn_when_local names
= mapRn (warnUnusedGroup warn_when_local) groups `thenRn_`
returnRn ()
= mapRn_ (warnUnusedGroup warn_when_local) groups
where
-- Group by provenance
groups = equivClasses cmp names
......@@ -693,7 +690,7 @@ warnUnusedGroup emit_warning names
= case getNameProvenance name1 of
LocalDef loc _ -> (True, loc, text "Defined but not used")
NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+>
text "but but not used")
text "but not used")
other -> (False, getSrcLoc name1, text "Strangely defined but not used")
\end{code}
......@@ -711,6 +708,11 @@ fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
4 (vcat [ppr how_in_scope1,
ppr how_in_scope2])
failUnboundNameErrRn :: RdrName -> RnM s d Name
failUnboundNameErrRn rdr_name =
failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
shadowedNameWarn shadow
= hsep [ptext SLIT("This binding for"),
quotes (ppr shadow),
......
......@@ -421,7 +421,7 @@ rnExpr (ArithSeqIn seq)
\begin{code}
rnRbinds str rbinds
= mapRn field_dup_err dup_fields `thenRn_`
= mapRn_ field_dup_err dup_fields `thenRn_`
mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
returnRn (rbinds', plusFVs fvRbind_s)
where
......@@ -435,7 +435,7 @@ rnRbinds str rbinds
returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
rnRpats rpats
= mapRn field_dup_err dup_fields `thenRn_`
= mapRn_ field_dup_err dup_fields `thenRn_`
mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) ->
returnRn (rpats', plusFVs fvs_s)
where
......
......@@ -25,7 +25,7 @@ import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls,
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
FixitySig(..),
hsDeclName, countTyClDecls, isDataDecl, nonFixitySigs
hsDeclName, countTyClDecls, isDataDecl, isClassOpSig
)
import BasicTypes ( Version, NewOrData(..) )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl,
......@@ -765,7 +765,7 @@ getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)]
getImportedInstDecls
= -- First load any special-instance modules that aren't aready loaded
getSpecialInstModules `thenRn` \ inst_mods ->
mapRn load_it inst_mods `thenRn_`
mapRn_ load_it inst_mods `thenRn_`
-- Now we're ready to grab the instance declarations
-- Find the un-gated ones and return them,
......@@ -820,7 +820,7 @@ getImportedFixities gbl_env
not (isLocallyDefined name)
]
in
mapRn load (nub home_modules) `thenRn_`
mapRn_ load (nub home_modules) `thenRn_`
-- Now we can snaffle the fixity env
getIfacesRn `thenRn` \ ifaces ->
......@@ -996,10 +996,10 @@ getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc
-- Record the names for the class ops
let
-- ignoring fixity declarations
nonfix_sigs = nonFixitySigs sigs
-- just want class-op sigs
op_sigs = filter isClassOpSig sigs
in
mapRn (getClassOpNames new_name) nonfix_sigs `thenRn` \ sub_names ->
mapRn (getClassOpNames new_name) op_sigs `thenRn` \ sub_names ->
returnRn (Just (AvailTC class_name (class_name : sub_names)))
......
......@@ -571,6 +571,7 @@ thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
mapRn_ :: (a -> RnM s d b) -> [a] -> RnM s d ()
mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b]
sequenceRn :: [RnM s d a] -> RnM s d [a]
foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
......@@ -597,6 +598,11 @@ mapRn f (x:xs)
mapRn f xs `thenRn` \ rs ->
returnRn (r:rs)
mapRn_ f [] = returnRn ()
mapRn_ f (x:xs) =
f x `thenRn_`
mapRn_ f xs
foldlRn k z [] = returnRn z
foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
foldlRn k z' xs
......
......@@ -255,10 +255,10 @@ importsFromLocalDecls mod rec_exp_fn decls
non_singleton other = False
in
-- Check for duplicate definitions
mapRn (addErrRn . dupDeclErr) dups `thenRn_`
mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
-- Record that locally-defined things are available
mapRn (recordSlurp Nothing Compulsory) avails `thenRn_`
mapRn_ (recordSlurp Nothing Compulsory) avails `thenRn_`
-- Build the environment
qualifyImports mod
......@@ -308,10 +308,10 @@ fixitiesFromLocalDecls gbl_env decls
getFixities acc (FixD fix)
= fix_decl acc fix
getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too
-- Get fixities from class decl sigs too.
getFixities acc other_decl
= returnRn acc
......
......@@ -20,7 +20,7 @@ import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
import RnHsSyn
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
lookupImplicitOccRn, addImplicitOccRn,
bindLocalsRn,
......@@ -193,12 +193,17 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr
-- Check the signatures
let
-- Filter out fixity signatures;
-- they are done at top level
nofix_sigs = nonFixitySigs sigs
-- First process the class op sigs, then the fixity sigs.
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
(fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapAndUnzipRn (rn_op cname' clas_tyvar_names) nofix_sigs `thenRn` \ (sigs', sig_fvs_s) ->
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapAndUnzipRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs_s) ->
mapRn_ (unknownSigErr) non_sigs `thenRn_`
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) ->
-- Check the methods
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
......@@ -210,8 +215,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr
-- for instance decls.
ASSERT(isNoClassPragmas pragmas)
returnRn (TyClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc),
plusFVs sig_fvs_s `plusFV` cxt_fvs `plusFV` meth_fvs)
returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' NoClassPragmas tname' dname' src_loc),
plusFVs sig_fvs_s `plusFV`
fix_fvs `plusFV`
cxt_fvs `plusFV`
meth_fvs
)
)
where
cls_doc = text "the declaration for class" <+> ppr cname
......@@ -232,7 +241,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr
check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
(classTyVarNotInOpTyErr clas_tyvar sig)
in
mapRn check_in_op_ty clas_tyvars `thenRn_`
mapRn_ check_in_op_ty clas_tyvars `thenRn_`
-- Make the default-method name
let
......@@ -286,10 +295,26 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
let
binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
-- Delete sigs (&report) sigs that aren't allowed inside an
-- instance decl:
--
-- + type signatures
-- + fixity decls
--
(ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
okInInstDecl (FixSig _) = False
okInInstDecl (Sig _ _ _) = False
okInInstDecl _ = True
in
renameSigs NotTopLevel True binders uprags `thenRn` \ (new_uprags, prag_fvs) ->
mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name ->
addOccurrenceName dfun_name `thenRn_`
-- You can't have fixity decls & type signatures
-- within an instance declaration.
mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name ->
addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
......@@ -370,7 +395,7 @@ rnDerivs (Just ds)
Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_`
returnRn clas_name
Just occs -> mapRn lookupImplicitOccRn occs `thenRn_`
Just occs -> mapRn_ lookupImplicitOccRn occs `thenRn_`
returnRn clas_name
\end{code}
......@@ -557,8 +582,8 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
(bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys
forall_tyvar_names = map getTyVarName forall_tyvars
in
mapRn (forAllErr doc ty) bad_guys `thenRn_`
mapRn (forAllWarn doc ty) warn_guys `thenRn_`
mapRn_ (forAllErr doc ty) bad_guys `thenRn_`
mapRn_ (forAllWarn doc ty) warn_guys `thenRn_`
checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' ty
......@@ -609,7 +634,7 @@ rnContext doc ctxt
in
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
returnRn (theta, plusFVs fvs_s)
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment