From 5f553f0c0508cb09b75f78e6c2ac1baa4c01b6aa Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 12 Jan 2004 15:47:53 +0000 Subject: [PATCH] [project @ 2004-01-12 15:47:50 by simonpj] Wibble to kind inference; add zipWithM, zipWithM_ and use them --- ghc/compiler/typecheck/Inst.lhs | 24 ++++++++++++++++++++++-- ghc/compiler/typecheck/TcArrows.lhs | 6 +++--- ghc/compiler/typecheck/TcExpr.lhs | 4 ++-- ghc/compiler/typecheck/TcHsType.lhs | 4 ++-- ghc/compiler/typecheck/TcMatches.lhs | 4 ++-- ghc/compiler/typecheck/TcUnify.lhs | 1 + ghc/compiler/utils/IOEnv.hs | 12 +++++++++++- 7 files changed, 43 insertions(+), 12 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 0c1bff0..f27a782 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -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 -> diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 5c8c3b5..5a76356 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index cf94f27..8383353 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 3ed5555..ea1444c 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -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") diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 05797f5..76933c4 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index d4e3edd..c13cff6 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -904,6 +904,7 @@ okToUnifyWith tv ty Just p `and` m = Just p \end{code} + %************************************************************************ %* * Kind unification diff --git a/ghc/compiler/utils/IOEnv.hs b/ghc/compiler/utils/IOEnv.hs index 3b4f983..847a46e 100644 --- a/ghc/compiler/utils/IOEnv.hs +++ b/ghc/compiler/utils/IOEnv.hs @@ -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) } -- 1.7.10.4