X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=4633f49a9dc01806fa948d4102d5cdc2efc16de6;hb=00abc3998739f7db38a2466b6e730105f16f8ddf;hp=23c3381581a2dd4a62b1b1e9597bf8e335e7f161;hpb=44ba24dc84d271ca9bd5ab5060cb63ed87f585e3;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 23c3381..4633f49 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -1,9 +1,12 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section{Monadic type operations} -This module contains monadic operations over types that contain mutable type variables +Monadic type operations + +This module contains monadic operations over types that contain +mutable type variables \begin{code} module TcMType ( @@ -46,7 +49,7 @@ module TcMType ( zonkType, zonkTcPredType, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkQuantifiedTyVar, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, - zonkTcKindToKind, zonkTcKind, + zonkTcKindToKind, zonkTcKind, zonkTopTyVar, readKindVar, writeKindVar @@ -54,60 +57,31 @@ module TcMType ( #include "HsVersions.h" - -- friends: -import TypeRep ( Type(..), PredType(..), -- Friend; can see representation - ThetaType - ) -import TcType ( TcType, TcThetaType, TcTauType, TcPredType, - TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), - MetaDetails(..), SkolemInfo(..), BoxInfo(..), - BoxyTyVar, BoxyType, UserTypeCtxt(..), kindVarRef, - mkKindVar, isMetaTyVar, isSigTyVar, metaTvRef, - tcCmpPred, isClassPred, tcGetTyVar, - tcSplitPhiTy, tcSplitPredTy_maybe, - tcSplitAppTy_maybe, - tcValidInstHeadTy, tcSplitForAllTys, - tcIsTyVarTy, tcSplitSigmaTy, - isUnLiftedType, isIPPred, - typeKind, isSkolemTyVar, - mkAppTy, mkTyVarTy, mkTyVarTys, - tyVarsOfPred, getClassPredTys_maybe, - tyVarsOfType, tyVarsOfTypes, tcView, - pprPred, pprTheta, pprClassPred ) -import Type ( Kind, KindVar, - isLiftedTypeKind, isSubArgTypeKind, isSubOpenTypeKind, - liftedTypeKind, defaultKind - ) -import Type ( TvSubst, zipTopTvSubst, substTy ) -import Coercion ( mkCoKind ) -import Class ( Class, classArity, className ) -import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon, - tyConArity, tyConName ) -import Var ( TyVar, tyVarKind, tyVarName, isTcTyVar, - mkTyVar, mkTcTyVar, tcTyVarDetails, - CoVar, mkCoVar ) - - -- Assertions -#ifdef DEBUG -import TcType ( isFlexi, isBoxyTyVar, isImmutableTyVar ) -import Type ( isSubKind ) -#endif +import TypeRep +import TcType +import Type +import Type +import Coercion +import Class +import TyCon +import Var -- others: import TcRnMonad -- TcType, amongst others -import FunDeps ( grow, checkInstCoverage ) -import Name ( Name, setNameUnique, mkSysTvName ) +import FunDeps +import Name import VarSet -import DynFlags ( dopt, DynFlag(..) ) -import Util ( nOfThem, isSingleton, notNull ) -import ListSetOps ( removeDups ) -import UniqSupply ( uniqsFromSupply ) +import ErrUtils +import DynFlags +import Util +import Maybes +import ListSetOps +import UniqSupply import Outputable import Control.Monad ( when ) import Data.List ( (\\) ) - \end{code} @@ -368,7 +342,8 @@ data LookupTyVarResult -- The result of a lookupTcTyVar call lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult lookupTcTyVar tyvar - = case details of + = ASSERT( isTcTyVar tyvar ) + case details of SkolemTv _ -> return (DoneTv details) MetaTv _ ref -> do { meta_details <- readMutVar ref ; case meta_details of @@ -468,6 +443,30 @@ zonkTcPredType (EqPred t1 t2) are used at the end of type checking \begin{code} +zonkTopTyVar :: TcTyVar -> TcM TcTyVar +-- zonkTopTyVar is used, at the top level, on any un-instantiated meta type variables +-- to default the kind of ? and ?? etc to *. This is important to ensure that +-- instance declarations match. For example consider +-- instance Show (a->b) +-- foo x = show (\_ -> True) +-- Then we'll get a constraint (Show (p ->q)) where p has argTypeKind (printed ??), +-- and that won't match the typeKind (*) in the instance decl. +-- +-- Because we are at top level, no further constraints are going to affect these +-- type variables, so it's time to do it by hand. However we aren't ready +-- to default them fully to () or whatever, because the type-class defaulting +-- rules have yet to run. + +zonkTopTyVar tv + | k `eqKind` default_k = return tv + | otherwise + = do { tv' <- newFlexiTyVar default_k + ; writeMetaTyVar tv (mkTyVarTy tv') + ; return tv' } + where + k = tyVarKind tv + default_k = defaultKind k + zonkQuantifiedTyVar :: TcTyVar -> TcM TyVar -- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it. -- It might be a meta TyVar, in which case we freeze it into an ordinary TyVar. @@ -1129,14 +1128,15 @@ checkValidInstance tyvars theta clas inst_tys -- Check that instance inference will terminate (if we care) -- For Haskell 98, checkValidTheta has already done that ; when (gla_exts && not undecidable_ok) $ - checkInstTermination theta inst_tys + mapM_ failWithTc (checkInstTermination inst_tys theta) -- The Coverage Condition ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) } where - msg = parens (ptext SLIT("the Coverage Condition fails for one of the functional dependencies")) + msg = parens (vcat [ptext SLIT("the Coverage Condition fails for one of the functional dependencies;"), + undecidableMsg]) \end{code} Termination test: each assertion in the context satisfies @@ -1153,20 +1153,19 @@ The underlying idea is that \begin{code} -checkInstTermination :: ThetaType -> [TcType] -> TcM () -checkInstTermination theta tys - = do { mappM_ (check_nomore (fvTypes tys)) theta - ; mappM_ (check_smaller (sizeTypes tys)) theta } - -check_nomore :: [TyVar] -> PredType -> TcM () -check_nomore fvs pred - = checkTc (null (fvPred pred \\ fvs)) - (predUndecErr pred nomoreMsg $$ parens undecidableMsg) - -check_smaller :: Int -> PredType -> TcM () -check_smaller n pred - = checkTc (sizePred pred < n) - (predUndecErr pred smallerMsg $$ parens undecidableMsg) +checkInstTermination :: [TcType] -> ThetaType -> [Message] +checkInstTermination tys theta + = mapCatMaybes check theta + where + fvs = fvTypes tys + size = sizeTypes tys + check pred + | not (null (fvPred pred \\ fvs)) + = Just (predUndecErr pred nomoreMsg $$ parens undecidableMsg) + | sizePred pred >= size + = Just (predUndecErr pred smallerMsg $$ parens undecidableMsg) + | otherwise + = Nothing predUndecErr pred msg = sep [msg, nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]