#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
-import TypeRep ( Type(..) )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
lclEnvElts, tcMetaTy )
import InstEnv ( lookupInstEnv, classInstances, pprInstances )
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType,
- checkAmbiguity, checkInstTermination )
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
import Util ( zipEqual, isSingleton )
import List ( partition )
import SrcLoc ( Located(..) )
-import DynFlags ( DynFlag(..) )
-import StaticFlags
+import DynFlags ( DynFlags(ctxtStkDepth),
+ DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances,
+ Opt_WarnTypeDefaults, Opt_ExtendedDefaultRules ) )
\end{code}
tcSimplifySuperClasses qtvs givens sc_wanteds
= ASSERT( all isSkolemTyVar qtvs )
do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds
- ; binds2 <- tc_simplify_top doc False NoSCs frees
+ ; ext_default <- doptM Opt_ExtendedDefaultRules
+ ; binds2 <- tc_simplify_top doc ext_default NoSCs frees
; return (binds1 `unionBags` binds2) }
where
get_qtvs = return (mkVarSet qtvs)
\begin{code}
reduceList (n,stack) try_me wanteds state
- | n > opt_MaxContextReductionDepth
- = failWithTc (reduceDepthErr n stack)
-
- | otherwise
- =
+ = do { dopts <- getDOpts
#ifdef DEBUG
- (if n > 8 then
- pprTrace "Interesting! Context reduction stack deeper than 8:"
- (int n $$ ifPprDebug (nest 2 (pprStack stack)))
- else (\x->x))
+ ; if n > 8 then
+ dumpTcRn (text "Interesting! Context reduction stack deeper than 8:"
+ <+> (int n $$ ifPprDebug (nest 2 (pprStack stack))))
+ else return ()
#endif
- go wanteds state
+ ; if n >= ctxtStkDepth dopts then
+ failWithTc (reduceDepthErr n stack)
+ else
+ go wanteds state }
where
- go [] state = returnM state
- go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
- go ws state'
+ go [] state = return state
+ go (w:ws) state = do { state' <- reduce (n+1, w:stack) try_me w state
+ ; go ws state' }
-- Base case: we're done!
reduce stack try_me wanted avails
\begin{code}
tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
tcSimplifyTop wanteds
- = tc_simplify_top doc False {- Not interactive loop -} AddSCs wanteds
+ = do { ext_default <- doptM Opt_ExtendedDefaultRules
+ ; tc_simplify_top doc ext_default AddSCs wanteds }
where
doc = text "tcSimplifyTop"
-- The TcLclEnv should be valid here, solely to improve
-- error message generation for the monomorphism restriction
-tc_simplify_top doc is_interactive want_scs wanteds
+tc_simplify_top doc use_extended_defaulting want_scs wanteds
= do { lcl_env <- getLclEnv
; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env))
= not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
&& defaultable_classes (map get_clas ds)
defaultable_classes clss
- | is_interactive = any isInteractiveClass clss
- | otherwise = all isStandardClass clss && any isNumericClass clss
+ | use_extended_defaulting = any isInteractiveClass clss
+ | otherwise = all isStandardClass clss && any isNumericClass clss
isInteractiveClass cls = isNumericClass cls
|| (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
- -- In interactive mode, we default Show a to Show ()
- -- to avoid graututious errors on "show []"
+ -- In interactive mode, or with -fextended-default-rules,
+ -- we default Show a to Show () to avoid graututious errors on "show []"
-- Collect together all the bad guys
rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
-
- head_ty = TyConApp tc (map TyVarTy tvs)
in
addNoInstanceErrs Nothing [] bad_insts `thenM_`
mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
- checkAmbiguity tvs simpl_theta tv_set `thenM_`
- -- Check instance termination as for user-declared instances.
- -- unless we had -fallow-undecidable-instances (which risks
- -- non-termination in the 'deriving' context-inference fixpoint
- -- loop).
- ifM (gla_exts && not undecidable_ok)
- (checkInstTermination simpl_theta [head_ty]) `thenM_`
returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
- ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
+ ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack)