[commit: ghc] wip/rae: Fix #11974 by adding a more smarts to TcDefaults. (4526940)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/4526940a5397d608a95307797ae4251b5e87171b/ghc

>---------------------------------------------------------------

commit 4526940a5397d608a95307797ae4251b5e87171b
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 case: typecheck/should_compile/T11974


>---------------------------------------------------------------

4526940a5397d608a95307797ae4251b5e87171b
 compiler/prelude/PrelNames.hs                      | 12 ++++++++++
 compiler/typecheck/TcDefaults.hs                   | 28 ++++++++++++----------
 testsuite/tests/typecheck/should_compile/T11974.hs |  5 ++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 4 files changed, 33 insertions(+), 13 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..477e10b 100644
--- a/compiler/typecheck/TcDefaults.hs
+++ b/compiler/typecheck/TcDefaults.hs
@@ -13,8 +13,9 @@ import Class
 import TcRnMonad
 import TcEnv
 import TcHsType
+import TcHsSyn
 import TcSimplify
-import TcMType
+import TcValidity
 import TcType
 import PrelNames
 import SrcLoc
@@ -46,11 +47,16 @@ 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
 
@@ -63,10 +69,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
@@ -91,10 +97,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/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, [''])