[commit: ghc] wip/new-flatten-skolems-Oct14: Improve error message for a handwritten Typeable instance (d81c97f)
git at git.haskell.org
git at git.haskell.org
Fri Oct 31 13:43:50 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/new-flatten-skolems-Oct14
Link : http://ghc.haskell.org/trac/ghc/changeset/d81c97fb64fee5d1b8d7406b41e2af513031c3b9/ghc
>---------------------------------------------------------------
commit d81c97fb64fee5d1b8d7406b41e2af513031c3b9
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Oct 30 16:33:34 2014 +0000
Improve error message for a handwritten Typeable instance
>---------------------------------------------------------------
d81c97fb64fee5d1b8d7406b41e2af513031c3b9
compiler/typecheck/TcInstDcls.lhs | 42 ++++++++++++----------
testsuite/tests/deriving/should_fail/T9687.hs | 4 +++
.../should_fail/T9687.stderr} | 4 +--
.../should_fail/T9730.stderr} | 0
testsuite/tests/deriving/should_fail/all.T | 1 +
5 files changed, 31 insertions(+), 20 deletions(-)
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 10bc466..d22938e 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -61,7 +61,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
import Control.Monad
import Maybes ( isNothing, isJust, whenIsJust )
-import Data.List ( mapAccumL )
+import Data.List ( mapAccumL, partition )
\end{code}
Typechecking instance declarations is done in two passes. The first
@@ -378,7 +378,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
local_infos' = concat local_infos_s
-- Handwritten instances of the poly-kinded Typeable class are
-- forbidden, so we handle those separately
- (typeable_instances, local_infos) = splitTypeable env local_infos'
+ (typeable_instances, local_infos)
+ = partition (bad_typeable_instance env) local_infos'
; addClsInsts local_infos $
addFamInsts fam_insts $
@@ -400,7 +401,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
else tcDeriving tycl_decls inst_decls deriv_decls
-- Fail if there are any handwritten instance of poly-kinded Typeable
- ; mapM_ (failWithTc . instMsg) typeable_instances
+ ; mapM_ typeable_err typeable_instances
-- Check that if the module is compiled with -XSafe, there are no
-- hand written instances of old Typeable as then unsafe casts could be
@@ -422,18 +423,14 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
}}
where
-- Separate the Typeable instances from the rest
- splitTypeable _ [] = ([],[])
- splitTypeable env (i:is) =
- let (typeableInsts, otherInsts) = splitTypeable env is
- in if -- We will filter out instances of Typeable
- (typeableClassName == is_cls_nm (iSpec i))
- -- but not those that come from Data.Typeable.Internal
- && tcg_mod env /= tYPEABLE_INTERNAL
- -- nor those from an .hs-boot or .hsig file
- -- (deriving can't be used there)
- && not (isHsBootOrSig (tcg_src env))
- then (i:typeableInsts, otherInsts)
- else (typeableInsts, i:otherInsts)
+ bad_typeable_instance env i
+ = -- Class name is Typeable
+ typeableClassName == is_cls_nm (iSpec i)
+ -- but not those that come from Data.Typeable.Internal
+ && tcg_mod env /= tYPEABLE_INTERNAL
+ -- nor those from an .hs-boot or .hsig file
+ -- (deriving can't be used there)
+ && not (isHsBootOrSig (tcg_src env))
overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem`
[Overlappable, Overlapping, Overlaps]
@@ -443,9 +440,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
ptext (sLit "Replace the following instance:"))
2 (pprInstanceHdr (iSpec i))
- instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace "
- ++ "the following instance:"))
- 2 (pprInstance (iSpec i))
+ typeable_err i
+ = setSrcSpan (getSrcSpan ispec) $
+ addErrTc $ hang (ptext (sLit "Typeable instances can only be derived"))
+ 2 (vcat [ ptext (sLit "Try") <+> quotes (ptext (sLit "deriving instance Typeable")
+ <+> pp_tc)
+ , ptext (sLit "(requires StandaloneDeriving)") ])
+ where
+ ispec = iSpec i
+ pp_tc | [_kind, ty] <- is_tys ispec
+ , Just (tc,_) <- tcSplitTyConApp_maybe ty
+ = ppr tc
+ | otherwise = ptext (sLit "<tycon>")
addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
diff --git a/testsuite/tests/deriving/should_fail/T9687.hs b/testsuite/tests/deriving/should_fail/T9687.hs
new file mode 100644
index 0000000..818878b
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T9687.hs
@@ -0,0 +1,4 @@
+module T9687 where
+import Data.Typeable
+
+instance Typeable (a,b,c,d,e,f,g,h)
diff --git a/testsuite/tests/polykinds/T8132.stderr b/testsuite/tests/deriving/should_fail/T9687.stderr
similarity index 54%
copy from testsuite/tests/polykinds/T8132.stderr
copy to testsuite/tests/deriving/should_fail/T9687.stderr
index 6c567de..10619a6 100644
--- a/testsuite/tests/polykinds/T8132.stderr
+++ b/testsuite/tests/deriving/should_fail/T9687.stderr
@@ -1,5 +1,5 @@
-T8132.hs:6:10:
+T9687.hs:4:10:
Typeable instances can only be derived
- Try ‘deriving instance Typeable K’
+ Try ‘deriving instance Typeable (,,,,,,,)’
(requires StandaloneDeriving)
diff --git a/testsuite/tests/deSugar/should_run/T5472.stdout b/testsuite/tests/deriving/should_fail/T9730.stderr
similarity index 100%
copy from testsuite/tests/deSugar/should_run/T5472.stdout
copy to testsuite/tests/deriving/should_fail/T9730.stderr
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index 7700d62..54a6f95 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -51,4 +51,5 @@ test('T6147', normal, compile_fail, [''])
test('T8851', normal, compile_fail, [''])
test('T9071', normal, multimod_compile_fail, ['T9071',''])
test('T9071_2', normal, compile_fail, [''])
+test('T9687', normal, compile_fail, [''])
More information about the ghc-commits
mailing list