X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=ef019dfbbb620b390327d8dc7c94374f761c8add;hb=00abc3998739f7db38a2466b6e730105f16f8ddf;hp=ffd88b8712c7c7247f190d2c6b43f660c31949da;hpb=4a8695c5772772ccf9a688d82a9ce4f772c2ad20;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index ffd88b8..ef019df 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1,9 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcSimplify]{TcSimplify} - +TcSimplify \begin{code} module TcSimplify ( @@ -21,58 +21,39 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps, - HsWrapper(..), (<.>), emptyLHsBinds ) +import HsSyn import TcRnMonad -import Inst ( lookupInst, LookupInstResult(..), - tyVarsOfInst, fdPredsOfInsts, - isDict, isClassDict, - isMethodFor, isMethod, - instToId, tyVarsOfInsts, - ipNamesOfInsts, ipNamesOfInst, dictPred, - fdPredsOfInst, - newDictBndrs, newDictBndrsO, - getDictClassTys, isTyVarDict, instLoc, - zonkInst, tidyInsts, tidyMoreInsts, - pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, - isInheritableInst, pprDictsTheta - ) -import TcEnv ( tcGetGlobalTyVars, findGlobals, pprBinders, - lclEnvElts, tcMetaTy ) -import InstEnv ( lookupInstEnv, classInstances, pprInstances ) -import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType ) -import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred, - mkClassPred, isOverloadedTy, isSkolemTyVar, - mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, - tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy ) -import TcIface ( checkWiredInTyCon ) -import Id ( idType ) -import Var ( TyVar ) -import TyCon ( TyCon ) -import Name ( Name ) -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import Class ( classBigSig, classKey ) -import FunDeps ( oclose, grow, improve, pprEquation ) -import PrelInfo ( isNumericClass, isStandardClass ) -import PrelNames ( integerTyConName, - showClassKey, eqClassKey, ordClassKey ) -import Type ( zipTopTvSubst, substTheta, substTy ) -import TysWiredIn ( doubleTy, doubleTyCon ) -import ErrUtils ( Message ) -import BasicTypes ( TopLevelFlag, isNotTopLevel ) +import Inst +import TcEnv +import InstEnv +import TcMType +import TcType +import TcIface +import Id +import Var +import TyCon +import Name +import NameSet +import Class +import FunDeps +import PrelInfo +import PrelNames +import Type +import TysWiredIn +import ErrUtils +import BasicTypes import VarSet -import VarEnv ( TidyEnv ) +import VarEnv import FiniteMap import Bag import Outputable -import ListSetOps ( equivClasses ) -import Util ( zipEqual, isSingleton ) -import List ( partition ) -import SrcLoc ( Located(..) ) -import DynFlags ( DynFlags(ctxtStkDepth), - DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances, - Opt_WarnTypeDefaults, Opt_ExtendedDefaultRules ) ) +import ListSetOps +import Util +import SrcLoc +import DynFlags + +import Data.List \end{code} @@ -1933,6 +1914,9 @@ tc_simplify_top doc use_extended_defaulting want_scs wanteds = do { lcl_env <- getLclEnv ; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) + ; wanteds <- mapM zonkInst wanteds + ; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds)) + ; let try_me inst = ReduceMe want_scs ; (frees, binds, irreds) <- simpleReduceLoop doc try_me wanteds @@ -2169,29 +2153,35 @@ tcSimplifyDeriv orig tc tyvars theta doptM Opt_GlasgowExts `thenM` \ gla_exts -> doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok -> let - tv_set = mkVarSet tvs - - (bad_insts, ok_insts) = partition is_bad_inst irreds - is_bad_inst dict - = let pred = dictPred dict -- reduceMe squashes all non-dicts - in isEmptyVarSet (tyVarsOfPred pred) - -- Things like (Eq T) are bad - || (not gla_exts && not (isTyVarClassPred pred)) - + inst_ty = mkTyConApp tc (mkTyVarTys tvs) + (ok_insts, bad_insts) = partition is_ok_inst irreds + is_ok_inst dict + = isTyVarClassPred pred || (gla_exts && ok_gla_pred pred) + where + pred = dictPred dict -- reduceMe squashes all non-dicts + + ok_gla_pred pred = null (checkInstTermination [inst_ty] [pred]) + -- See Note [Deriving context] + + tv_set = mkVarSet tvs simpl_theta = map dictPred ok_insts weird_preds = [pred | pred <- simpl_theta , not (tyVarsOfPred pred `subVarSet` tv_set)] + -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts -- of problems; in particular, it's hard to compare solutions for -- equality when finding the fixpoint. So I just rule it out for now. - + rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) -- This reverse-mapping is a Royal Pain, -- but the result should mention TyVars not TcTyVars in - + -- In effect, the bad and wierd insts cover all of the cases that + -- would make checkValidInstance fail; if it were called right after tcSimplifyDeriv + -- * wierd_preds ensures unambiguous instances (checkAmbiguity in checkValidInstance) + -- * ok_gla_pred ensures termination (checkInstTermination in checkValidInstance) addNoInstanceErrs Nothing [] bad_insts `thenM_` mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_` returnM (substTheta rev_env simpl_theta) @@ -2199,6 +2189,27 @@ tcSimplifyDeriv orig tc tyvars theta doc = ptext SLIT("deriving classes for a data type") \end{code} +Note [Deriving context] +~~~~~~~~~~~~~~~~~~~~~~~ +With -fglasgow-exts, we allow things like (C Int a) in the simplified +context for a derived instance declaration, because at a use of this +instance, we might know that a=Bool, and have an instance for (C Int +Bool) + +We nevertheless insist that each predicate meets the termination +conditions. If not, the deriving mechanism generates larger and larger +constraints. Example: + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate + instance (Show (Succ a), Show a) => Show (Seq a) +and then + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) +and so on. Instead we want to complain of no instance for (Show (Succ a)). + + + @tcSimplifyDefault@ just checks class-type constraints, essentially; used with \tr{default} declarations. We are only interested in whether it worked or not.