module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted,
- tcSimplifyToDicts, tcSimplifyIPs,
+ tcSimplifyRuleLhs, tcSimplifyIPs,
tcSimplifySuperClasses,
tcSimplifyTop, tcSimplifyInteractive,
tcSimplifyBracket,
#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)
%************************************************************************
%* *
-\subsection{tcSimplifyToDicts}
+ tcSimplifyRuleLhs
%* *
%************************************************************************
getting dictionaries. We want to keep all of them unsimplified, to serve
as the available stuff for the RHS of the rule.
-The same thing is used for specialise pragmas. Consider
+Example. Consider the following left-hand side of a rule
+
+ f (x == y) (y > z) = ...
- f :: Num a => a -> a
- {-# SPECIALISE f :: Int -> Int #-}
- f = ...
+If we typecheck this expression we get constraints
-The type checker generates a binding like:
+ d1 :: Ord a, d2 :: Eq a
- f_spec = (f :: Int -> Int)
+We do NOT want to "simplify" to the LHS
-and we want to end up with
+ forall x::a, y::a, z::a, d1::Ord a.
+ f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
- f_spec = _inline_me_ (f Int dNumInt)
+Instead we want
-But that means that we must simplify the Method for f to (f Int dNumInt)!
-So tcSimplifyToDicts squeezes out all Methods.
+ forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
+ f ((==) d2 x y) ((>) d1 y z) = ...
-IMPORTANT NOTE: we *don't* want to do superclass commoning up. Consider
+Here is another example:
fromIntegral :: (Integral a, Num b) => a -> b
{-# RULES "foo" fromIntegral = id :: Int -> Int #-}
-Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
-want to get
+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
+we *dont* want to get
forall dIntegralInt.
- fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+ fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
because the scsel will mess up RULE matching. Instead we want
forall dIntegralInt, dNumInt.
- fromIntegral Int Int dIntegralInt dNumInt = id Int
+ fromIntegral Int Int dIntegralInt dNumInt = id Int
-Hence "WithoutSCs"
+Even if we have
-\begin{code}
-tcSimplifyToDicts :: [Inst] -> TcM (TcDictBinds)
-tcSimplifyToDicts wanteds
- = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
- -- Since try_me doesn't look at types, we don't need to
- -- do any zonking, so it's safe to call reduceContext directly
- ASSERT( null frees )
- extendLIEs irreds `thenM_`
- returnM binds
+ g (x == y) (y == z) = ..
- where
- doc = text "tcSimplifyToDicts"
+where the two dictionaries are *identical*, we do NOT WANT
- -- Reduce methods and lits only; stop as soon as we get a dictionary
- try_me inst | isDict inst = KeepDictWithoutSCs -- See notes above re "WithoutSCs"
- | otherwise = ReduceMe NoSCs
-\end{code}
+ forall x::a, y::a, z::a, d1::Eq a
+ f ((==) d1 x y) ((>) d1 y z) = ...
+because that will only match if the dict args are (visibly) equal.
+Instead we want to quantify over the dictionaries separately.
+In short, tcSimplifyRuleLhs must *only* squash LitInst and MethInts, leaving
+all dicts unchanged, with absolutely no sharing. It's simpler to do this
+from scratch, rather than further parameterise simpleReduceLoop etc
+
+\begin{code}
+tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds)
+tcSimplifyRuleLhs wanteds
+ = go [] emptyBag wanteds
+ where
+ go dicts binds []
+ = return (dicts, binds)
+ go dicts binds (w:ws)
+ | isDict w
+ = go (w:dicts) binds ws
+ | otherwise
+ = do { w' <- zonkInst w -- So that (3::Int) does not generate a call
+ -- to fromInteger; this looks fragile to me
+ ; lookup_result <- lookupInst w'
+ ; case lookup_result of
+ GenInst ws' rhs -> go dicts (addBind binds w rhs) (ws' ++ ws)
+ SimpleInst rhs -> go dicts (addBind binds w rhs) ws
+ NoInstance -> pprPanic "tcSimplifyRuleLhs" (ppr w)
+ }
+\end{code}
tcSimplifyBracket is used when simplifying the constraints arising from
a Template Haskell bracket [| ... |]. We want to check that there aren't
-- but don't produce an error message of any kind.
-- It might be quite legitimate such as (Eq a)!
- | KeepDictWithoutSCs -- Return as irreducible; don't add its superclasses
- -- Rather specialised: see notes with tcSimplifyToDicts
-
| DontReduceUnlessConstant -- Return as irreducible unless it can
-- be reduced to a constant in one step
-- When simplifying with i,f free, we might still notice that
-- t1=t3; but alas, the binding for t2 (which mentions t1)
-- will continue to float out!
- -- (split n i a) returns: n rhss
- -- auxiliary bindings
- -- 1 or 0 insts to add to irreds
-
split :: Int -> TcId -> TcId -> Inst
-> TcM (TcDictBinds, [LHsExpr TcId])
\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
| otherwise
= case try_me wanted of {
- KeepDictWithoutSCs -> addIrred NoSCs avails wanted
-
; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
-- First, see if the inst can be reduced to a constant in one step
try_simple (addIrred AddSCs) -- Assume want superclasses
\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")
ptext SLIT("to the") <+> what] ]
fix2 | null instance_dicts = []
- | otherwise = [ ptext SLIT("add an instance declaration for")
- <+> pprDictsTheta instance_dicts ]
+ | otherwise = [ sep [ptext SLIT("add an instance declaration for"),
+ pprDictsTheta instance_dicts] ]
instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)]
-- Insts for which it is worth suggesting an adding an instance declaration
-- Exclude implicit parameters, and tyvar dicts
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)
projects / ghc-hetmet.git / blobdiff