Commit 9a34bf19 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu
Browse files

Fix #11974 by adding a more smarts to TcDefaults.

Test cases:
  typecheck/should_compile/T11974
  typecheck/should_fail/T11974b
parent 7f5d5603
......@@ -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
{-
************************************************************************
* *
......
......@@ -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"))
......
......@@ -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 }
......
{-# LANGUAGE ExtendedDefaultRules #-}
module T11974 where
default (Maybe, [])
......@@ -526,3 +526,4 @@ test('T11339', normal, compile_fail, [''])
test('T11339b', normal, compile, [''])
test('T11339c', normal, compile, [''])
test('T11339d', normal, compile, [''])
test('T11974', normal, compile, [''])
{-# LANGUAGE ExtendedDefaultRules #-}
module T11974b where
default (Either, Monad, [], Maybe, Either Bool, Integer, Double, Blah)
data Blah
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
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment