import TcRnMonad
import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr,
checkAmbiguity, SourceTyCtxt(..) )
-import TcType ( mkClassPred, tyVarsOfType,
+import TcType ( mkClassPred, tyVarsOfType, tcSplitInstHeadTy_maybe,
tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE,
MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
- tcSplitTyConApp_maybe, tcSplitForAllTys,
+ tcValidInstHeadTy, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy,
isUnLiftedType, isIPPred, isImmutableTyVar,
typeKind, isFlexi, isSkolemTyVar,
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
| 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")
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
- tcGetTyVar_maybe, tcGetTyVar,
+ tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
---------------------------------
-- Predicates.
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
-import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
+import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, tyConUnique )
import DataCon ( DataCon )
import Class ( Class )
import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
import BasicTypes ( IPName(..), ipNameName )
import SrcLoc ( SrcLoc, SrcSpan )
-import Util ( snocView )
-import Maybes ( maybeToBool, expectJust )
+import Util ( snocView, equalLength )
+import Maybes ( maybeToBool, expectJust, mapCatMaybes )
+import ListSetOps ( hasNoDups )
import Outputable
import DATA_IOREF
\end{code}
-- as tycon applications by the type checker
tcSplitTyConApp_maybe other = Nothing
+tcValidInstHeadTy :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must not be type synonyms, but everywhere else type synonyms
+-- are transparent, so we need a special function here
+tcValidInstHeadTy ty
+ = case ty of
+ TyConApp tc tys -> ASSERT( not (isSynTyCon tc) ) ok tys
+ -- A synonym would be a NoteTy
+ FunTy arg res -> ok [arg, res]
+ NoteTy (SynNote _) _ -> False
+ NoteTy other_note ty -> tcValidInstHeadTy ty
+ other -> False
+ where
+ -- Check that all the types are type variables,
+ -- and that each is distinct
+ ok tys = equalLength tvs tys && hasNoDups tvs
+ where
+ tvs = mapCatMaybes get_tv tys
+
+ get_tv (TyVarTy tv) = Just tv -- Again, do not look
+ get_tv (NoteTy (SynNote _) _) = Nothing -- through synonyms
+ get_tv (NoteTy other_note ty) = get_tv ty
+ get_tv other = Nothing
+
tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
Nothing -> ([], ty)