#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcCheckSigma )
+import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
import TcHsSyn ( TcId, TcIdSet,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
- PredType(..), TyVarDetails(VanillaTv),
+ PredType(..), TyVarDetails(VanillaTv), typeKind,
tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
pprPred, pprParendType, pprThetaArrow, pprClassPred
)
+import Kind ( isSubKind )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon,dataConSig )
import NameSet ( addOneToNameSet )
import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
import Literal ( inIntRange )
-import Var ( TyVar )
+import Var ( TyVar, tyVarKind )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
-- This is important because they are used by TcSimplify
-- to simplify Insts
+-- NB: the kind of the type variable to be instantiated
+-- might be a sub-kind of the type to which it is applied,
+-- notably when the latter is a type variable of kind ??
+-- Hence the call to checkKind
+-- A worry: is this needed anywhere else?
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
= let
substTyWith tyvars tys rho
(preds,tau) = tcSplitPhiTy rho_ty
in
+ zipWithM_ checkKind tyvars tys `thenM_`
newMethod inst_loc sel_id tys preds tau
+checkKind :: TyVar -> TcType -> TcM ()
+-- Ensure that the type has a sub-kind of the tyvar
+checkKind tv ty
+ = do { ty1 <- zonkTcType ty
+ ; if typeKind ty1 `isSubKind` tyVarKind tv
+ then return ()
+ else do
+ { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
+ ; tv1 <- tcInstTyVar VanillaTv tv
+ ; unifyTauTy (mkTyVarTy tv1) ty1 }}
+
+
---------------------------
newMethod inst_loc id tys theta tau
= newUnique `thenM` \ new_uniq ->
tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
- do { cmds_w_tys <- mapM new_cmd_ty (cmd_args `zip` [1..])
+ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
; w_tv <- newSigTyVar liftedTypeKind
; let w_ty = mkTyVarTy w_tv
where
-- Make the types
-- b, ((e,s1) .. sm), s
- new_cmd_ty :: (LHsCmdTop Name, Int)
+ new_cmd_ty :: LHsCmdTop Name -> Int
-> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
- new_cmd_ty (cmd,i)
+ new_cmd_ty cmd i
= do { b_ty <- newTyVarTy arrowTyConKind
; tup_ty <- newTyVarTy liftedTypeKind
-- We actually make a type variable for the tuple
non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
- mk_inst_ty (tyvar, result_inst_ty)
+ mk_inst_ty tyvar result_inst_ty
| tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type
| otherwise = newTyVarTy liftedTypeKind -- Fresh type
in
- mappM mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenM` \ inst_tys ->
+ zipWithM mk_inst_ty tycon_tyvars result_inst_tys `thenM` \ inst_tys ->
-- STEP 5
-- Typecheck the expression to be updated
-> TcM ([LHsType Name], TcKind) -- Kind-checked args
kcApps fun_kind ppr_fun args
= split_fk fun_kind (length args) `thenM` \ (arg_kinds, res_kind) ->
- mappM kc_arg (args `zip` arg_kinds) `thenM` \ args' ->
+ zipWithM kc_arg args arg_kinds `thenM` \ args' ->
returnM (args', res_kind)
where
split_fk fk 0 = returnM ([], fk)
Just (ak,fk') -> split_fk fk' (n-1) `thenM` \ (aks, rk) ->
returnM (ak:aks, rk)
- kc_arg (arg, arg_kind) = kcCheckHsType arg arg_kind
+ kc_arg arg arg_kind = kcCheckHsType arg arg_kind
too_many_args = ptext SLIT("Kind error:") <+> quotes ppr_fun <+>
ptext SLIT("is applied to too many type arguments")
in
tcExtendLocalValEnv rec_ids $
tcStmtsAndThen combine_rec ctxt stmts (
- mappM tc_ret (recNames `zip` recTys) `thenM` \ rec_rets ->
+ zipWithM tc_ret recNames recTys `thenM` \ rec_rets ->
tcLookupLocalIds laterNames `thenM` \ later_ids ->
returnM ([], (later_ids, rec_rets))
) `thenM` \ (stmts', (later_ids, rec_rets)) ->
combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
- tc_ret (rec_name, mono_ty)
+ tc_ret rec_name mono_ty
= tcLookupId rec_name `thenM` \ poly_id ->
-- poly_id may have a polymorphic type
-- but mono_ty is just a monomorphic type variable
Just p `and` m = Just p
\end{code}
+
%************************************************************************
%* *
Kind unification
returnM, thenM, thenM_, failM,
mappM, mappM_, sequenceM, foldlM,
mapAndUnzipM, mapAndUnzip3M,
- checkM, ifM,
+ checkM, ifM, zipWithM, zipWithM_,
-- Getting at the environment
getEnv, setEnv, updEnv,
mappM_ f [] = return ()
mappM_ f (x:xs) = f x >> mappM_ f xs
+zipWithM :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env [c]
+zipWithM f [] bs = return []
+zipWithM f as [] = return []
+zipWithM f (a:as) (b:bs) = do { r <- f a b; rs <- zipWithM f as bs; return (r:rs) }
+
+zipWithM_ :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env ()
+zipWithM_ f [] bs = return ()
+zipWithM_ f as [] = return ()
+zipWithM_ f (a:as) (b:bs) = do { f a b; zipWithM_ f as bs }
+
sequenceM [] = return []
sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) }