Commit a170160c authored by simonpj's avatar simonpj
Browse files

[project @ 2002-03-08 15:50:53 by simonpj]

--------------------------------------
	Lift the class-method type restriction
	--------------------------------------

Haskell 98 prohibits class method types to mention constraints on the
class type variable, thus:

  class Seq s a where
    fromList :: [a] -> s a
    elem     :: Eq a => a -> s a -> Bool

The type of 'elem' is illegal in Haskell 98, because it contains the
constraint 'Eq a', which constrains only the class type variable (in
this case 'a').

This commit lifts the restriction.  The way we do that is to do a full
context reduction (tcSimplifyCheck) step for each method separately in
TcClassDcl.tcMethodBind, rather than doing a single context reduction
for the whole group of method bindings.

As a result, I had to reorganise the code a bit, and tidy up.
parent 4593b105
......@@ -45,7 +45,7 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType,
)
import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
SourceType(..), PredType, ThetaType,
SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
tcSplitForAllTys, tcSplitForAllTys,
tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
......@@ -358,7 +358,7 @@ newIPDict orig ip_name ty
\begin{code}
tcInstCall :: InstOrigin -> TcType -> NF_TcM (TypecheckedHsExpr -> TypecheckedHsExpr, LIE, TcType)
tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
= tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
= tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
newDicts orig theta `thenNF_Tc` \ dicts ->
let
inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
......@@ -550,18 +550,18 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc)
case lookupInstEnv dflags inst_env clas tys of
FoundInst tenv dfun_id
-> let
-> -- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
mk_ty_arg tv = case lookupSubstEnv tenv tv of
Just (DoneTy ty) -> returnNF_Tc ty
Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv ->
Nothing -> tcInstTyVar VanillaTv tv `thenNF_Tc` \ tc_tv ->
returnTc (mkTyVarTy tc_tv)
in
-- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
let
dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
......
......@@ -4,7 +4,7 @@
\section[TcBinds]{TcBinds}
\begin{code}
module TcBinds ( tcBindsAndThen, tcTopBinds,
module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
tcSpecSigs, tcBindWithSigs ) where
#include "HsVersions.h"
......@@ -25,11 +25,11 @@ import TcMonad
import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
newDicts, instToId
)
import TcEnv ( tcExtendLocalValEnv, newLocalName )
import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..),
TcSigInfo(..), tcTySig, maybeSig, tcAddScopedTyVars
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars
)
import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
import TcSimplify ( bindInstsOfLocalFuns )
......@@ -131,7 +131,7 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-- Extend the environment to bind the new polymorphic Ids
tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
tcExtendLocalValEnv poly_ids $
-- Build bindings and IdInfos corresponding to user pragmas
tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) ->
......@@ -219,8 +219,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
binder_names = collectMonoBinders mbind
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
Nothing -> mkLocalId name forall_a_a -- No signature
Just sig -> tcSigPolyId sig -- Signature
Nothing -> mkLocalId name forall_a_a -- No signature
in
returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
) $
......@@ -273,7 +273,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
where
(tyvars, poly_id) =
case maybeSig tc_ty_sigs binder_name of
Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
Just (TySigInfo sig_poly_id sig_tyvars _ _ _ _ _) ->
(sig_tyvars, sig_poly_id)
Nothing -> (real_tyvars_to_gen, new_poly_id)
......@@ -452,8 +452,8 @@ generalise binder_names mbind tau_tvs lie_req sigs =
returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
where
tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
is_mono_sig (TySigInfo _ _ _ theta _ _ _ _) = null theta
tysig_names = map (idName . tcSigPolyId) sigs
is_mono_sig (TySigInfo _ _ theta _ _ _ _) = null theta
doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
......@@ -465,7 +465,7 @@ generalise binder_names mbind tau_tvs lie_req sigs =
-- We unify them because, with polymorphic recursion, their types
-- might not otherwise be related. This is a rather subtle issue.
-- ToDo: amplify
checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
= tcAddSrcLoc src_loc $
mapTc_ check_one other_sigs `thenTc_`
if null theta1 then
......@@ -481,20 +481,20 @@ checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
returnTc (sig_avails, map instToId sig_dicts)
where
sig1_dict_tys = map mkPredTy theta1
sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
check_one sig@(TySigInfo id _ theta _ _ _ _)
= tcAddErrCtxt (sigContextsCtxt id1 id) $
checkTc (equalLength theta theta1) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
checkSigsTyVars sigs = mapTc_ check_one sigs
where
check_one (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ptext SLIT("When checking the type signature for")
<+> quotes (ppr id)) $
tcAddErrCtxtM (sigCtxt sig_tyvars sig_theta sig_tau) $
tcAddErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
\end{code}
......@@ -612,8 +612,10 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
where
mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
Nothing -> (name, mono_id)
Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
Nothing -> (name, mono_id)
Just sig -> (idName poly_id, poly_id)
where
poly_id = tcSigPolyId sig
tc_mb_pats EmptyMonoBinds
= returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
......@@ -634,14 +636,13 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
tc_mb_pats (FunMonoBind name inf matches locn)
= (case maybeSig tc_ty_sigs name of
Just (TySigInfo _ _ _ _ _ mono_id _ _)
-> returnNF_Tc mono_id
Nothing -> newLocalName name `thenNF_Tc` \ bndr_name ->
newTyVarTy openTypeKind `thenNF_Tc` \ bndr_ty ->
Just sig -> returnNF_Tc (tcSigMonoId sig)
Nothing -> newLocalName name `thenNF_Tc` \ bndr_name ->
newTyVarTy openTypeKind `thenNF_Tc` \ bndr_ty ->
-- NB: not a 'hole' tyvar; since there is no type
-- signature, we revert to ordinary H-M typechecking
-- which means the variable gets an inferred tau-type
returnNF_Tc (mkLocalId bndr_name bndr_ty)
returnNF_Tc (mkLocalId bndr_name bndr_ty)
) `thenNF_Tc` \ bndr_id ->
let
bndr_ty = idType bndr_id
......@@ -667,7 +668,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
let
complete_it xve = tcAddSrcLoc locn $
tcAddErrCtxt (patMonoBindsCtxt bind) $
tcExtendLocalValEnv xve $
tcExtendLocalValEnv2 xve $
tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) ->
returnTc (PatMonoBind pat' grhss' locn, lie)
in
......@@ -687,10 +688,11 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
-> newLocalName name `thenNF_Tc` \ bndr_name ->
tcMonoPatBndr bndr_name pat_ty
Just (TySigInfo _ _ _ _ _ mono_id _ _)
-> tcAddSrcLoc (getSrcLoc name) $
tcSubPat pat_ty (idType mono_id) `thenTc` \ (co_fn, lie) ->
returnTc (co_fn, lie, mono_id)
Just sig -> tcAddSrcLoc (getSrcLoc name) $
tcSubPat pat_ty (idType mono_id) `thenTc` \ (co_fn, lie) ->
returnTc (co_fn, lie, mono_id)
where
mono_id = tcSigMonoId sig
\end{code}
......
......@@ -5,7 +5,7 @@
\begin{code}
module TcClassDcl ( tcClassDecl1, checkValidClass, tcClassDecls2,
tcMethodBind, badMethodErr
tcMethodBind, mkMethodBind, badMethodErr
) where
#include "HsVersions.h"
......@@ -16,24 +16,24 @@ import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
isClassOpSig, isPragSig,
getClassDeclSysNames, placeHolderType
)
import BasicTypes ( TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
RenamedSig, maybeGenericMatch
maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
instToId, newDicts, newMethod )
import TcEnv ( TyThingDetails(..), tcExtendGlobalTyVars,
tcLookupClass, tcExtendTyVarEnvForMeths,
tcExtendLocalValEnv, tcExtendTyVarEnv
import TcEnv ( TyThingDetails(..),
tcLookupClass, tcExtendTyVarEnv2,
tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcMonoType ( tcHsType, tcHsTheta, mkTcSig )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcBinds ( tcMonoBinds )
import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( checkSigTyVars, sigCtxt )
import TcMType ( tcInstSigTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
import TcMType ( tcInstTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
mkTyVarTys, mkPredTys, mkClassPred,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
......@@ -407,7 +407,7 @@ tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds,
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
= tcInstSigTyVars ClsTv tyvars `thenNF_Tc` \ clas_tyvars ->
= tcInstTyVars ClsTv tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
let
dm_ty = idType sel_id -- Same as dict selector!
-- The default method's type should really come from the
......@@ -417,18 +417,17 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
-- of types of default methods (and dict funs) by annotating them
-- TyGenNever (in MkId). Ugh! KSW 1999-09.
inst_tys = mkTyVarTys clas_tyvars
theta = [mkClassPred clas inst_tys]
dm_id = mkDefaultMethodId dm_name dm_ty
local_dm_id = setIdLocalExported dm_id
-- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
xtve = tyvars `zip` clas_tyvars
in
newDicts origin theta `thenNF_Tc` \ [this_dict] ->
newDicts origin theta `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths tyvars clas_tyvars (
tcMethodBind clas origin clas_tyvars inst_tys theta
binds_in prags False op_item
) `thenTc` \ (defm_bind, insts_needed, local_dm_inst) ->
mkMethodBind origin clas inst_tys binds_in op_item `thenTc` \ (dm_inst, meth_info) ->
tcMethodBind xtve clas_tyvars theta
[this_dict] meth_info `thenTc` \ (defm_bind, insts_needed) ->
tcAddErrCtxt (defltMethCtxt clas) $
......@@ -446,7 +445,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
full_bind = AbsBinds
clas_tyvars'
[instToId this_dict]
[(clas_tyvars', local_dm_id, instToId local_dm_inst)]
[(clas_tyvars', local_dm_id, instToId dm_inst)]
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
......@@ -470,87 +469,104 @@ tyvar sets.
\begin{code}
tcMethodBind
:: Class
-> InstOrigin
:: [(TyVar,TcTyVar)] -- Bindings for type environment
-> [TcTyVar] -- Instantiated type variables for the
-- enclosing class/instance decl.
-- They'll be signature tyvars, and we
-- want to check that they don't get bound
-> [TcType] -- Instance types
-> TcThetaType -- Available theta; this could be used to check
-- the method signature, but actually that's done by
-- the caller; here, it's just used for the error message
-> RenamedMonoBinds -- Method binding (pick the right one from in here)
-> [RenamedSig] -- Pramgas (just for this one)
-> Bool -- True <=> This method is from an instance declaration
-> ClassOpItem -- The method selector and default-method Id
-> TcM (TcMonoBinds, LIE, Inst)
tcMethodBind clas origin inst_tyvars inst_tys inst_theta
meth_binds prags is_inst_decl (sel_id, dm_info)
-- enclosing class/instance decl.
-- They'll be signature tyvars, and we
-- want to check that they don't get bound
-- Always equal the range of the type envt
-> TcThetaType -- Available theta; it's just used for the error message
-> [Inst] -- Available from context, used to simplify constraints
-- from the method body
-> (Id, TcSigInfo, RenamedMonoBinds) -- Details of this method
-> TcM (TcMonoBinds, LIE)
tcMethodBind xtve inst_tyvars inst_theta avail_insts
(sel_id, meth_sig, meth_bind)
=
-- Check the bindings; first adding inst_tyvars to the envt
-- so that we don't quantify over them in nested places
tcExtendTyVarEnv2 xtve (
tcAddErrCtxt (methodCtxt sel_id) $
tcMonoBinds meth_bind [meth_sig] NonRecursive
) `thenTc` \ (meth_bind, meth_lie, _, _) ->
-- Now do context reduction. We simplify wrt both the local tyvars
-- and the ones of the class/instance decl, so that there is
-- no problem with
-- class C a where
-- op :: Eq a => a -> b -> a
--
-- We do this for each method independently to localise error messages
let
TySigInfo meth_id meth_tvs meth_theta _ local_meth_id _ _ = meth_sig
in
tcAddErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
newDicts SignatureOrigin meth_theta `thenNF_Tc` \ meth_dicts ->
let
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
in
tcSimplifyCheck
(ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
all_tyvars all_insts meth_lie `thenTc` \ (lie, lie_binds) ->
checkSigTyVars all_tyvars `thenTc` \ all_tyvars' ->
let
meth_tvs' = take (length meth_tvs) all_tyvars'
poly_meth_bind = AbsBinds meth_tvs'
(map instToId meth_dicts)
[(meth_tvs', meth_id, local_meth_id)]
emptyNameSet -- Inlines?
(lie_binds `andMonoBinds` meth_bind)
in
returnTc (poly_meth_bind, lie)
mkMethodBind :: InstOrigin
-> Class -> [TcType] -- Class and instance types
-> RenamedMonoBinds -- Method binding (pick the right one from in here)
-> ClassOpItem
-> TcM (Inst, -- Method inst
(Id, -- Global selector Id
TcSigInfo, -- Signature
RenamedMonoBinds)) -- Binding for the method
mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
= tcGetSrcLoc `thenNF_Tc` \ loc ->
newMethod origin sel_id inst_tys `thenNF_Tc` \ meth ->
newMethod origin sel_id inst_tys `thenNF_Tc` \ meth_inst ->
let
meth_id = instToId meth
meth_id = instToId meth_inst
meth_name = idName meth_id
meth_prags = find_prags (idName sel_id) meth_name prags
in
mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
-- Figure out what method binding to use
-- If the user suppplied one, use it, else construct a default one
(case find_bind (idName sel_id) meth_name meth_binds of
Just user_bind -> returnTc user_bind
Nothing -> mkDefMethRhs is_inst_decl clas inst_tys sel_id loc dm_info `thenTc` \ rhs ->
Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenTc` \ rhs ->
returnTc (FunMonoBind meth_name False -- Not infix decl
[mkSimpleMatch [] rhs placeHolderType loc] loc)
) `thenTc` \ meth_bind ->
-- Check the bindings; first add inst_tyvars to the envt
-- so that we don't quantify over them in nested places
-- The *caller* put the class/inst decl tyvars into the tyvar envt,
-- but not into the global tyvars, so that the call to checkSigTyVars below works ok
tcExtendGlobalTyVars inst_tyvars
(tcAddErrCtxt (methodCtxt sel_id) $
tcBindWithSigs NotTopLevel meth_bind
[sig_info] meth_prags NonRecursive
) `thenTc` \ (binds, insts, _) ->
tcExtendLocalValEnv [(meth_name, meth_id)]
(tcSpecSigs meth_prags) `thenTc` \ (prag_binds1, prag_lie) ->
-- The prag_lie for a SPECIALISE pragma will mention the function
-- itself, so we have to simplify them away right now lest they float
-- outwards!
bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) ->
-- Now check that the instance type variables
-- (or, in the case of a class decl, the class tyvars)
-- have not been unified with anything in the environment
--
-- We do this for each method independently to localise error messages
-- ...and this is why the call to tcExtendGlobalTyVars must be here
-- rather than in the caller
tcAddErrCtxt (ptext SLIT("When checking the type of class method")
<+> quotes (ppr sel_id)) $
tcAddErrCtxtM (sigCtxt inst_tyvars inst_theta (idType meth_id)) $
checkSigTyVars inst_tyvars `thenTc_`
returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
insts `plusLIE` prag_lie',
meth)
mkTcSig meth_id loc `thenNF_Tc` \ meth_sig ->
returnTc (meth_inst, (sel_id, meth_sig, meth_bind))
-- The user didn't supply a method binding,
-- so we have to make up a default binding
-- The RHS of a default method depends on the default-method info
mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_name)
mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name)
= -- An polymorphic default method
returnTc (HsVar dm_name)
mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
= -- No default method
-- Warn only if -fwarn-missing-methods
doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
warnTc (is_inst_decl && warn)
warnTc (isInstDecl origin && warn)
(omittedMethodWarn sel_id) `thenNF_Tc_`
returnTc error_rhs
where
......@@ -559,13 +575,13 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
= -- A generic default method
-- If the method is defined generically, we can only do the job if the
-- instance declaration is for a single-parameter type class with
-- a type constructor applied to type arguments in the instance decl
-- (checkTc, so False provokes the error)
checkTc (not is_inst_decl || simple_inst)
checkTc (not (isInstDecl origin) || simple_inst)
(badGenericInstance sel_id) `thenTc_`
ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
......@@ -588,6 +604,9 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
other -> Nothing
other -> Nothing
isInstDecl InstanceDeclOrigin = True
isInstDecl ClassDeclOrigin = False
\end{code}
......
......@@ -19,12 +19,13 @@ module TcEnv(
tcLookupGlobal_maybe, tcLookupGlobal,
-- Local environment
tcExtendKindEnv, tcLookupLocalIds, tcInLocalScope,
tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId,
tcExtendKindEnv, tcInLocalScope,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocalIds, tcLookup_maybe, tcLookupId,
-- Global type variables
tcGetGlobalTyVars, tcExtendGlobalTyVars,
tcGetGlobalTyVars,
-- Random useful things
RecTcEnv, tcLookupRecId, tcLookupRecId_maybe,
......@@ -45,7 +46,7 @@ import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
tyVarsOfTypes, tcSplitDFunTy,
getDFunTyKey, tcTyConAppTyCon
)
import Id ( isDataConWrapId_maybe )
import Id ( idName, isDataConWrapId_maybe )
import Var ( TyVar, Id, idType )
import VarSet
import DataCon ( DataCon )
......@@ -66,7 +67,6 @@ import HscTypes ( DFunId,
import Module ( Module )
import InstEnv ( InstEnv, emptyInstEnv )
import HscTypes ( lookupType, TyThing(..) )
import Util ( zipEqual )
import SrcLoc ( SrcLoc )
import Outputable
......@@ -386,10 +386,19 @@ tcExtendKindEnv pairs thing_inside
tcSetEnv (env {tcLEnv = le'}) thing_inside
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tyvars thing_inside
tcExtendTyVarEnv tvs thing_inside
= tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 tv_pairs thing_inside
= tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
[tv | (_,tv) <- tv_pairs]
thing_inside
tc_extend_tv_env binds tyvars thing_inside
= tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
let
le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
le' = extendNameEnvList le binds
new_tv_set = mkVarSet tyvars
in
-- It's important to add the in-scope tyvars to the global tyvar set
......@@ -400,29 +409,23 @@ tcExtendTyVarEnv tyvars thing_inside
-- when typechecking the methods.
tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
\end{code}
-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
-- the signature tyvars contain the original names
-- the instance tyvars are what those names should be mapped to
-- It's needed when typechecking the method bindings of class and instance decls
-- It does *not* extend the global tyvars; tcMethodBind does that for itself
tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
\begin{code}
tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
tcExtendLocalValEnv ids thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
let
le' = extendNameEnvList (tcLEnv env) stuff
stuff = [ (getName sig_tv, ATyVar inst_tv)
| (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
]
extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
extra_env = [(idName id, ATcId id) | id <- ids]
le' = extendNameEnvList (tcLEnv env) extra_env
in
tcSetEnv (env {tcLEnv = le'}) thing_inside
\end{code}
tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
\begin{code}
tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendLocalValEnv names_w_ids thing_inside
tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendLocalValEnv2 names_w_ids thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
......@@ -441,11 +444,6 @@ tcExtendLocalValEnv names_w_ids thing_inside
%************************************************************************
\begin{code}
tcExtendGlobalTyVars extra_global_tvs thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
tc_extend_gtvs (tcTyVars env) (mkVarSet extra_global_tvs) `thenNF_Tc` \ gtvs' ->
tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
tc_extend_gtvs gtvs extra_global_tvs
= tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
......
......@@ -35,7 +35,7 @@ import TcPat ( badFieldCon )
import TcSimplify ( tcSimplifyIPs )
import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy,
newTyVarTy, newTyVarTys, zonkTcType )
import TcType ( TcType, TcSigmaType, TcPhiType,
import TcType ( TcType, TcSigmaType, TcPhiType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
isSigmaTy, mkFunTy, mkAppTy, mkTyConTy,
mkTyConApp, mkClassPred, tcFunArgTy,
......@@ -444,7 +444,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
data_cons = tyConDataCons tycon
(con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
in
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
tcInstTyVars VanillaTv con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
-- STEP 2
-- Check that at least one constructor has all the named fields
......@@ -482,7 +482,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
mk_inst_ty (tyvar, result_inst_ty)
| tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
| otherwise = newTyVarTy liftedTypeKind -- Fresh type
| otherwise = newTyVarTy liftedTypeKind -- Fresh type
in
mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
......@@ -742,7 +742,7 @@ tcId name -- Look up the Id and instantiate its type
where
loop orig (HsVar fun_id) lie fun_ty
| want_method_inst fun_ty
= tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
= tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
newMethodWithGivenTy orig fun_id
(mkTyVarTys tyvars) theta tau `thenNF_Tc` \ meth ->
loop orig (HsVar (instToId meth))
......
......@@ -23,9 +23,9 @@ import RnHsSyn ( RenamedHsBinds, RenamedInstDecl,
)
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr )
import TcMonad
import TcMType ( tcInstSigType, checkValidTheta, checkValidInstHead, instTypeErr,
import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr,
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe,
......@@ -34,21 +34,21 @@ import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys,
import Inst ( InstOrigin(..), newDicts, instToId,
LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths, tcLookupId, tcLookupClass,
import TcEnv ( tcExtendGlobalValEnv, tcExtendLocalValEnv2,
tcLookupId, tcLookupClass, tcExtendTyVarEnv2,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
simpleInstInfoTy, newDFunName
)
import InstEnv ( InstEnv, extendInstEnv )
import PprType ( pprClassPred )
import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
import TcMonoType ( tcSigPolyId, tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck )
import HscTypes ( HomeSymbolTable, DFunId, FixityEnv,
PersistentCompilerState(..), PersistentRenamerState,
ModDetails(..)