> > ghc -c Sequ.lhs
>
> Sequ.lhs:21: Mismatched contexts
> When matching the contexts of the signatures for `foldr' and `member'
> (the signature contexts in a mutually recursive group should all be
>identical)
Thanks for this bug report. I had done some house-cleaning on TcClassDcl.lhs
and TcInstDcls.lhs, and succeeded in introducing this bug. It arises
from the fact that default-method decls were (erroneously) checked together,
whereas they should be checked one by one.
Enclosed are patches for the two files I mention. There are two separate
runs of "diff". You'll need to re-run mkdepend, because TcInstDcls now
imports TcClassDcl.
NB I havn't re-run the test suite....
Simon
diff -c /local/grasp/sof/fptools/ghc/compiler/typecheck/TcInstDcls.lhs\~
/local/grasp/sof/fptools/ghc/compiler/typecheck/TcInstDcls.lhs
*** /local/grasp/sof/fptools/ghc/compiler/typecheck/TcInstDcls.lhs~ Wed Jul 30
14:39:19 1997
--- /local/grasp/sof/fptools/ghc/compiler/typecheck/TcInstDcls.lhs Mon Aug 18
12:53:41 1997
***************
*** 8,15 ****
module TcInstDcls (
tcInstDecls1,
! tcInstDecls2,
! tcMethodBind
) where
--- 8,14 ----
module TcInstDcls (
tcInstDecls1,
! tcInstDecls2
) where
***************
*** 34,40 ****
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
! import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..),
checkSigTyVars )
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
--- 33,40 ----
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
! import TcBinds ( tcPragmaSigs )
! import TcClassDcl ( tcMethodBind )
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
***************
*** 73,79 ****
isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes )
! import Name ( nameOccName, getOccString, occNameString, moduleString,
getSrcLoc,
isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
NamedThing(..)
)
--- 73,79 ----
isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes )
! import Name ( nameOccName, getSrcLoc, mkLocalName,
isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
NamedThing(..)
)
***************
*** 396,402 ****
tcExtendGlobalTyVars inst_tyvars_set' (
tcExtendGlobalValEnv (catMaybes defm_ids) $
-- Default-method Ids may be mentioned in synthesised RHSs
! mapAndUnzip3Tc (tcMethodBind clas inst_ty' monobinds)
(op_sel_ids `zip` defm_ids)
) `thenTc` \ (method_binds_s, insts_needed_s,
meth_lies_w_ids) ->
--- 396,402 ----
tcExtendGlobalTyVars inst_tyvars_set' (
tcExtendGlobalValEnv (catMaybes defm_ids) $
-- Default-method Ids may be mentioned in synthesised RHSs
! mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds)
(op_sel_ids `zip` defm_ids)
) `thenTc` \ (method_binds_s, insts_needed_s,
meth_lies_w_ids) ->
***************
*** 453,459 ****
%************************************************************************
\begin{code}
! tcMethodBind
:: Class
-> TcType s -- Instance type
-> RenamedMonoBinds -- Method binding
--- 453,459 ----
%************************************************************************
\begin{code}
! tcInstMethodBind
:: Class
-> TcType s -- Instance type
-> RenamedMonoBinds -- Method binding
***************
*** 460,499 ****
-> (Id, Maybe Id) -- Selector id and
default-method id
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
! tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
! = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId
local_meth_id) ->
! tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty')
->
let
! meth_name = getName local_meth_id
!
! maybe_meth_bind = go (getOccName sel_id) meth_binds
! (bndr_name, op_bind) = case maybe_meth_bind of
Just stuff -> stuff
! Nothing -> (meth_name, mk_default_bind meth_name)
!
! (theta', tau') = splitRhoTy rho_ty'
! sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau'
noSrcLoc
in
-- Warn if no method binding
! warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool
maybe_dm_id))
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
! tcBindWithSigs [bndr_name] op_bind [sig_info]
! nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
!
! returnTc (binds, insts, meth)
where
origin = InstanceDeclOrigin -- Poor
! go occ EmptyMonoBinds = Nothing
! go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2
! go occ b@(FunMonoBind op_name _ _ locn) | nameOccName op_name
== occ = Just (op_name, b)
! | otherwise =
Nothing
! go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name
== occ = Just (op_name, b)
! | otherwise =
Nothing
! go occ other = panic "Urk! Bad instance method binding"
mk_default_bind local_meth_name
--- 460,495 ----
-> (Id, Maybe Id) -- Selector id and
default-method id
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
! tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
! = tcGetSrcLoc `thenNF_Tc` \ loc ->
! tcGetUnique `thenNF_Tc` \ uniq ->
let
! meth_occ = getOccName sel_id
! default_meth_name = mkLocalName uniq meth_occ loc
! maybe_meth_bind = find meth_occ meth_binds
! the_meth_bind = case maybe_meth_bind of
Just stuff -> stuff
! Nothing -> mk_default_bind default_meth_name
in
-- Warn if no method binding
! warnTc (not (maybeToBool maybe_meth_bind) &&
! not (maybeToBool maybe_dm_id))
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
! -- Typecheck the method binding
! tcMethodBind clas origin inst_ty sel_id the_meth_bind
where
origin = InstanceDeclOrigin -- Poor
! find occ EmptyMonoBinds = Nothing
! find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
! find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name ==
occ = Just b
! | otherwise = Nothing
! find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name ==
occ = Just b
! | otherwise = Nothing
! find occ other = panic "Urk! Bad instance method binding"
mk_default_bind local_meth_name
Diff finished at Tue Aug 19 11:43:00
diff -c /local/grasp/sof/fptools/ghc/compiler/typecheck/TcClassDcl.lhs\~
/local/grasp/sof/fptools/ghc/compiler/typecheck/TcClassDcl.lhs
*** /local/grasp/sof/fptools/ghc/compiler/typecheck/TcClassDcl.lhs~ Wed Jul 30
14:39:11 1997
--- /local/grasp/sof/fptools/ghc/compiler/typecheck/TcClassDcl.lhs Mon Aug 18
12:45:13 1997
***************
*** 6,12 ****
\begin{code}
#include "HsVersions.h"
! module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
IMP_Ubiq()
--- 6,12 ----
\begin{code}
#include "HsVersions.h"
! module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind ) where
IMP_Ubiq()
***************
*** 13,21 ****
import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
! HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
SYN_IE(RecFlag), nonRecursive, andMonoBinds,
collectMonoBinders,
! Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake )
import HsTypes ( getTyVarName )
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
--- 13,21 ----
import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
! HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
InPat(..),
SYN_IE(RecFlag), nonRecursive, andMonoBinds,
collectMonoBinders,
! Stmt, DoOrListComp, ArithSeqInfo, Fake )
import HsTypes ( getTyVarName )
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
***************
*** 37,43 ****
tcInstSigType, tcInstSigTcType )
import PragmaInfo ( PragmaInfo(..) )
! import Bag ( bagToList )
import Class ( GenClass, mkClass, classBigSig,
classDefaultMethodId,
classOpTagByOccName, SYN_IE(Class)
--- 37,43 ----
tcInstSigType, tcInstSigTcType )
import PragmaInfo ( PragmaInfo(..) )
! import Bag ( bagToList, unionManyBags )
import Class ( GenClass, mkClass, classBigSig,
classDefaultMethodId,
classOpTagByOccName, SYN_IE(Class)
***************
*** 49,55 ****
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
! import Name ( Name, isLocallyDefined, moduleString, getSrcLoc,
nameString, NamedThing(..) )
import Outputable
import Pretty
--- 49,55 ----
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
! import Name ( Name, isLocallyDefined, moduleString, getSrcLoc, nameOccName,
nameString, NamedThing(..) )
import Outputable
import Pretty
***************
*** 308,314 ****
final_sel_binds = andMonoBinds sel_binds
in
-- Generate bindings for the default methods
! buildDefaultMethodBinds clas default_binds `thenTc` \
(const_insts,
meth_binds) ->
returnTc (const_insts,
final_sel_binds `AndMonoBinds` meth_binds)
--- 308,314 ----
final_sel_binds = andMonoBinds sel_binds
in
-- Generate bindings for the default methods
! tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts,
meth_binds) ->
returnTc (const_insts,
final_sel_binds `AndMonoBinds` meth_binds)
***************
*** 388,425 ****
\end{verbatim}
\begin{code}
! buildDefaultMethodBinds
:: Class
-> RenamedMonoBinds
-> TcM s (LIE s, TcMonoBinds s)
! buildDefaultMethodBinds clas default_binds
= -- Construct suitable signatures
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], [inst_ty],
inst_env) ->
- let
- mk_sig (bndr_name, locn)
- = let
- idx = classOpTagByOccName clas (getOccName bndr_name) - 1
- sel_id = op_sel_ids !! idx
- Just dm_id = defm_ids !! idx
- in
- newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId
local_dm_id) ->
- tcInstSigTcType (idType local_dm_id) `thenNF_Tc` \ (tyvars',
rho_ty') ->
- let
- (theta', tau') = splitRhoTy rho_ty'
- sig_info = TySigInfo bndr_name local_dm_id tyvars' theta' tau'
locn
- in
- returnNF_Tc (sig_info, ([clas_tyvar], RealId dm_id, TcId local_dm_id))
- in
- mapAndUnzipNF_Tc mk_sig bndrs `thenNF_Tc` \ (sigs, abs_bind_stuff) ->
-- Typecheck the default bindings
let
! clas_tyvar_set = unitTyVarSet clas_tyvar
! in
tcExtendGlobalTyVars clas_tyvar_set (
! tcBindWithSigs (map fst bndrs) default_binds sigs nonRecursive (\_ ->
NoPragmaInfo)
! ) `thenTc` \ (defm_binds, insts_needed,
_) ->
-- Check the context
newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict,
[this_dict_id]) ->
--- 388,423 ----
\end{verbatim}
\begin{code}
! tcDefaultMethodBinds
:: Class
-> RenamedMonoBinds
-> TcM s (LIE s, TcMonoBinds s)
! tcDefaultMethodBinds clas default_binds
= -- Construct suitable signatures
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], [inst_ty],
inst_env) ->
-- Typecheck the default bindings
let
! clas_tyvar_set = unitTyVarSet clas_tyvar
!
! tc_dm meth_bind
! = let
! bndr_name = case meth_bind of
! FunMonoBind name _ _ _ -> name
! PatMonoBind (VarPatIn name) _ _ -> name
!
! idx = classOpTagByOccName clas (nameOccName bndr_name) - 1
! sel_id = op_sel_ids !! idx
! Just dm_id = defm_ids !! idx
! in
! tcMethodBind clas origin inst_ty sel_id meth_bind
! `thenTc` \ (bind, insts, (_,
local_dm_id)) ->
! returnTc (bind, insts, ([clas_tyvar], RealId dm_id, local_dm_id))
! in
tcExtendGlobalTyVars clas_tyvar_set (
! mapAndUnzip3Tc tc_dm (flatten default_binds [])
! ) `thenTc` \ (defm_binds, insts_needed,
abs_bind_stuff) ->
-- Check the context
newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict,
[this_dict_id]) ->
***************
*** 429,435 ****
tcSimplifyAndCheck
clas_tyvar_set
avail_insts
! insts_needed `thenTc` \ (const_lie, dict_binds) ->
let
full_binds = AbsBinds
--- 427,433 ----
tcSimplifyAndCheck
clas_tyvar_set
avail_insts
! (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
let
full_binds = AbsBinds
***************
*** 436,442 ****
[clas_tyvar]
[this_dict_id]
abs_bind_stuff
! (dict_binds `AndMonoBinds` defm_binds)
in
returnTc (const_lie, full_binds)
--- 434,440 ----
[clas_tyvar]
[this_dict_id]
abs_bind_stuff
! (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
in
returnTc (const_lie, full_binds)
***************
*** 443,453 ****
where
(tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
origin = ClassDeclOrigin
! bndrs = bagToList (collectMonoBinders default_binds)
\end{code}
Contexts
~~~~~~~~
\begin{code}
--- 441,484 ----
where
(tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
origin = ClassDeclOrigin
!
! flatten EmptyMonoBinds rest = rest
! flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
! flatten a_bind rest = a_bind : rest
\end{code}
+ @tcMethodBind@ is used to type-check both default-method and
+ instance-decl method declarations. We must type-check methods one at a
+ time, because their signatures may have different contexts and
+ tyvar sets.
+ \begin{code}
+ tcMethodBind
+ :: Class
+ -> InstOrigin s
+ -> TcType s -- Instance type
+ -> Id -- The method selector
+ -> RenamedMonoBinds -- Method binding (just one)
+ -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
+ tcMethodBind clas origin inst_ty sel_id meth_bind
+ = tcAddSrcLoc src_loc $
+ newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId
local_meth_id) ->
+ tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
+ let
+ (theta', tau') = splitRhoTy rho_ty'
+ sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau'
src_loc
+ in
+ tcBindWithSigs [bndr_name] meth_bind [sig_info]
+ nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
+
+ returnTc (binds, insts, meth)
+ where
+ (bndr_name, src_loc) = case meth_bind of
+ FunMonoBind name _ _ loc -> (name, loc)
+ PatMonoBind (VarPatIn name) _ loc -> (name, loc)
+ \end{code}
+
Contexts
~~~~~~~~
\begin{code}
Diff finished at Tue Aug 19 11:44:11
