Commit 428d8026 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-07-08 15:05:15 by simonpj]

MERGE TO STABLE

Add a check for Haskell-98 mode, to check that there is no type
synonym in an instance declaration.

tcfail139 tests this case
parent d200e947
......@@ -15,7 +15,7 @@ import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
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,
......
......@@ -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,
......@@ -82,7 +82,7 @@ import VarSet
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
......@@ -1129,20 +1129,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")
......
......@@ -38,7 +38,7 @@ module TcType (
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
tcGetTyVar_maybe, tcGetTyVar,
tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
---------------------------------
-- Predicates.
......@@ -156,7 +156,7 @@ import Type ( -- Re-exports
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 )
......@@ -173,8 +173,9 @@ import PrelNames -- Lots (e.g. in isFFIArgumentTy)
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}
......@@ -486,6 +487,30 @@ tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
-- 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)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment