Fix #11974 by adding a more smarts to TcDefaults.
authorRichard Eisenberg <eir@cis.upenn.edu>
Sat, 23 Apr 2016 02:28:35 +0000 (22:28 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 24 Aug 2016 23:18:15 +0000 (19:18 -0400)
Test cases:
  typecheck/should_compile/T11974
  typecheck/should_fail/T11974b

(cherry picked from commit 9a34bf1985035858ece043bf38b47b6ff4b88efb)

compiler/prelude/PrelNames.hs
compiler/typecheck/TcDefaults.hs
compiler/typecheck/TcSimplify.hs
testsuite/tests/typecheck/should_compile/T11974.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_fail/T11974b.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T11974b.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index cc18398..ea244d5 100644 (file)
@@ -2243,6 +2243,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
+
 {-
 ************************************************************************
 *                                                                      *
index f45dd63..e33b8c5 100644 (file)
@@ -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"))
index 41a54b3..c8702b4 100644 (file)
@@ -436,7 +436,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
        ; wanted <- newWanteds DefaultOrigin theta
        ; unsolved <- simplifyWantedsTcM wanted
 
diff --git a/testsuite/tests/typecheck/should_compile/T11974.hs b/testsuite/tests/typecheck/should_compile/T11974.hs
new file mode 100644 (file)
index 0000000..dc157cf
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+
+module T11974 where
+
+default (Maybe, [])
index fd62707..466e4f0 100644 (file)
@@ -514,3 +514,4 @@ test('T11793', normal, compile, [''])
 test('T11947', normal, compile, [''])
 test('T12064', extra_clean(['T12064.hi-boot', 'T12064.o-boot', 'T11062a.hi', 'T11062a.o']),
      multimod_compile, ['T12064', '-v0'])
+test('T11974', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T11974b.hs b/testsuite/tests/typecheck/should_fail/T11974b.hs
new file mode 100644 (file)
index 0000000..023b270
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+
+module T11974b where
+
+default (Either, Monad, [], Maybe, Either Bool, Integer, Double, Blah)
+
+data Blah
diff --git a/testsuite/tests/typecheck/should_fail/T11974b.stderr b/testsuite/tests/typecheck/should_fail/T11974b.stderr
new file mode 100644 (file)
index 0000000..d9ee113
--- /dev/null
@@ -0,0 +1,15 @@
+
+T11974b.hs:5:1: error:
+    • The default type ‘Either’ is not an instance of
+        ‘Num’ or ‘Show’ or ‘Eq’ or ‘Ord’ or ‘Foldable’ or ‘Traversable’
+    • When checking the types in a default declaration
+
+T11974b.hs:5:1: error:
+    • The default type ‘Monad’ is not an instance of
+        ‘Num’ or ‘Show’ or ‘Eq’ or ‘Ord’ or ‘Foldable’ or ‘Traversable’
+    • When checking the types in a default declaration
+
+T11974b.hs:5:1: error:
+    • The default type ‘Blah’ is not an instance of
+        ‘Num’ or ‘Show’ or ‘Eq’ or ‘Ord’ or ‘Foldable’ or ‘Traversable’
+    • When checking the types in a default declaration
index 1ba517f..e6aa020 100644 (file)
@@ -418,3 +418,4 @@ test('BadUnboxedTuple', normal, compile_fail, [''])
 test('T12151', normal, compile_fail, [''])
 test('T7437', normal, compile_fail, [''])
 test('T11947a', normal, compile_fail, [''])
+test('T11974b', normal, compile_fail, [''])