%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcSimplify]{TcSimplify}
-
+TcSimplify
\begin{code}
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}
= 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
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
- newDicts DerivOrigin (substTheta tenv theta) `thenM` \ wanteds ->
+ newDictBndrsO orig (substTheta tenv theta) `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
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)
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.
projects / ghc-hetmet.git / blobdiff