[commit: ghc] wip/rae: Fix #11974 by adding a more smarts to TcDefaults. (f92b765)
git at git.haskell.org
git at git.haskell.org
Wed May 25 15:01:36 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/rae
Link : http://ghc.haskell.org/trac/ghc/changeset/f92b7652628fbce6db8fa551526585bb590af8a7/ghc
>---------------------------------------------------------------
commit f92b7652628fbce6db8fa551526585bb590af8a7
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Fri Apr 22 22:28:35 2016 -0400
Fix #11974 by adding a more smarts to TcDefaults.
Test cases:
typecheck/should_compile/T11974
typecheck/should_fail/T11974b
>---------------------------------------------------------------
f92b7652628fbce6db8fa551526585bb590af8a7
compiler/prelude/PrelNames.hs | 12 +++++++
compiler/typecheck/TcDefaults.hs | 37 ++++++++++++----------
compiler/typecheck/TcSimplify.hs | 2 +-
testsuite/tests/typecheck/should_compile/T11974.hs | 5 +++
testsuite/tests/typecheck/should_compile/all.T | 1 +
testsuite/tests/typecheck/should_fail/all.T | 1 +
6 files changed, 40 insertions(+), 18 deletions(-)
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 1480851..5ed3151 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -2245,6 +2245,18 @@ derivableClassKeys
= [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,
boundedClassKey, showClassKey, readClassKey ]
+
+-- These are the "interactive classes" that are consulted when doing
+-- defaulting. Does not include Num or IsString, which have special
+-- handling.
+interactiveClassNames :: [Name]
+interactiveClassNames
+ = [ showClassName, eqClassName, ordClassName, foldableClassName
+ , traversableClassName ]
+
+interactiveClassKeys :: [Unique]
+interactiveClassKeys = map getUnique interactiveClassNames
+
{-
************************************************************************
* *
diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs
index f45dd63..e33b8c5 100644
--- a/compiler/typecheck/TcDefaults.hs
+++ b/compiler/typecheck/TcDefaults.hs
@@ -13,12 +13,12 @@ import Class
import TcRnMonad
import TcEnv
import TcHsType
+import TcHsSyn
import TcSimplify
-import TcMType
+import TcValidity
import TcType
import PrelNames
import SrcLoc
-import Data.Maybe
import Outputable
import FastString
import qualified GHC.LanguageExtensions as LangExt
@@ -46,13 +46,18 @@ tcDefaults [L _ (DefaultDecl [])]
tcDefaults [L locn (DefaultDecl mono_tys)]
= setSrcSpan locn $
addErrCtxt defaultDeclCtxt $
- do { ovl_str <- xoptM LangExt.OverloadedStrings
+ do { ovl_str <- xoptM LangExt.OverloadedStrings
+ ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
; num_class <- tcLookupClass numClassName
- ; is_str_class <- tcLookupClass isStringClassName
- ; let deflt_clss | ovl_str = [num_class, is_str_class]
- | otherwise = [num_class]
+ ; deflt_str <- if ovl_str
+ then mapM tcLookupClass [isStringClassName]
+ else return []
+ ; deflt_interactive <- if ext_deflt
+ then mapM tcLookupClass interactiveClassNames
+ else return []
+ ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
- ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys
+ ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
; return (Just tau_tys) }
@@ -63,10 +68,10 @@ tcDefaults decls@(L locn (DefaultDecl _) : _)
tc_default_ty :: [Class] -> LHsType Name -> TcM Type
tc_default_ty deflt_clss hs_ty
- = do { ty <- solveEqualities $
- tcHsLiftedType hs_ty
- ; ty <- zonkTcType ty -- establish Type invariants
- ; checkTc (isTauTy ty) (polyDefErr hs_ty)
+ = do { (ty, _kind) <- solveEqualities $
+ tcLHsType hs_ty
+ ; ty <- zonkTcTypeToType emptyZonkEnv ty -- establish Type invariants
+ ; checkValidType DefaultDeclCtxt ty
-- Check that the type is an instance of at least one of the deflt_clss
; oks <- mapM (check_instance ty) deflt_clss
@@ -77,8 +82,10 @@ check_instance :: Type -> Class -> TcM Bool
-- Check that ty is an instance of cls
-- We only care about whether it worked or not; return a boolean
check_instance ty cls
- = do { (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]])
- ; return (isJust mb_res) }
+ = do { (_, success) <- discardErrs $
+ askNoErrs $
+ simplifyDefault [mkClassPred cls [ty]]
+ ; return success }
defaultDeclCtxt :: SDoc
defaultDeclCtxt = text "When checking the types in a default declaration"
@@ -91,10 +98,6 @@ dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn
dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
-polyDefErr :: LHsType Name -> SDoc
-polyDefErr ty
- = hang (text "Illegal polymorphic type in default declaration" <> colon) 2 (ppr ty)
-
badDefaultTy :: Type -> [Class] -> SDoc
badDefaultTy ty deflt_clss
= hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 4c621dd..60663ed 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -427,7 +427,7 @@ simplifyInteractive wanteds
simplifyDefault :: ThetaType -- Wanted; has no type variables in it
-> TcM () -- Succeeds if the constraint is soluble
simplifyDefault theta
- = do { traceTc "simplifyInteractive" empty
+ = do { traceTc "simplifyDefault" empty
; loc <- getCtLocM DefaultOrigin Nothing
; let wanted = [ CtDerived { ctev_pred = pred
, ctev_loc = loc }
diff --git a/testsuite/tests/typecheck/should_compile/T11974.hs b/testsuite/tests/typecheck/should_compile/T11974.hs
new file mode 100644
index 0000000..dc157cf
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11974.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+
+module T11974 where
+
+default (Maybe, [])
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index e58feae..bf03c22 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -515,3 +515,4 @@ test('T11811', normal, compile, [''])
test('T11793', normal, compile, [''])
test('T11348', normal, compile, [''])
test('T11947', normal, compile, [''])
+test('T11974', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index bfae69b..a376a31 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -420,3 +420,4 @@ test('T11990a', normal, compile_fail, [''])
test('T11990b', normal, compile_fail, [''])
test('T12063', [ expect_broken(12063), extra_clean(['T12063.hi-boot', 'T12063.o-boot', 'T12063a.hi', 'T12063a.o']) ],
multimod_compile_fail, ['T12063', '-v0'])
+test('T11974b', normal, compile_fail, [''])
More information about the ghc-commits
mailing list