diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-30 16:33:34 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-11-04 10:38:03 +0000 |
commit | 6d1ac963d87b83f1cac85c18729cfbc29c390383 (patch) | |
tree | 4eff3bfb76d87e3f2782cb64d4e8cebfe4a7099a | |
parent | f861fc6ad8e5504a4fecfc9bb0945fe2d313687c (diff) | |
download | haskell-6d1ac963d87b83f1cac85c18729cfbc29c390383.tar.gz |
Improve error message for a handwritten Typeable instance
-rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 42 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_fail/T9687.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_fail/T9687.stderr | 5 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_fail/T9730.stderr | 1 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_fail/all.T | 1 |
5 files changed, 35 insertions, 18 deletions
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 10bc466f27..d22938eba2 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 0000000000..818878b215 --- /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/deriving/should_fail/T9687.stderr b/testsuite/tests/deriving/should_fail/T9687.stderr new file mode 100644 index 0000000000..10619a6575 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T9687.stderr @@ -0,0 +1,5 @@ + +T9687.hs:4:10: + Typeable instances can only be derived + Try ‘deriving instance Typeable (,,,,,,,)’ + (requires StandaloneDeriving) diff --git a/testsuite/tests/deriving/should_fail/T9730.stderr b/testsuite/tests/deriving/should_fail/T9730.stderr new file mode 100644 index 0000000000..0519ecba6e --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T9730.stderr @@ -0,0 +1 @@ +
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T index 7700d62be1..54a6f95afc 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, ['']) |