[project @ 2005-10-31 11:53:42 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index b4a0ac7..fd0d1ca 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -55,7 +55,7 @@ import TcType         ( TcType, TcThetaType, TcTauType, TcPredType,
                          MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
                          tcCmpPred, isClassPred, 
                          tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
-                         tcSplitTyConApp_maybe, tcSplitForAllTys,
+                         tcValidInstHeadTy, tcSplitForAllTys,
                          tcIsTyVarTy, tcSplitSigmaTy, 
                          isUnLiftedType, isIPPred, isImmutableTyVar,
                          typeKind, isFlexi, isSkolemTyVar,
@@ -63,7 +63,7 @@ import TcType         ( TcType, TcThetaType, TcTauType, TcPredType,
                          tyVarsOfPred, getClassPredTys_maybe,
                          tyVarsOfType, tyVarsOfTypes, 
                          pprPred, pprTheta, pprClassPred )
-import Kind            ( Kind(..), KindVar(..), mkKindVar, isSubKind,
+import Kind            ( Kind(..), KindVar, kindVarRef, mkKindVar, isSubKind,
                          isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
                          liftedTypeKind, defaultKind
                        )
@@ -80,9 +80,9 @@ import FunDeps                ( grow )
 import Name            ( Name, setNameUnique, mkSysTvName )
 import VarSet
 import VarEnv
-import CmdLineOpts     ( dopt, DynFlag(..) )
+import DynFlags        ( dopt, DynFlag(..) )
 import UniqSupply      ( uniqsFromSupply )
-import Util            ( nOfThem, isSingleton, equalLength, notNull )
+import Util            ( nOfThem, isSingleton, notNull )
 import ListSetOps      ( removeDups )
 import SrcLoc          ( unLoc )
 import Outputable
@@ -294,7 +294,7 @@ We return Nothing iff the original box was unbound.
 
 \begin{code}
 data LookupTyVarResult -- The result of a lookupTcTyVar call
-  = DoneTv TcTyVarDetails
+  = DoneTv TcTyVarDetails      -- Unrefined SkolemTv or virgin MetaTv/SigSkolTv
   | IndirectTv Bool TcType
        --      True  => This is a non-wobbly type refinement, 
        --               gotten from GADT match unification
@@ -589,8 +589,8 @@ zonkTyVar unbound_var_fn rflag tyvar
 \begin{code}
 readKindVar  :: KindVar -> TcM (Maybe TcKind)
 writeKindVar :: KindVar -> TcKind -> TcM ()
-readKindVar  (KVar _ ref)     = readMutVar ref
-writeKindVar (KVar _ ref) val = writeMutVar ref (Just val)
+readKindVar  kv = readMutVar (kindVarRef kv)
+writeKindVar kv val = writeMutVar (kindVarRef kv) (Just val)
 
 -------------
 zonkTcKind :: TcKind -> TcM TcKind
@@ -655,6 +655,7 @@ This might not necessarily show up in kind checking.
 \begin{code}
 data UserTypeCtxt 
   = FunSigCtxt Name    -- Function type signature
+                       -- Also used for types in SPECIALISE pragmas
   | ExprSigCtxt                -- Expression type signature
   | ConArgCtxt Name    -- Data constructor argument
   | TySynCtxt Name     -- RHS of a type synonym decl
@@ -667,6 +668,7 @@ data UserTypeCtxt
   | ForSigCtxt Name    -- Foreign inport or export signature
   | RuleSigCtxt Name   -- Signature on a forall'd variable in a RULE
   | DefaultDeclCtxt    -- Types in a default declaration
+  | SpecInstCtxt       -- SPECIALISE instance pragma
 
 -- Notes re TySynCtxt
 -- We allow type synonyms that aren't types; e.g.  type List = []
@@ -693,6 +695,7 @@ pprUserTypeCtxt ty ResSigCtxt      = sep [ptext SLIT("In a result type signature
 pprUserTypeCtxt ty (ForSigCtxt n)  = sep [ptext SLIT("In the foreign declaration:"), pp_sig n ty]
 pprUserTypeCtxt ty (RuleSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
 pprUserTypeCtxt ty DefaultDeclCtxt = sep [ptext SLIT("In a type in a `default' declaration:"), nest 2 (ppr ty)]
+pprUserTypeCtxt ty SpecInstCtxt    = sep [ptext SLIT("In a SPECIALISE instance pragma:"), nest 2 (ppr ty)]
 
 pp_sig n ty = nest 2 (ppr n <+> dcolon <+> ppr ty)
 \end{code}
@@ -718,6 +721,7 @@ checkValidType ctxt ty
                                                -- constructor, hence rank 1
                 ForSigCtxt _   -> Rank 1
                 RuleSigCtxt _  -> Rank 1
+                SpecInstCtxt   -> Rank 1
 
        actual_kind = typeKind ty
 
@@ -727,7 +731,7 @@ checkValidType ctxt ty
                        ExprSigCtxt  -> isOpenTypeKind   actual_kind
                        GenPatCtxt   -> isLiftedTypeKind actual_kind
                        ForSigCtxt _ -> isLiftedTypeKind actual_kind
-                       other        -> isArgTypeKind       actual_kind
+                       other        -> isArgTypeKind    actual_kind
        
        ubx_tup | not gla_exts = UT_NotOk
                | otherwise    = case ctxt of
@@ -979,6 +983,7 @@ check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty)
 -------------------------
 check_class_pred_tys dflags ctxt tys 
   = case ctxt of
+       TypeCtxt      -> True   -- {-# SPECIALISE instance Eq (T Int) #-} is fine
        InstHeadCtxt  -> True   -- We check for instance-head 
                                -- formation in checkValidInstHead
        InstThetaCtxt -> undecidable_ok || all tcIsTyVarTy tys
@@ -1129,20 +1134,16 @@ check_inst_head dflags clas tys
   | dopt Opt_GlasgowExts dflags
   = check_tyvars dflags clas tys
 
-       -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
+       -- WITH HASKELL 98, MUST HAVE C (T a b c)
   | isSingleton tys,
-    Just (tycon, arg_tys) <- tcSplitTyConApp_maybe first_ty,
-    not (isSynTyCon tycon),            -- ...but not a synonym
-    all tcIsTyVarTy arg_tys,           -- Applied to type variables
-    equalLength (varSetElems (tyVarsOfTypes arg_tys)) arg_tys
-          -- This last condition checks that all the type variables are distinct
+    tcValidInstHeadTy first_ty
   = returnM ()
 
   | otherwise
   = failWithTc (instTypeErr (pprClassPred clas tys) head_shape_msg)
 
   where
-    (first_ty : _)       = tys
+    (first_ty : _) = tys
 
     head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$
                             text "where T is not a synonym, and a,b,c are distinct type variables")