summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Builtin/Names.hs21
-rw-r--r--compiler/GHC/Core/Predicate.hs25
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs16
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs8
-rw-r--r--compiler/GHC/Tc/Solver.hs88
-rw-r--r--compiler/GHC/Types/Error/Codes.hs1
6 files changed, 123 insertions, 36 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index d72e911541..d8c7519b7e 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -452,6 +452,10 @@ basicKnownKeyNames
-- Overloaded record fields
hasFieldClassName,
+ -- ExceptionContext
+ exceptionContextTyConName,
+ emptyExceptionContextName,
+
-- Call Stacks
callStackTyConName,
emptyCallStackName, pushCallStackName,
@@ -561,7 +565,8 @@ gHC_PRIM, gHC_PRIM_PANIC,
tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,
- cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,
+ cONTROL_EXCEPTION_BASE, gHC_EXCEPTION_CONTEXT,
+ gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,
gHC_TYPENATS, gHC_TYPENATS_INTERNAL,
dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module
@@ -623,6 +628,7 @@ rANDOM = mkBaseModule (fsLit "System.Random")
gHC_EXTS = mkBaseModule (fsLit "GHC.Exts")
gHC_IS_LIST = mkBaseModule (fsLit "GHC.IsList")
cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
+gHC_EXCEPTION_CONTEXT = mkBaseModule (fsLit "GHC.Exception.Context")
gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics")
gHC_TYPEERROR = mkBaseModule (fsLit "GHC.TypeError")
gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits")
@@ -1632,6 +1638,13 @@ hasFieldClassName :: Name
hasFieldClassName
= clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey
+-- ExceptionContext
+exceptionContextTyConName, emptyExceptionContextName :: Name
+exceptionContextTyConName =
+ tcQual gHC_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey
+emptyExceptionContextName
+ = varQual gHC_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey
+
-- Source Locations
callStackTyConName, emptyCallStackName, pushCallStackName,
srcLocDataConName :: Name
@@ -2103,6 +2116,9 @@ typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415
typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416
constPtrTyConKey = mkPreludeTyConUnique 417
+exceptionContextTyConKey :: Unique
+exceptionContextTyConKey = mkPreludeTyConUnique 420
+
{-
************************************************************************
* *
@@ -2553,6 +2569,9 @@ fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560
makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 561
+emptyExceptionContextKey :: Unique
+emptyExceptionContextKey = mkPreludeMiscIdUnique 562
+
-- Unsafe coercion proofs
unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique
unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index c8d280259a..499f0c5fa8 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -26,7 +26,8 @@ module GHC.Core.Predicate (
-- Implicit parameters
isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,
- isCallStackTy, isCallStackPred, isCallStackPredTy,
+ isCallStackPred, isCallStackPredTy,
+ isExceptionContextPred,
isIPPred_maybe,
-- Evidence variables
@@ -292,6 +293,28 @@ has_ip_super_classes rec_clss cls tys
initIPRecTc :: RecTcChecker
initIPRecTc = setRecTcMaxBound 1 initRecTc
+-- --------------------- ExceptionContext predicates --------------------------
+
+-- | Is a 'PredType' an @ExceptionContext@ implicit parameter?
+--
+-- If so, return the name of the parameter.
+isExceptionContextPred :: Class -> [Type] -> Maybe FastString
+isExceptionContextPred cls tys
+ | [ty1, ty2] <- tys
+ , isIPClass cls
+ , isExceptionContextTy ty2
+ = isStrLitTy ty1
+ | otherwise
+ = Nothing
+
+-- | Is a type a 'CallStack'?
+isExceptionContextTy :: Type -> Bool
+isExceptionContextTy ty
+ | Just tc <- tyConAppTyCon_maybe ty
+ = tc `hasKey` exceptionContextTyConKey
+ | otherwise
+ = False
+
-- --------------------- CallStack predicates ---------------------------------
isCallStackPredTy :: Type -> Bool
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 269063ae65..d58d5bae2d 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1862,6 +1862,17 @@ instance Diagnostic TcRnMessage where
TcRnNonCanonicalDefinition reason inst_ty
-> mkSimpleDecorated $
pprNonCanonicalDefinition inst_ty reason
+ TcRnDefaultedExceptionContext ct_loc ->
+ mkSimpleDecorated $ vcat [ header, warning, proposal ]
+ where
+ header, warning, proposal :: SDoc
+ header
+ = vcat [ text "Solving for an implicit ExceptionContext constraint"
+ , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ]
+ warning
+ = vcat [ text "Future versions of GHC will turn this warning into an error." ]
+ proposal
+ = vcat [ text "See GHC Proposal #330." ]
diagnosticReason = \case
TcRnUnknownMessage m
@@ -2491,7 +2502,8 @@ instance Diagnostic TcRnMessage where
-> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances
TcRnNonCanonicalDefinition (NonCanonicalMonad _) _
-> WarningWithFlag Opt_WarnNonCanonicalMonadInstances
-
+ TcRnDefaultedExceptionContext{}
+ -> WarningWithoutFlag --WarningWithFlag TODO
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3155,6 +3167,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnNonCanonicalDefinition reason _
-> suggestNonCanonicalDefinition reason
+ TcRnDefaultedExceptionContext _
+ -> noHints
diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode
diagnosticCode = constructorCode
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 68c5ca2869..7b1e68490b 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -4053,6 +4053,14 @@ data TcRnMessage where
-> !(LHsSigType GhcRn) -- ^ The instance type
-> TcRnMessage
+ {-| TcRnDefaultedExceptionContext is a warning that is triggered when the
+ backward-compatibility logic solving for implicit ExceptionContext
+ constraints fires.
+
+ Test cases: TODO
+ -}
+ TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index eaa62e44ea..dc2924c1aa 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -33,7 +33,6 @@ import GHC.Data.Bag
import GHC.Core.Class
import GHC.Core
import GHC.Core.DataCon
-import GHC.Core.InstEnv ( Coherence(IsCoherent) )
import GHC.Core.Make
import GHC.Driver.Session
import GHC.Data.FastString
@@ -56,6 +55,7 @@ import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad as TcS
import GHC.Tc.Types.Constraint
import GHC.Tc.Instance.FunDeps
+import GHC.Core.InstEnv ( Coherence(..) )
import GHC.Core.Predicate
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
@@ -67,6 +67,7 @@ import GHC.Core.Unify ( tcMatchTyKi )
import GHC.Unit.Module ( getModule )
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Types.TyThing ( MonadThings(lookupId) )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Basic
@@ -80,7 +81,7 @@ import Control.Monad.Trans.State.Strict ( StateT(runStateT), put )
import Data.Foldable ( toList )
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
-import GHC.Data.Maybe ( mapMaybe )
+import GHC.Data.Maybe ( mapMaybe, runMaybeT, MaybeT )
{-
*********************************************************************************
@@ -545,10 +546,7 @@ simplifyTopWanteds wanteds
try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
try_callstack_defaulting wc
- | isEmptyWC wc
- = return wc
- | otherwise
- = defaultCallStacks wc
+ = defaultConstraints [defaultCallStack, defaultExceptionContext] wc
-- | If an implication contains a Given of the form @Unsatisfiable msg@, use
-- it to solve all Wanteds within the implication.
@@ -693,41 +691,65 @@ This allows us to indirectly box constraints with different representations
(such as primitive equality constraints).
-}
+defaultExceptionContext :: Ct -> MaybeT TcS ()
+defaultExceptionContext ct
+ = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+ ; Just {} <- pure $ isExceptionContextPred cls tys
+ ; emptyEC <- Var <$> lift (lookupId emptyExceptionContextName)
+ ; let ev = ctEvidence ct
+ ; let ev_tm = mkEvCast emptyEC (wrapIP (ctEvPred ev))
+ ; lift $ warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)
+ ; lift $ setEvBindIfWanted ev IsCoherent ev_tm
+ }
+
-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.
-defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-defaultCallStacks wanteds
+defaultCallStack :: Ct -> MaybeT TcS ()
+defaultCallStack ct
+ = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+ ; Just {} <- pure $ isCallStackPred cls tys
+ ; lift $ solveCallStack (ctEvidence ct) EvCsEmpty
+ }
+
+defaultConstraints :: [Ct -> MaybeT TcS ()]
+ -> WantedConstraints
+ -> TcS WantedConstraints
+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+defaultConstraints defaulting_strategies wanteds
+ | isEmptyWC wanteds = return wanteds
+ | otherwise
= do simples <- handle_simples (wc_simple wanteds)
mb_implics <- mapBagM handle_implic (wc_impl wanteds)
return (wanteds { wc_simple = simples
, wc_impl = catBagMaybes mb_implics })
where
-
- handle_simples simples
- = catBagMaybes <$> mapBagM defaultCallStack simples
-
- handle_implic :: Implication -> TcS (Maybe Implication)
- -- The Maybe is because solving the CallStack constraint
- -- may well allow us to discard the implication entirely
- handle_implic implic
- | isSolvedStatus (ic_status implic)
- = return (Just implic)
- | otherwise
- = do { wanteds <- setEvBindsTcS (ic_binds implic) $
- -- defaultCallStack sets a binding, so
- -- we must set the correct binding group
- defaultCallStacks (ic_wanted implic)
- ; setImplicationStatus (implic { ic_wanted = wanteds }) }
-
- defaultCallStack ct
- | ClassPred cls tys <- classifyPredType (ctPred ct)
- , Just {} <- isCallStackPred cls tys
- = do { solveCallStack (ctEvidence ct) EvCsEmpty
- ; return Nothing }
-
- defaultCallStack ct
- = return (Just ct)
+ handle_simples :: Bag Ct -> TcS (Bag Ct)
+ handle_simples simples
+ = catBagMaybes <$> mapBagM handle_simple simples
+ where
+ handle_simple :: Ct -> TcS (Maybe Ct)
+ handle_simple ct = go defaulting_strategies
+ where
+ go [] = return (Just ct)
+ go (f:fs) = do
+ mb <- runMaybeT (f ct)
+ case mb of
+ Just () -> return Nothing
+ Nothing -> go fs
+
+ handle_implic :: Implication -> TcS (Maybe Implication)
+ -- The Maybe is because solving the CallStack constraint
+ -- may well allow us to discard the implication entirely
+ handle_implic implic
+ | isSolvedStatus (ic_status implic)
+ = return (Just implic)
+ | otherwise
+ = do { wanteds <- setEvBindsTcS (ic_binds implic) $
+ -- defaultCallStack sets a binding, so
+ -- we must set the correct binding group
+ defaultConstraints defaulting_strategies (ic_wanted implic)
+ ; setImplicationStatus (implic { ic_wanted = wanteds }) }
{- Note [When to do type-class defaulting]
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 5025ff022f..d465422e95 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -600,6 +600,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnBindingNameConflict" = 10498
GhcDiagnosticCode "NonCanonicalMonoid" = 50928
GhcDiagnosticCode "NonCanonicalMonad" = 22705
+ GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235
-- PatSynInvalidRhsReason
GhcDiagnosticCode "PatSynNotInvertible" = 69317
View Lorry Controller Status