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

Wibble to kind inference; add zipWithM, zipWithM_ and use them

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 0c1bff0..f27a782 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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) }