Commit f4ead30b authored by David Terei's avatar David Terei

Warn for Safe Haskell when -XOverlappingInstances or

-XIncoherentInstances turned on.
parent c96a613c
......@@ -774,6 +774,7 @@ data DynFlags = DynFlags {
thOnLoc :: SrcSpan,
newDerivOnLoc :: SrcSpan,
overlapInstLoc :: SrcSpan,
incoherentOnLoc :: SrcSpan,
pkgTrustOnLoc :: SrcSpan,
warnSafeOnLoc :: SrcSpan,
warnUnsafeOnLoc :: SrcSpan,
......@@ -1461,6 +1462,7 @@ defaultDynFlags mySettings =
thOnLoc = noSrcSpan,
newDerivOnLoc = noSrcSpan,
overlapInstLoc = noSrcSpan,
incoherentOnLoc = noSrcSpan,
pkgTrustOnLoc = noSrcSpan,
warnSafeOnLoc = noSrcSpan,
warnUnsafeOnLoc = noSrcSpan,
......@@ -1791,17 +1793,23 @@ combineSafeFlags a b | a == Sf_None = return b
-- * function to turn the flag off
unsafeFlags, unsafeFlagsForInfer
:: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
xopt Opt_GeneralizedNewtypeDeriving,
flip xopt_unset Opt_GeneralizedNewtypeDeriving),
("-XTemplateHaskell", thOnLoc,
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)]
unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
xopt Opt_GeneralizedNewtypeDeriving,
flip xopt_unset Opt_GeneralizedNewtypeDeriving)
, ("-XTemplateHaskell", thOnLoc,
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)
]
unsafeFlagsForInfer = unsafeFlags ++
-- TODO: Can we do better than this for inference?
[("-XOverlappingInstances", overlapInstLoc,
[ ("-XOverlappingInstances", overlapInstLoc,
xopt Opt_OverlappingInstances,
flip xopt_unset Opt_OverlappingInstances)]
flip xopt_unset Opt_OverlappingInstances)
, ("-XIncoherentInstances", incoherentOnLoc,
xopt Opt_IncoherentInstances,
flip xopt_unset Opt_IncoherentInstances)
]
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
......@@ -2881,7 +2889,7 @@ xFlags = [
( "ImplicitParams", Opt_ImplicitParams, nop ),
( "ImplicitPrelude", Opt_ImplicitPrelude, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
( "IncoherentInstances", Opt_IncoherentInstances, setIncoherentInsts ),
( "InstanceSigs", Opt_InstanceSigs, nop ),
( "InterruptibleFFI", Opt_InterruptibleFFI, nop ),
( "JavaScriptFFI", Opt_JavaScriptFFI, nop ),
......@@ -2904,9 +2912,7 @@ xFlags = [
( "NullaryTypeClasses", Opt_NullaryTypeClasses,
deprecatedForExtension "MultiParamTypeClasses" ),
( "NumDecimals", Opt_NumDecimals, nop),
( "OverlappingInstances", Opt_OverlappingInstances,
\ turn_on -> when turn_on
$ deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" ),
( "OverlappingInstances", Opt_OverlappingInstances, setOverlappingInsts),
( "OverloadedLists", Opt_OverloadedLists, nop),
( "OverloadedStrings", Opt_OverloadedStrings, nop ),
( "PackageImports", Opt_PackageImports, nop ),
......@@ -3226,6 +3232,19 @@ setGenDeriving :: TurnOnFlag -> DynP ()
setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })
setGenDeriving False = return ()
setOverlappingInsts :: TurnOnFlag -> DynP ()
setOverlappingInsts False = return ()
setOverlappingInsts True = do
l <- getCurLoc
upd (\d -> d { overlapInstLoc = l })
deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS"
setIncoherentInsts :: TurnOnFlag -> DynP ()
setIncoherentInsts False = return ()
setIncoherentInsts True = do
l <- getCurLoc
upd (\d -> d { incoherentOnLoc = l })
checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
#ifdef GHCI
checkTemplateHaskellOk turn_on
......
......@@ -432,8 +432,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- (deriving can't be used there)
&& not (isHsBootOrSig (tcg_src env))
overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem`
[Overlappable, Overlapping, Overlaps]
overlapCheck ty = overlapMode (is_flag $ iSpec ty) /= NoOverlap
genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
genInstErr i = hang (ptext (sLit $ "Generic instances can only be "
++ "derived in Safe Haskell.") $+$
......
{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered15 where
module UnsafeInfered16 where
class C a where
f :: a -> String
......
UnsafeInfered16.hs:1:16: Warning:
‘UnsafeInfered15’ has been inferred as unsafe!
‘UnsafeInfered16’ has been inferred as unsafe!
Reason:
UnsafeInfered16.hs:8:30:
[overlapping] overlap mode isn't allowed in Safe Haskell
......
{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered15 where
module UnsafeInfered17 where
class C a where
f :: a -> String
......
UnsafeInfered17.hs:1:16: Warning:
‘UnsafeInfered15’ has been inferred as unsafe!
‘UnsafeInfered17’ has been inferred as unsafe!
Reason:
UnsafeInfered17.hs:8:29:
[incoherent] overlap mode isn't allowed in Safe Haskell
......
{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
module UnsafeInfered18 where
class C a where
f :: a -> String
instance C a where
f _ = "a"
UnsafeInfered18.hs:3:14: Warning:
-XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS
UnsafeInfered18.hs:1:16: Warning:
‘UnsafeInfered18’ has been inferred as unsafe!
Reason:
UnsafeInfered18.hs:3:14:
-XOverlappingInstances is not allowed in Safe Haskell
UnsafeInfered18.hs:9:10:
[overlap ok] overlap mode isn't allowed in Safe Haskell
{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
module UnsafeInfered19 where
class C a where
f :: a -> String
instance C a where
f _ = "a"
UnsafeInfered19.hs:1:16: Warning:
‘UnsafeInfered19’ has been inferred as unsafe!
Reason:
UnsafeInfered19.hs:3:14:
-XIncoherentInstances is not allowed in Safe Haskell
UnsafeInfered19.hs:9:10:
[incoherent] overlap mode isn't allowed in Safe Haskell
<no location info>:
Failing due to -Werror.
......@@ -65,6 +65,8 @@ test('UnsafeInfered14', normal, compile_fail, [''])
test('UnsafeInfered15', normal, compile_fail, [''])
test('UnsafeInfered16', normal, compile_fail, [''])
test('UnsafeInfered17', normal, compile_fail, [''])
test('UnsafeInfered18', normal, compile, [''])
test('UnsafeInfered19', normal, compile_fail, [''])
# Mixed tests
test('Mixed01', 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