projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
I don't thing we want to add a call-context here; it just clutters the output
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcSimplify.lhs
diff --git
a/compiler/typecheck/TcSimplify.lhs
b/compiler/typecheck/TcSimplify.lhs
index
4cb32b8
..
3c8160c
100644
(file)
--- a/
compiler/typecheck/TcSimplify.lhs
+++ b/
compiler/typecheck/TcSimplify.lhs
@@
-21,7
+21,6
@@
module TcSimplify (
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
-import TypeRep ( Type(..) )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
@@
-71,8
+70,9
@@
import ListSetOps ( equivClasses )
import Util ( zipEqual, isSingleton )
import List ( partition )
import SrcLoc ( Located(..) )
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}
\end{code}
@@
-922,7
+922,8
@@
Two more nasty cases are in
tcSimplifySuperClasses qtvs givens sc_wanteds
= ASSERT( all isSkolemTyVar qtvs )
do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds
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)
; return (binds1 `unionBags` binds2) }
where
get_qtvs = return (mkVarSet qtvs)
@@
-1715,22
+1716,21
@@
I had to produce Y, to produce Y I had to produce Z, and so on.
\begin{code}
reduceList (n,stack) try_me wanteds state
\begin{code}
reduceList (n,stack) try_me wanteds state
- | n > opt_MaxContextReductionDepth
- = failWithTc (reduceDepthErr n stack)
-
- | otherwise
- =
+ = do { dopts <- getDOpts
#ifdef DEBUG
#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
#endif
- go wanteds state
+ ; if n >= ctxtStkDepth dopts then
+ failWithTc (reduceDepthErr n stack)
+ else
+ go wanteds state }
where
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
-- Base case: we're done!
reduce stack try_me wanted avails
@@
-2011,7
+2011,8
@@
It's OK: the final zonking stage should zap y to (), which is fine.
\begin{code}
tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
tcSimplifyTop wanteds
\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"
where
doc = text "tcSimplifyTop"
@@
-2022,7
+2023,7
@@
tcSimplifyInteractive wanteds
-- The TcLclEnv should be valid here, solely to improve
-- error message generation for the monomorphism restriction
-- 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))
= do { lcl_env <- getLclEnv
; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env))
@@
-2048,13
+2049,13
@@
tc_simplify_top doc is_interactive want_scs wanteds
= not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
&& defaultable_classes (map get_clas ds)
defaultable_classes clss
= 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])
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
-- Collect together all the bad guys
@@
-2450,8
+2451,8
@@
addNoInstanceErrs mb_what givens dicts
ptext SLIT("to the") <+> what] ]
fix2 | null instance_dicts = []
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
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
@@
-2524,7
+2525,7
@@
badDerivedPred pred
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
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)
nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack)