Commit 5f553f0c authored by simonpj's avatar simonpj
Browse files

[project @ 2004-01-12 15:47:50 by simonpj]

Wibble to kind inference; add zipWithM, zipWithM_ and use them
parent 20e1c6cc
......@@ -38,6 +38,7 @@ module Inst (
#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,
......@@ -52,7 +53,7 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
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,
......@@ -64,6 +65,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
pprPred, pprParendType, pprThetaArrow, pprClassPred
)
import Kind ( isSubKind )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon,dataConSig )
......@@ -73,7 +75,7 @@ import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInt
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 )
......@@ -329,6 +331,11 @@ newMethodWithGivenTy orig id tys theta tau
-- 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
......@@ -337,8 +344,21 @@ tcInstClassOp inst_loc sel_id tys
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 ->
......
......@@ -234,7 +234,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
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
......@@ -264,9 +264,9 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
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
......
......@@ -458,11 +458,11 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty
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
......
......@@ -319,7 +319,7 @@ kcApps :: TcKind -- Function kind
-> 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)
......@@ -329,7 +329,7 @@ kcApps fun_kind ppr_fun args
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")
......
......@@ -559,7 +559,7 @@ tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thi
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)) ->
......@@ -574,7 +574,7 @@ tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thi
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
......
......@@ -904,6 +904,7 @@ okToUnifyWith tv ty
Just p `and` m = Just p
\end{code}
%************************************************************************
%* *
Kind unification
......
......@@ -10,7 +10,7 @@ module IOEnv (
returnM, thenM, thenM_, failM,
mappM, mappM_, sequenceM, foldlM,
mapAndUnzipM, mapAndUnzip3M,
checkM, ifM,
checkM, ifM, zipWithM, zipWithM_,
-- Getting at the environment
getEnv, setEnv, updEnv,
......@@ -162,6 +162,16 @@ mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
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) }
......
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