MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
- tcSplitTyConApp_maybe, tcSplitForAllTys,
+ tcValidInstHeadTy, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy,
isUnLiftedType, isIPPred, isImmutableTyVar,
typeKind, isFlexi, isSkolemTyVar,
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
)
import VarEnv
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
\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
\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
\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
| 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 = []
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}
-- constructor, hence rank 1
ForSigCtxt _ -> Rank 1
RuleSigCtxt _ -> Rank 1
+ SpecInstCtxt -> Rank 1
actual_kind = typeKind 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
-------------------------
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
| 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")