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,
\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)
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
\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds,
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
tcSpecSigs, tcBindWithSigs ) where
#include "HsVersions.h"
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 )
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) ->
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)
) $
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)
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
-- 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
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}
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)
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
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
-> 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}
\begin{code}
module TcClassDcl ( tcClassDecl1, checkValidClass, tcClassDecls2,
- tcMethodBind, badMethodErr
+ tcMethodBind, mkMethodBind, badMethodErr
) where
#include "HsVersions.h"
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
-- (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
-- 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) $
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
\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
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_`
Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
other -> Nothing
other -> Nothing
+
+isInstDecl InstanceDeclOrigin = True
+isInstDecl ClassDeclOrigin = False
\end{code}
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,
tyVarsOfTypes, tcSplitDFunTy,
getDFunTyKey, tcTyConAppTyCon
)
-import Id ( isDataConWrapId_maybe )
+import Id ( idName, isDataConWrapId_maybe )
import Var ( TyVar, Id, idType )
import VarSet
import DataCon ( DataCon )
import Module ( Module )
import InstEnv ( InstEnv, emptyInstEnv )
import HscTypes ( lookupType, TyThing(..) )
-import Util ( zipEqual )
import SrcLoc ( SrcLoc )
import Outputable
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
-- 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]
%************************************************************************
\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)
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,
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
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 ->
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))
)
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,
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(..)
)
-import Subst ( substTheta )
+import Subst ( mkTyVarSubst, substTheta )
import DataCon ( classDataCon )
import Class ( Class, classBigSig )
import Var ( idName, idType )
import Name ( getSrcLoc )
import NameSet ( unitNameSet, emptyNameSet, nameSetToList )
import TyCon ( TyCon )
-import Subst ( mkTopTyVarSubst, substTheta )
import TysWiredIn ( genericTyCons )
import SrcLoc ( SrcLoc )
import Unique ( Uniquable(..) )
tcInstDecl2 :: InstInfo -> TcM (LIE, TcMonoBinds)
tcInstDecl2 (NewTypeDerived { iDFunId = dfun_id })
- = tcInstSigType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
+ = tcInstType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
newDicts InstanceDeclOrigin dfun_theta' `thenNF_Tc` \ rep_dicts ->
let
rep_dict_id = ASSERT( isSingleton rep_dicts )
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc (getSrcLoc dfun_id) $
tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
+ let
+ inst_ty = idType dfun_id
+ (inst_tyvars, _) = tcSplitForAllTys inst_ty
+ -- The tyvars of the instance decl scope over the 'where' part
+ -- Those tyvars are inside the dfun_id's type, which is a bit
+ -- bizarre, but OK so long as you realise it!
+ in
-- Instantiate the instance decl with tc-style type variables
- tcInstSigType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
+ tcInstType InstTv inst_ty `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
let
Just pred = tcSplitPredTy_maybe inst_head'
(clas, inst_tys') = getClassPredTys pred
sel_names = [idName sel_id | (sel_id, _) <- op_items]
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+ sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
-- Find any definitions in monobinds that aren't from the class
- bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
- (inst_tyvars, _) = tcSplitForAllTys (idType dfun_id)
- origin = InstanceDeclOrigin
+ bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
+ origin = InstanceDeclOrigin
in
-- Check that all the method bindings come from this class
mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
-
- tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
- -- The type variable from the dict fun actually scope
- -- over the bindings. They were gotten from
- -- the original instance declaration
-
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
- mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
- dfun_theta'
- monobinds uprags True)
- op_items
- ) `thenTc` \ (method_binds_s, insts_needed_s, meth_insts) ->
-
- -- Deal with SPECIALISE instance pragmas by making them
- -- look like SPECIALISE pragmas for the dfun
- let
- dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
- in
- tcExtendGlobalValEnv [dfun_id] (
- tcSpecSigs dfun_prags
- ) `thenTc` \ (prag_binds, prag_lie) ->
+ mapAndUnzipTc (mkMethodBind origin clas inst_tys' monobinds)
+ op_items `thenTc` \ (meth_insts, meth_infos) ->
- -- Check the overloading constraints of the methods and superclasses
- let
+ let
-- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++
dfun_arg_dicts ++
sc_dicts ++
meth_insts
- methods_lie = plusLIEs insts_needed_s
+ xtve = inst_tyvars `zip` inst_tyvars'
+ tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts
in
+ mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) ->
- -- Simplify the constraints from methods
- tcAddErrCtxt methodCtxt (
- tcSimplifyCheck
- (ptext SLIT("instance declaration context"))
- inst_tyvars'
- avail_insts
- methods_lie
- ) `thenTc` \ (const_lie1, lie_binds1) ->
-
-- Figure out bindings for the superclass context
- tcAddErrCtxt superClassCtxt (
- tcSimplifyCheck
- (ptext SLIT("instance declaration context"))
+ tcAddErrCtxt superClassCtxt $
+ tcSimplifyCheck
+ (ptext SLIT("instance declaration superclass context"))
inst_tyvars'
dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
-- get bound by just selecting from this_dict!!
(mkLIE sc_dicts)
- ) `thenTc` \ (const_lie2, lie_binds2) ->
-
+ `thenTc` \ (sc_lie, sc_binds) ->
+ -- It's possible that the superclass stuff might have done unification
checkSigTyVars inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
+ -- Deal with SPECIALISE instance pragmas by making them
+ -- look like SPECIALISE pragmas for the dfun
+ let
+ mk_prag (SpecInstSig ty loc) = SpecSig (idName dfun_id) ty loc
+ mk_prag prag = prag
+
+ all_prags = map mk_prag uprags
+ in
+
+ tcExtendGlobalValEnv [dfun_id] (
+ tcExtendTyVarEnv2 xtve $
+ tcExtendLocalValEnv2 [(idName sel_id, tcSigPolyId sig)
+ | (sel_id, sig, _) <- meth_infos] $
+ -- Map sel_id to the local method name we are using
+ tcSpecSigs all_prags
+ ) `thenTc` \ (prag_binds, prag_lie) ->
+
-- Create the result bindings
let
local_dfun_id = setIdLocalExported dfun_id
where
msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
- dict_bind = VarMonoBind this_dict_id dict_rhs
- method_binds = andMonoBindList method_binds_s
-
- main_bind
- = AbsBinds
- zonked_inst_tyvars
- (map instToId dfun_arg_dicts)
- [(inst_tyvars', local_dfun_id, this_dict_id)]
- inlines
- (lie_binds1 `AndMonoBinds`
- lie_binds2 `AndMonoBinds`
- method_binds `AndMonoBinds`
- dict_bind)
+ dict_bind = VarMonoBind this_dict_id dict_rhs
+ meth_binds = andMonoBindList meth_binds_s
+ all_binds = sc_binds `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind
+
+ main_bind = AbsBinds
+ zonked_inst_tyvars
+ (map instToId dfun_arg_dicts)
+ [(inst_tyvars', local_dfun_id, this_dict_id)]
+ inlines all_binds
in
- returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
+ returnTc (plusLIEs meth_lie_s `plusLIE` sc_lie `plusLIE` prag_lie,
main_bind `AndMonoBinds` prag_binds)
\end{code}
--------------------------------
-- Instantiation
- tcInstTyVar, tcInstTyVars,
- tcInstSigTyVars, tcInstType, tcInstSigType,
- tcSplitRhoTyM,
+ tcInstTyVar, tcInstTyVars, tcInstType,
--------------------------------
-- Checking type validity
%* *
%************************************************************************
-I don't understand why this is needed
-An old comments says "No need for tcSplitForAllTyM because a type
- variable can't be instantiated to a for-all type"
-But the same is true of rho types!
-
-\begin{code}
-tcSplitRhoTyM :: TcType -> NF_TcM (TcThetaType, TcType)
-tcSplitRhoTyM t
- = go t t []
- where
- -- A type variable is never instantiated to a dictionary type,
- -- so we don't need to do a tcReadVar on the "arg".
- go syn_t (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
- Just pair -> go res res (pair:ts)
- Nothing -> returnNF_Tc (reverse ts, syn_t)
- go syn_t (NoteTy n t) ts = go syn_t t ts
- go syn_t (TyVarTy tv) ts = getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty | not (tcIsTyVarTy ty) -> go syn_t ty ts
- other -> returnNF_Tc (reverse ts, syn_t)
- go syn_t t ts = returnNF_Tc (reverse ts, syn_t)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Type instantiation}
-%* *
-%************************************************************************
-
Instantiating a bunch of type variables
\begin{code}
-tcInstTyVars :: [TyVar]
+tcInstTyVars :: TyVarDetails -> [TyVar]
-> NF_TcM ([TcTyVar], [TcType], Subst)
-tcInstTyVars tyvars
- = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars ->
+tcInstTyVars tv_details tyvars
+ = mapNF_Tc (tcInstTyVar tv_details) tyvars `thenNF_Tc` \ tc_tyvars ->
let
tys = mkTyVarTys tc_tyvars
in
-- they cannot possibly be captured by
-- any existing for-alls. Hence mkTopTyVarSubst
-tcInstTyVar tyvar
+tcInstTyVar tv_details tyvar
= tcGetUnique `thenNF_Tc` \ uniq ->
let
name = setNameUnique (tyVarName tyvar) uniq
-- Better watch out for this. If worst comes to worst, just
-- use mkSysLocalName.
in
- tcNewMutTyVar name (tyVarKind tyvar) VanillaTv
-
-tcInstSigTyVars :: TyVarDetails -> [TyVar] -> NF_TcM [TcTyVar]
-tcInstSigTyVars details tyvars -- Very similar to tcInstTyVar
- = tcGetUniques `thenNF_Tc` \ uniqs ->
- listTc [ ASSERT( not (kind `eqKind` openTypeKind) ) -- Shouldn't happen
- tcNewMutTyVar name kind details
- | (tyvar, uniq) <- tyvars `zip` uniqs,
- let name = setNameUnique (tyVarName tyvar) uniq,
- let kind = tyVarKind tyvar
- ]
-\end{code}
-
-@tcInstType@ instantiates the outer-level for-alls of a TcType with
-fresh type variables, splits off the dictionary part, and returns the results.
+ tcNewMutTyVar name (tyVarKind tyvar) tv_details
-\begin{code}
-tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType)
-tcInstType ty
+tcInstType :: TyVarDetails -> TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType)
+-- tcInstType instantiates the outer-level for-alls of a TcType with
+-- fresh (mutable) type variables, splits off the dictionary part,
+-- and returns the pieces.
+tcInstType tv_details ty
= case tcSplitForAllTys ty of
- ([], rho) -> -- There may be overloading but no type variables;
+ ([], rho) -> -- There may be overloading despite no type variables;
-- (?x :: Int) => Int -> Int
let
- (theta, tau) = tcSplitRhoTy rho -- Used to be tcSplitRhoTyM
+ (theta, tau) = tcSplitRhoTy rho
in
returnNF_Tc ([], theta, tau)
- (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
let
- (theta, tau) = tcSplitRhoTy (substTy tenv rho) -- Used to be tcSplitRhoTyM
+ (theta, tau) = tcSplitRhoTy (substTy tenv rho)
in
returnNF_Tc (tyvars', theta, tau)
-
-
-tcInstSigType :: TyVarDetails -> Type -> NF_TcM ([TcTyVar], TcThetaType, TcType)
--- Very similar to tcInstSigType, but uses signature type variables
--- Also, somewhat arbitrarily, don't deal with the monomorphic case so efficiently
-tcInstSigType tv_details poly_ty
- = let
- (tyvars, rho) = tcSplitForAllTys poly_ty
- in
- tcInstSigTyVars tv_details tyvars `thenNF_Tc` \ tyvars' ->
- -- Make *signature* type variables
-
- let
- tyvar_tys' = mkTyVarTys tyvars'
- rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho
- -- mkTopTyVarSubst because the tyvars' are fresh
-
- (theta', tau') = tcSplitRhoTy rho'
- -- This splitRhoTy tries hard to make sure that tau' is a type synonym
- -- wherever possible, which can improve interface files.
- in
- returnNF_Tc (tyvars', theta', tau')
\end{code}
-
%************************************************************************
%* *
\subsection{Putting and getting mutable type variables}
import TcMonad
import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
-import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv )
+import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
import TcPat ( tcPat, tcMonoPatBndr )
import TcMType ( newTyVarTy, zonkTcType )
import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
where
tc_grhss pats' rhs_ty
- = tcExtendLocalValEnv xve1 $
+ = tcExtendLocalValEnv2 xve1 $
-- Deal with the result signature
case maybe_rhs_sig of
xve = bagToList pat_bndrs
pat_ids = map snd xve
in
- tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
+ tcExtendLocalValEnv2 xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
returnTc (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
) `thenTc` \ (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2) ->
import Name ( Name )
import Var ( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
-import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
kcHsLiftedSigType, kcHsContext,
tcAddScopedTyVars, tcHsTyVars, mkImmutTyVars,
- TcSigInfo(..), tcTySig, mkTcSig, maybeSig
+ TcSigInfo(..), tcTySig, mkTcSig, maybeSig, tcSigPolyId, tcSigMonoId
) where
#include "HsVersions.h"
tcInLocalScope,
TyThing(..), TcTyThing(..), tcExtendKindEnv
)
-import TcMType ( newKindVar, zonkKindEnv, tcInstSigType,
+import TcMType ( newKindVar, zonkKindEnv, tcInstType,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
)
import TcUnify ( unifyKind, unifyOpenTypeKind )
\begin{code}
data TcSigInfo
= TySigInfo
- Name -- N, the Name in corresponding binding
-
TcId -- *Polymorphic* binder for this value...
-- Has name = N
SrcLoc -- Of the signature
instance Outputable TcSigInfo where
- ppr (TySigInfo nm id tyvars theta tau _ inst loc) =
- ppr nm <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
+ ppr (TySigInfo id tyvars theta tau _ inst loc) =
+ ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
+
+tcSigPolyId :: TcSigInfo -> TcId
+tcSigPolyId (TySigInfo id _ _ _ _ _ _) = id
+
+tcSigMonoId :: TcSigInfo -> TcId
+tcSigMonoId (TySigInfo _ _ _ _ id _ _) = id
maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
-- Search for a particular signature
maybeSig [] name = Nothing
-maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
- | name == sig_name = Just sig
- | otherwise = maybeSig sigs name
+maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name
+ | name == idName sig_id = Just sig
+ | otherwise = maybeSig sigs name
\end{code}
-- the tyvars *do* get unified with something, we want to carry on
-- typechecking the rest of the program with the function bound
-- to a pristine type, namely sigma_tc_ty
- tcInstSigType SigTv (idType poly_id) `thenNF_Tc` \ (tyvars', theta', tau') ->
+ tcInstType SigTv (idType poly_id) `thenNF_Tc` \ (tyvars', theta', tau') ->
newMethodWithGivenTy SignatureOrigin
poly_id
theta' tau' `thenNF_Tc` \ inst ->
-- We make a Method even if it's not overloaded; no harm
- returnNF_Tc (TySigInfo (idName poly_id) poly_id tyvars' theta' tau'
+ returnNF_Tc (TySigInfo poly_id tyvars' theta' tau'
(instToId inst) [inst] src_loc)
\end{code}
import FieldLabel ( fieldLabelName )
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
-import TcType ( TcType, TcTyVar, TcSigmaType,
+import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
isHoleTyVar, openTypeKind )
import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyPArrTy,
-- behave differently when called, not when used for
-- matching.
in
- tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+ tcInstTyVars VanillaTv (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
ex_theta' = substTheta tenv ex_theta
arg_tys' = map (substTy tenv) arg_tys
import TcExpr ( tcMonoExpr )
import TcEnv ( tcExtendLocalValEnv, tcLookupId )
import Inst ( LIE, plusLIEs, emptyLIE, instToId )
-import Id ( idName, idType, mkLocalId )
+import Id ( idType, mkLocalId )
import Outputable
\end{code}
tcAddScopedTyVars (collectRuleBndrSigTys vars) (
-- Ditto forall'd variables
- mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
- tcExtendLocalValEnv [(idName id, id) | id <- ids] $
+ mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
+ tcExtendLocalValEnv ids $
-- Now LHS and RHS
- tcMonoExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
- tcMonoExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
+ tcMonoExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
+ tcMonoExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
-import TcType ( TcTyVar, TcTyVarSet, ThetaType,
+import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
mkClassPred, isOverloadedTy, mkTyConApp,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, isIPPred, isInheritablePred, predHasFDs )
returnTc False
where
unify ((qtvs, t1, t2), doc)
- = tcAddErrCtxt doc $
- tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ = tcAddErrCtxt doc $
+ tcInstTyVars VanillaTv (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
unifyTauTy (substTy tenv t1) (substTy tenv t2)
\end{code}
-> TcM ThetaType -- Needed
tcSimplifyDeriv tyvars theta
- = tcInstTyVars tyvars `thenNF_Tc` \ (tvs, _, tenv) ->
+ = tcInstTyVars VanillaTv tyvars `thenNF_Tc` \ (tvs, _, tenv) ->
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
data_cons sel_ids
flavour is_rec gen_info
+ -- It's not strictly necesary to mark newtypes as
+ -- recursive if the loop is broken via a data type.
+ -- But I'm not sure it's worth the hassle of discovering that.
gen_info | not (dopt Opt_Generics dflags) = Nothing
| otherwise = mkTyConGenInfo tycon sys_names
isSkolemTyVar :: TcTyVar -> Bool
isSkolemTyVar tv = case mutTyVarDetails tv of
- SigTv -> True
+ SigTv -> True
+ ClsTv -> True
+ InstTv -> True
oteher -> False
isHoleTyVar :: TcTyVar -> Bool
import TcMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcPhiType, TcTyVar, TcTauType,
- TcTyVarSet, TcThetaType,
+ TcTyVarSet, TcThetaType, TyVarDetails(SigTv),
isTauTy, isSigmaTy,
tcSplitAppTy_maybe, tcSplitTyConApp_maybe,
tcGetTyVar_maybe, tcGetTyVar,
import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, tcLEnvElts )
import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity )
import PprType ( pprType )
-import Id ( mkSysLocal, idType )
+import Id ( Id, mkSysLocal, idType )
import Var ( Var, varName, tyVarKind )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, varSetElems )
import VarEnv
tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type
-- If not, the call is a no-op
- = tcInstType expected_ty `thenNF_Tc` \ (forall_tvs, theta, phi_ty) ->
+ = tcInstType SigTv expected_ty `thenNF_Tc` \ (forall_tvs, theta, phi_ty) ->
-- Type-check the arg and unify with poly type
- thing_inside phi_ty `thenTc` \ (result, lie) ->
+ thing_inside phi_ty `thenTc` \ (result, lie) ->
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
These two context are used with checkSigTyVars
\begin{code}
-sigCtxt :: [TcTyVar] -> TcThetaType -> TcTauType
+sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType
-> TidyEnv -> NF_TcM (TidyEnv, Message)
-sigCtxt sig_tvs sig_theta sig_tau tidy_env
+sigCtxt id sig_tvs sig_theta sig_tau tidy_env
= zonkTcType sig_tau `thenNF_Tc` \ actual_tau ->
let
(env1, tidy_sig_tvs) = tidyOpenTyVars tidy_env sig_tvs
sub_msg = vcat [ptext SLIT("Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho),
ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau
]
- msg = ptext SLIT("When trying to generalise an inferred type") $$ nest 4 sub_msg
+ msg = vcat [ptext SLIT("When trying to generalise the type inferred for") <+> quotes (ppr id),
+ nest 4 sub_msg]
in
returnNF_Tc (env3, msg)
\end{code}
projects / ghc-hetmet.git / commitdiff