[project @ 2004-03-17 08:54:19 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / Inst.lhs

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 0c1bff0..eaf433e 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -8,7 +8,7 @@ module Inst (
        showLIE,
 
        Inst, 
-       pprInst, pprInsts, pprInstsInFull, pprDFuns,
+       pprInst, pprInsts, pprDFuns, pprDictsTheta, pprDictsInFull,
        tidyInsts, tidyMoreInsts,
 
        newDictsFromOld, newDicts, cloneDict, 
@@ -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,
@@ -62,8 +63,9 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
                  getClassPredTys, getClassPredTys_maybe, mkPredName,
                  isInheritablePred, isIPPred, matchTys,
                  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, 
-                 pprPred, pprParendType, pprThetaArrow, pprClassPred
+                 pprPred, pprParendType, pprThetaArrow, pprTheta, 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 ->
@@ -476,27 +496,33 @@ relevant in error messages.
 instance Outputable Inst where
     ppr inst = pprInst inst
 
-pprInsts :: [Inst] -> SDoc
-pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
+pprDictsTheta :: [Inst] -> SDoc
+-- Print in type-like fashion (Eq a, Show b)
+pprDictsTheta dicts = pprTheta (map dictPred dicts)
 
-pprInstsInFull insts
-  = vcat (map go insts)
+pprDictsInFull :: [Inst] -> SDoc
+-- Print in type-like fashion, but with source location
+pprDictsInFull dicts 
+  = vcat (map go dicts)
   where
-    go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
+    go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
 
-pprInst (LitInst u lit ty loc)
-  = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
+pprInsts :: [Inst] -> SDoc
+-- Debugging: print the evidence :: type
+pprInsts insts  = brackets (interpp'SP insts)
 
-pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
+pprInst, pprInstInFull :: Inst -> SDoc
+-- Debugging: print the evidence :: type
+pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
+pprInst (Dict id pred loc)      = ppr id <+> dcolon <+> pprPred pred
 
-pprInst m@(Method u id tys theta tau loc)
-  = hsep [ppr id, ptext SLIT("at"), 
-         brackets (sep (map pprParendType tys)) {- ,
-         ptext SLIT("theta"), ppr theta,
-         ptext SLIT("tau"), ppr tau
-         show_uniq u,
-         ppr (instToId m) -}]
+pprInst m@(Method inst_id id tys theta tau loc)
+  = ppr inst_id <+> dcolon <+> 
+       braces (sep [ppr id <+> ptext SLIT("at"),
+                    brackets (sep (map pprParendType tys))])
 
+pprInstInFull inst
+  = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
 
 pprDFuns :: [DFunId] -> SDoc
 -- Prints the dfun as an instance declaration
@@ -529,7 +555,7 @@ showLIE :: SDoc -> TcM ()   -- Debugging
 showLIE str
   = do { lie_var <- getLIEVar ;
         lie <- readMutVar lie_var ;
-        traceTc (str <+> pprInstsInFull (lieToList lie)) }
+        traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 \end{code}