{-# LANGUAGE CPP #-}
module GHC.Tc.Solver(
InferMode(..), simplifyInfer, findInferredDiff,
growThetaTyVars,
simplifyAmbiguityCheck,
simplifyDefault,
simplifyTop, simplifyTopImplic,
simplifyInteractive,
solveEqualities,
pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX,
reportUnsolvedEqualities,
simplifyWantedsTcM,
tcCheckGivens,
tcCheckWanteds,
tcNormalise,
captureTopConstraints,
simplifyTopWanteds,
promoteTyVarSet, simplifyAndEmitFlatConstraints,
solveWanteds, solveWantedsAndDrop,
approximateWC, runTcSDeriveds
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Data.Bag
import GHC.Core.Class ( Class, classKey, classTyCon )
import GHC.Driver.Session
import GHC.Tc.Utils.Instantiate
import GHC.Data.List.SetOps
import GHC.Types.Name
import GHC.Types.Id( idType )
import GHC.Utils.Outputable
import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Tc.Errors
import GHC.Tc.Types.Evidence
import GHC.Tc.Solver.Interact
import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack )
import GHC.Tc.Solver.Rewrite ( rewriteType )
import GHC.Tc.Utils.Unify ( buildTvImplication )
import GHC.Tc.Utils.TcMType as TcM
import GHC.Tc.Utils.Monad as TcM
import GHC.Tc.Solver.Monad as TcS
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Ppr
import GHC.Builtin.Types ( liftedRepTy, manyDataConTy )
import GHC.Core.Unify ( tcMatchTyKi )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Basic ( IntWithInf, intGtLimit )
import GHC.Types.Error
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Foldable ( toList )
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
captureTopConstraints :: forall a. TcM a -> TcM (a, WantedConstraints)
captureTopConstraints TcM a
thing_inside
= do { TcRef WantedConstraints
static_wc_var <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
TcM.newTcRef WantedConstraints
emptyWC ;
; (Maybe a
mb_res, WantedConstraints
lie) <- forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
TcM.updGblEnv (\TcGblEnv
env -> TcGblEnv
env { tcg_static_wc :: TcRef WantedConstraints
tcg_static_wc = TcRef WantedConstraints
static_wc_var } ) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
TcM.tryCaptureConstraints TcM a
thing_inside
; WantedConstraints
stWC <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef TcRef WantedConstraints
static_wc_var
; case Maybe a
mb_res of
Just a
res -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, WantedConstraints
lie WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
stWC)
Maybe a
Nothing -> do { Bag EvBind
_ <- WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
lie; forall env a. IOEnv env a
failM } }
simplifyTopImplic :: Bag Implication -> TcM ()
simplifyTopImplic :: Bag Implication -> TcM ()
simplifyTopImplic Bag Implication
implics
= do { Bag EvBind
empty_binds <- WantedConstraints -> TcM (Bag EvBind)
simplifyTop (Bag Implication -> WantedConstraints
mkImplicWC Bag Implication
implics)
; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
wanteds
= do { String -> SDoc -> TcM ()
traceTc String
"simplifyTop {" forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"wanted = " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanteds
; ((WantedConstraints
final_wc, Cts
unsafe_ol), EvBindMap
binds1) <- forall a. TcS a -> TcM (a, EvBindMap)
runTcS forall a b. (a -> b) -> a -> b
$
do { WantedConstraints
final_wc <- WantedConstraints -> TcS WantedConstraints
simplifyTopWanteds WantedConstraints
wanteds
; Cts
unsafe_ol <- TcS Cts
getSafeOverlapFailures
; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
final_wc, Cts
unsafe_ol) }
; String -> SDoc -> TcM ()
traceTc String
"End simplifyTop }" SDoc
empty
; Bag EvBind
binds2 <- WantedConstraints -> TcM (Bag EvBind)
reportUnsolved WantedConstraints
final_wc
; String -> SDoc -> TcM ()
traceTc String
"reportUnsolved (unsafe overlapping) {" SDoc
empty
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cts -> Bool
isEmptyCts Cts
unsafe_ol) forall a b. (a -> b) -> a -> b
$ do {
; TcRef (Messages DecoratedSDoc)
errs_var <- TcRn (TcRef (Messages DecoratedSDoc))
getErrsVar
; Messages DecoratedSDoc
saved_msg <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef TcRef (Messages DecoratedSDoc)
errs_var
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef TcRef (Messages DecoratedSDoc)
errs_var forall e. Messages e
emptyMessages
; WantedConstraints -> TcM ()
warnAllUnsolved forall a b. (a -> b) -> a -> b
$ WantedConstraints
emptyWC { wc_simple :: Cts
wc_simple = Cts
unsafe_ol }
; Bag (MsgEnvelope DecoratedSDoc)
whyUnsafe <- forall e. Messages e -> Bag (MsgEnvelope e)
getWarningMessages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
TcM.readTcRef TcRef (Messages DecoratedSDoc)
errs_var
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
TcM.writeTcRef TcRef (Messages DecoratedSDoc)
errs_var Messages DecoratedSDoc
saved_msg
; Bag (MsgEnvelope DecoratedSDoc) -> TcM ()
recordUnsafeInfer Bag (MsgEnvelope DecoratedSDoc)
whyUnsafe
}
; String -> SDoc -> TcM ()
traceTc String
"reportUnsolved (unsafe overlapping) }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindMap -> Bag EvBind
evBindMapBinds EvBindMap
binds1 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
binds2) }
pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities :: forall a. SkolemInfo -> [TcTyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info [TcTyVar]
skol_tvs TcM a
thing_inside
= do { (TcLevel
tclvl, WantedConstraints
wanted, a
res) <- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX
String
"pushLevelAndSolveEqualities" TcM a
thing_inside
; SkolemInfo -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info [TcTyVar]
skol_tvs TcLevel
tclvl WantedConstraints
wanted
; forall (m :: * -> *) a. Monad m => a -> m a
return a
res }
pushLevelAndSolveEqualitiesX :: String -> TcM a
-> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX :: forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
callsite TcM a
thing_inside
= do { String -> SDoc -> TcM ()
traceTc String
"pushLevelAndSolveEqualitiesX {" (String -> SDoc
text String
"Called from" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
callsite)
; (TcLevel
tclvl, (WantedConstraints
wanted, a
res))
<- forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM forall a b. (a -> b) -> a -> b
$
do { (a
res, WantedConstraints
wanted) <- forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints TcM a
thing_inside
; WantedConstraints
wanted <- forall a. TcS a -> TcM a
runTcSEqualities (WantedConstraints -> TcS WantedConstraints
simplifyTopWanteds WantedConstraints
wanted)
; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
wanted,a
res) }
; String -> SDoc -> TcM ()
traceTc String
"pushLevelAndSolveEqualities }" ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Residual:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted
, String -> SDoc
text String
"Level:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl ])
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl, WantedConstraints
wanted, a
res) }
solveEqualities :: String -> TcM a -> TcM a
solveEqualities :: forall a. String -> TcM a -> TcM a
solveEqualities String
callsite TcM a
thing_inside
= do { String -> SDoc -> TcM ()
traceTc String
"solveEqualities {" (String -> SDoc
text String
"Called from" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
callsite)
; (a
res, WantedConstraints
wanted) <- forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints TcM a
thing_inside
; WantedConstraints -> TcM ()
simplifyAndEmitFlatConstraints WantedConstraints
wanted
; String -> SDoc -> TcM ()
traceTc String
"solveEqualities }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return a
res }
simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()
simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()
simplifyAndEmitFlatConstraints WantedConstraints
wanted
= do {
WantedConstraints
wanted <- forall a. TcS a -> TcM a
runTcSEqualities (WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wanted)
; WantedConstraints
wanted <- WantedConstraints -> TcM WantedConstraints
TcM.zonkWC WantedConstraints
wanted
; String -> SDoc -> TcM ()
traceTc String
"emitFlatConstraints {" (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)
; case WantedConstraints -> Maybe (Cts, Bag Hole)
floatKindEqualities WantedConstraints
wanted of
Maybe (Cts, Bag Hole)
Nothing -> do { String -> SDoc -> TcM ()
traceTc String
"emitFlatConstraints } failing" (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)
; TcLevel
tclvl <- TcM TcLevel
TcM.getTcLevel
; Implication
implic <- SkolemInfo
-> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM Implication
buildTvImplication SkolemInfo
UnkSkol [] (TcLevel -> TcLevel
pushTcLevel TcLevel
tclvl) WantedConstraints
wanted
; Implication -> TcM ()
emitImplication Implication
implic
; forall env a. IOEnv env a
failM }
Just (Cts
simples, Bag Hole
holes)
-> do { Bool
_ <- VarSet -> TcM Bool
promoteTyVarSet (Cts -> VarSet
tyCoVarsOfCts Cts
simples)
; String -> SDoc -> TcM ()
traceTc String
"emitFlatConstraints }" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"simples:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Cts
simples
, String -> SDoc
text String
"holes: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bag Hole
holes ]
; Bag Hole -> TcM ()
emitHoles Bag Hole
holes
; Cts -> TcM ()
emitSimples Cts
simples } }
floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)
floatKindEqualities :: WantedConstraints -> Maybe (Cts, Bag Hole)
floatKindEqualities WantedConstraints
wc = VarSet -> WantedConstraints -> Maybe (Cts, Bag Hole)
float_wc VarSet
emptyVarSet WantedConstraints
wc
where
float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)
float_wc :: VarSet -> WantedConstraints -> Maybe (Cts, Bag Hole)
float_wc VarSet
trapping_tvs (WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples
, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics
, wc_holes :: WantedConstraints -> Bag Hole
wc_holes = Bag Hole
holes })
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Ct -> Bool
is_floatable Cts
simples
= do { (Cts
inner_simples, Bag Hole
inner_holes)
<- forall (m :: * -> *) a b c.
Monad m =>
(a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c)
flatMapBagPairM (VarSet -> Implication -> Maybe (Cts, Bag Hole)
float_implic VarSet
trapping_tvs) Bag Implication
implics
; forall (m :: * -> *) a. Monad m => a -> m a
return ( Cts
simples forall a. Bag a -> Bag a -> Bag a
`unionBags` Cts
inner_simples
, Bag Hole
holes forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag Hole
inner_holes) }
| Bool
otherwise
= forall a. Maybe a
Nothing
where
is_floatable :: Ct -> Bool
is_floatable Ct
ct
| Ct -> Bool
insolubleEqCt Ct
ct = Bool
False
| Bool
otherwise = Ct -> VarSet
tyCoVarsOfCt Ct
ct VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
trapping_tvs
float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)
float_implic :: VarSet -> Implication -> Maybe (Cts, Bag Hole)
float_implic VarSet
trapping_tvs (Implic { ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wanted, ic_given_eqs :: Implication -> HasGivenEqs
ic_given_eqs = HasGivenEqs
given_eqs
, ic_skols :: Implication -> [TcTyVar]
ic_skols = [TcTyVar]
skols, ic_status :: Implication -> ImplicStatus
ic_status = ImplicStatus
status })
| ImplicStatus -> Bool
isInsolubleStatus ImplicStatus
status
= forall a. Maybe a
Nothing
| Bool
otherwise
= do { (Cts
simples, Bag Hole
holes) <- VarSet -> WantedConstraints -> Maybe (Cts, Bag Hole)
float_wc VarSet
new_trapping_tvs WantedConstraints
wanted
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall a. Bag a -> Bool
isEmptyBag Cts
simples) Bool -> Bool -> Bool
&& HasGivenEqs
given_eqs forall a. Eq a => a -> a -> Bool
== HasGivenEqs
MaybeGivenEqs) forall a b. (a -> b) -> a -> b
$
forall a. Maybe a
Nothing
; forall (m :: * -> *) a. Monad m => a -> m a
return (Cts
simples, Bag Hole
holes) }
where
new_trapping_tvs :: VarSet
new_trapping_tvs = VarSet
trapping_tvs VarSet -> [TcTyVar] -> VarSet
`extendVarSetList` [TcTyVar]
skols
reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel
-> WantedConstraints -> TcM ()
reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info [TcTyVar]
skol_tvs TcLevel
tclvl WantedConstraints
wanted
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanted
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
do { Implication
implic <- SkolemInfo
-> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM Implication
buildTvImplication SkolemInfo
skol_info [TcTyVar]
skol_tvs TcLevel
tclvl WantedConstraints
wanted
; WantedConstraints -> TcM ()
reportAllUnsolved (Bag Implication -> WantedConstraints
mkImplicWC (forall a. a -> Bag a
unitBag Implication
implic)) }
simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints
simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints
simplifyTopWanteds WantedConstraints
wanteds
= do { WantedConstraints
wc_first_go <- forall a. TcS a -> TcS a
nestTcS (WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop WantedConstraints
wanteds)
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; DynFlags -> WantedConstraints -> TcS WantedConstraints
try_tyvar_defaulting DynFlags
dflags WantedConstraints
wc_first_go }
where
try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints
try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints
try_tyvar_defaulting DynFlags
dflags WantedConstraints
wc
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wc
= forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
| WantedConstraints -> Bool
insolubleWC WantedConstraints
wc
, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PrintExplicitRuntimeReps DynFlags
dflags
= WantedConstraints -> TcS WantedConstraints
try_class_defaulting WantedConstraints
wc
| Bool
otherwise
= do { [TcTyVar]
free_tvs <- [TcTyVar] -> TcS [TcTyVar]
TcS.zonkTyCoVarsAndFVList (WantedConstraints -> [TcTyVar]
tyCoVarsOfWCList WantedConstraints
wc)
; let meta_tvs :: [TcTyVar]
meta_tvs = forall a. (a -> Bool) -> [a] -> [a]
filter (TcTyVar -> Bool
isTyVar forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> TcTyVar -> Bool
isMetaTyVar) [TcTyVar]
free_tvs
; [Bool]
defaulted <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcTyVar -> TcS Bool
defaultTyVarTcS [TcTyVar]
meta_tvs
; if forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
defaulted
then do { WantedConstraints
wc_residual <- forall a. TcS a -> TcS a
nestTcS (WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wc)
; WantedConstraints -> TcS WantedConstraints
try_class_defaulting WantedConstraints
wc_residual }
else WantedConstraints -> TcS WantedConstraints
try_class_defaulting WantedConstraints
wc }
try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
try_class_defaulting WantedConstraints
wc
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wc Bool -> Bool -> Bool
|| WantedConstraints -> Bool
insolubleWC WantedConstraints
wc
= forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
| Bool
otherwise
= do { Bool
something_happened <- WantedConstraints -> TcS Bool
applyDefaultingRules WantedConstraints
wc
; if Bool
something_happened
then do { WantedConstraints
wc_residual <- forall a. TcS a -> TcS a
nestTcS (WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop WantedConstraints
wc)
; WantedConstraints -> TcS WantedConstraints
try_class_defaulting WantedConstraints
wc_residual }
else WantedConstraints -> TcS WantedConstraints
try_callstack_defaulting WantedConstraints
wc }
try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
try_callstack_defaulting WantedConstraints
wc
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wc
= forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
| Bool
otherwise
= WantedConstraints -> TcS WantedConstraints
defaultCallStacks WantedConstraints
wc
defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
defaultCallStacks WantedConstraints
wanteds
= do Cts
simples <- Cts -> TcS Cts
handle_simples (WantedConstraints -> Cts
wc_simple WantedConstraints
wanteds)
Bag (Maybe Implication)
mb_implics <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Implication -> TcS (Maybe Implication)
handle_implic (WantedConstraints -> Bag Implication
wc_impl WantedConstraints
wanteds)
forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
wanteds { wc_simple :: Cts
wc_simple = Cts
simples
, wc_impl :: Bag Implication
wc_impl = forall a. Bag (Maybe a) -> Bag a
catBagMaybes Bag (Maybe Implication)
mb_implics })
where
handle_simples :: Cts -> TcS Cts
handle_simples Cts
simples
= forall a. Bag (Maybe a) -> Bag a
catBagMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Ct -> TcS (Maybe Ct)
defaultCallStack Cts
simples
handle_implic :: Implication -> TcS (Maybe Implication)
handle_implic :: Implication -> TcS (Maybe Implication)
handle_implic Implication
implic
| ImplicStatus -> Bool
isSolvedStatus (Implication -> ImplicStatus
ic_status Implication
implic)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Implication
implic)
| Bool
otherwise
= do { WantedConstraints
wanteds <- forall a. EvBindsVar -> TcS a -> TcS a
setEvBindsTcS (Implication -> EvBindsVar
ic_binds Implication
implic) forall a b. (a -> b) -> a -> b
$
WantedConstraints -> TcS WantedConstraints
defaultCallStacks (Implication -> WantedConstraints
ic_wanted Implication
implic)
; Implication -> TcS (Maybe Implication)
setImplicationStatus (Implication
implic { ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
wanteds }) }
defaultCallStack :: Ct -> TcS (Maybe Ct)
defaultCallStack Ct
ct
| ClassPred Class
cls [Type]
tys <- Type -> Pred
classifyPredType (Ct -> Type
ctPred Ct
ct)
, Just {} <- Class -> [Type] -> Maybe FastString
isCallStackPred Class
cls [Type]
tys
= do { CtEvidence -> EvCallStack -> TcS ()
solveCallStack (Ct -> CtEvidence
ctEvidence Ct
ct) EvCallStack
EvCsEmpty
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
defaultCallStack Ct
ct
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Ct
ct)
simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
simplifyAmbiguityCheck Type
ty WantedConstraints
wanteds
= do { String -> SDoc -> TcM ()
traceTc String
"simplifyAmbiguityCheck {" (String -> SDoc
text String
"type = " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"wanted = " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanteds)
; (WantedConstraints
final_wc, EvBindMap
_) <- forall a. TcS a -> TcM (a, EvBindMap)
runTcS forall a b. (a -> b) -> a -> b
$ WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop WantedConstraints
wanteds
; String -> SDoc -> TcM ()
traceTc String
"End simplifyAmbiguityCheck }" SDoc
empty
; Bool
allow_ambiguous <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.AllowAmbiguousTypes
; String -> SDoc -> TcM ()
traceTc String
"reportUnsolved(ambig) {" SDoc
empty
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
allow_ambiguous Bool -> Bool -> Bool
&& Bool -> Bool
not (WantedConstraints -> Bool
insolubleWC WantedConstraints
final_wc))
(forall a. TcM a -> TcM ()
discardResult (WantedConstraints -> TcM (Bag EvBind)
reportUnsolved WantedConstraints
final_wc))
; String -> SDoc -> TcM ()
traceTc String
"reportUnsolved(ambig) }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
simplifyInteractive WantedConstraints
wanteds
= String -> SDoc -> TcM ()
traceTc String
"simplifyInteractive" SDoc
empty forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
WantedConstraints -> TcM (Bag EvBind)
simplifyTop WantedConstraints
wanteds
simplifyDefault :: ThetaType
-> TcM Bool
simplifyDefault :: [Type] -> TcM Bool
simplifyDefault [Type]
theta
= do { String -> SDoc -> TcM ()
traceTc String
"simplifyDefault" SDoc
empty
; [CtEvidence]
wanteds <- CtOrigin -> [Type] -> TcM [CtEvidence]
newWanteds CtOrigin
DefaultOrigin [Type]
theta
; WantedConstraints
unsolved <- forall a. TcS a -> TcM a
runTcSDeriveds (WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop ([CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence]
wanteds))
; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints -> Bool
isEmptyWC WantedConstraints
unsolved) }
tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)
tcCheckGivens :: InertSet -> Bag TcTyVar -> TcM (Maybe InertSet)
tcCheckGivens InertSet
inerts Bag TcTyVar
given_ids = do
(Bool
sat, InertSet
new_inerts) <- forall a. InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts InertSet
inerts forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcS ()
traceTcS String
"checkGivens {" (forall a. Outputable a => a -> SDoc
ppr InertSet
inerts SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bag TcTyVar
given_ids)
TcLclEnv
lcl_env <- TcS TcLclEnv
TcS.getLclEnv
let given_loc :: CtLoc
given_loc = TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc TcLevel
topTcLevel SkolemInfo
UnkSkol TcLclEnv
lcl_env
let given_cts :: [Ct]
given_cts = CtLoc -> [TcTyVar] -> [Ct]
mkGivens CtLoc
given_loc (forall a. Bag a -> [a]
bagToList Bag TcTyVar
given_ids)
[Ct] -> TcS ()
solveSimpleGivens [Ct]
given_cts
Cts
insols <- TcS Cts
getInertInsols
Cts
insols <- Cts -> TcS Cts
try_harder Cts
insols
String -> SDoc -> TcS ()
traceTcS String
"checkGivens }" (forall a. Outputable a => a -> SDoc
ppr Cts
insols)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bag a -> Bool
isEmptyBag Cts
insols)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
sat then forall a. a -> Maybe a
Just InertSet
new_inerts else forall a. Maybe a
Nothing
where
try_harder :: Cts -> TcS Cts
try_harder :: Cts -> TcS Cts
try_harder Cts
insols
| Bool -> Bool
not (forall a. Bag a -> Bool
isEmptyBag Cts
insols)
= forall (m :: * -> *) a. Monad m => a -> m a
return Cts
insols
| Bool
otherwise
= do { [Ct]
pending_given <- TcS [Ct]
getPendingGivenScs
; [Ct]
new_given <- [Ct] -> TcS [Ct]
makeSuperClasses [Ct]
pending_given
; [Ct] -> TcS ()
solveSimpleGivens [Ct]
new_given
; TcS Cts
getInertInsols }
tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool
tcCheckWanteds :: InertSet -> [Type] -> TcM Bool
tcCheckWanteds InertSet
inerts [Type]
wanteds = do
[CtEvidence]
cts <- CtOrigin -> [Type] -> TcM [CtEvidence]
newWanteds CtOrigin
PatCheckOrigin [Type]
wanteds
(Bool
sat, InertSet
_new_inerts) <- forall a. InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts InertSet
inerts forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcS ()
traceTcS String
"checkWanteds {" (forall a. Outputable a => a -> SDoc
ppr InertSet
inerts SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
wanteds)
WantedConstraints
wcs <- WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop ([CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence]
cts)
String -> SDoc -> TcS ()
traceTcS String
"checkWanteds }" (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wcs)
forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints -> Bool
isSolvedWC WantedConstraints
wcs)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
sat
tcNormalise :: InertSet -> Type -> TcM Type
tcNormalise :: InertSet -> Type -> TcM Type
tcNormalise InertSet
inerts Type
ty
= do { CtLoc
norm_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
PatCheckOrigin forall a. Maybe a
Nothing
; (Type
res, InertSet
_new_inerts) <- forall a. InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts InertSet
inerts forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcS ()
traceTcS String
"tcNormalise {" (forall a. Outputable a => a -> SDoc
ppr InertSet
inerts)
; Type
ty' <- CtLoc -> Type -> TcS Type
rewriteType CtLoc
norm_loc Type
ty
; String -> SDoc -> TcS ()
traceTcS String
"tcNormalise }" (forall a. Outputable a => a -> SDoc
ppr Type
ty')
; forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty' }
; forall (m :: * -> *) a. Monad m => a -> m a
return Type
res }
data InferMode = ApplyMR
| EagerDefaulting
| NoRestrictions
instance Outputable InferMode where
ppr :: InferMode -> SDoc
ppr InferMode
ApplyMR = String -> SDoc
text String
"ApplyMR"
ppr InferMode
EagerDefaulting = String -> SDoc
text String
"EagerDefaulting"
ppr InferMode
NoRestrictions = String -> SDoc
text String
"NoRestrictions"
simplifyInfer :: TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcTauType)]
-> WantedConstraints
-> TcM ([TcTyVar],
[EvVar],
TcEvBinds,
Bool)
simplifyInfer :: TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([TcTyVar], [TcTyVar], TcEvBinds, Bool)
simplifyInfer TcLevel
rhs_tclvl InferMode
infer_mode [TcIdSigInst]
sigs [(Name, Type)]
name_taus WantedConstraints
wanteds
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanteds
= do {
let psig_tv_tys :: [Type]
psig_tv_tys = [ TcTyVar -> Type
mkTyVarTy TcTyVar
tv | TcIdSigInst
sig <- [TcIdSigInst]
partial_sigs
, (Name
_,Bndr TcTyVar
tv Specificity
_) <- TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols TcIdSigInst
sig ]
psig_theta :: [Type]
psig_theta = [ Type
pred | TcIdSigInst
sig <- [TcIdSigInst]
partial_sigs
, Type
pred <- TcIdSigInst -> [Type]
sig_inst_theta TcIdSigInst
sig ]
; CandidatesQTvs
dep_vars <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes ([Type]
psig_tv_tys forall a. [a] -> [a] -> [a]
++ [Type]
psig_theta forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Type)]
name_taus)
; [TcTyVar]
qtkvs <- CandidatesQTvs -> TcM [TcTyVar]
quantifyTyVars CandidatesQTvs
dep_vars
; String -> SDoc -> TcM ()
traceTc String
"simplifyInfer: empty WC" (forall a. Outputable a => a -> SDoc
ppr [(Name, Type)]
name_taus SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
qtkvs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TcTyVar]
qtkvs, [], TcEvBinds
emptyTcEvBinds, Bool
False) }
| Bool
otherwise
= do { String -> SDoc -> TcM ()
traceTc String
"simplifyInfer {" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"sigs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TcIdSigInst]
sigs
, String -> SDoc
text String
"binds =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [(Name, Type)]
name_taus
, String -> SDoc
text String
"rhs_tclvl =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcLevel
rhs_tclvl
, String -> SDoc
text String
"infer_mode =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InferMode
infer_mode
, String -> SDoc
text String
"(unzonked) wanted =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanteds
]
; let psig_theta :: [Type]
psig_theta = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TcIdSigInst -> [Type]
sig_inst_theta [TcIdSigInst]
partial_sigs
; EvBindsVar
ev_binds_var <- TcM EvBindsVar
TcM.newTcEvBinds
; [CtEvidence]
psig_evs <- CtOrigin -> [Type] -> TcM [CtEvidence]
newWanteds CtOrigin
AnnOrigin [Type]
psig_theta
; WantedConstraints
wanted_transformed_incl_derivs
<- forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
rhs_tclvl forall a b. (a -> b) -> a -> b
$
forall a. EvBindsVar -> TcS a -> TcM a
runTcSWithEvBinds EvBindsVar
ev_binds_var forall a b. (a -> b) -> a -> b
$
WantedConstraints -> TcS WantedConstraints
solveWanteds ([CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence]
psig_evs WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
wanteds)
; WantedConstraints
wanted_transformed_incl_derivs <- WantedConstraints -> TcM WantedConstraints
TcM.zonkWC WantedConstraints
wanted_transformed_incl_derivs
; let definite_error :: Bool
definite_error = WantedConstraints -> Bool
insolubleWC WantedConstraints
wanted_transformed_incl_derivs
wanted_transformed :: WantedConstraints
wanted_transformed = WantedConstraints -> WantedConstraints
dropDerivedWC WantedConstraints
wanted_transformed_incl_derivs
quant_pred_candidates :: [Type]
quant_pred_candidates
| Bool
definite_error = []
| Bool
otherwise = Cts -> [Type]
ctsPreds (Bool -> WantedConstraints -> Cts
approximateWC Bool
False WantedConstraints
wanted_transformed)
; ([TcTyVar]
qtvs, [Type]
bound_theta, VarSet
co_vars) <- InferMode
-> TcLevel
-> [(Name, Type)]
-> [TcIdSigInst]
-> [Type]
-> TcM ([TcTyVar], [Type], VarSet)
decideQuantification InferMode
infer_mode TcLevel
rhs_tclvl
[(Name, Type)]
name_taus [TcIdSigInst]
partial_sigs
[Type]
quant_pred_candidates
; [TcTyVar]
bound_theta_vars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall gbl lcl. Type -> TcRnIf gbl lcl TcTyVar
TcM.newEvVar [Type]
bound_theta
; TcLevel
-> EvBindsVar
-> [(Name, Type)]
-> VarSet
-> [TcTyVar]
-> [TcTyVar]
-> WantedConstraints
-> TcM ()
emitResidualConstraints TcLevel
rhs_tclvl EvBindsVar
ev_binds_var
[(Name, Type)]
name_taus VarSet
co_vars [TcTyVar]
qtvs [TcTyVar]
bound_theta_vars
WantedConstraints
wanted_transformed
; String -> SDoc -> TcM ()
traceTc String
"} simplifyInfer/produced residual implication for quantification" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"quant_pred_candidates =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
quant_pred_candidates
, String -> SDoc
text String
"psig_theta =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
psig_theta
, String -> SDoc
text String
"bound_theta =" SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
pprCoreBinders [TcTyVar]
bound_theta_vars
, String -> SDoc
text String
"qtvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
qtvs
, String -> SDoc
text String
"definite_error =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
definite_error ]
; forall (m :: * -> *) a. Monad m => a -> m a
return ( [TcTyVar]
qtvs, [TcTyVar]
bound_theta_vars, EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
ev_binds_var, Bool
definite_error ) }
where
partial_sigs :: [TcIdSigInst]
partial_sigs = forall a. (a -> Bool) -> [a] -> [a]
filter TcIdSigInst -> Bool
isPartialSig [TcIdSigInst]
sigs
emitResidualConstraints :: TcLevel -> EvBindsVar
-> [(Name, TcTauType)]
-> VarSet -> [TcTyVar] -> [EvVar]
-> WantedConstraints -> TcM ()
emitResidualConstraints :: TcLevel
-> EvBindsVar
-> [(Name, Type)]
-> VarSet
-> [TcTyVar]
-> [TcTyVar]
-> WantedConstraints
-> TcM ()
emitResidualConstraints TcLevel
rhs_tclvl EvBindsVar
ev_binds_var
[(Name, Type)]
name_taus VarSet
co_vars [TcTyVar]
qtvs [TcTyVar]
full_theta_vars WantedConstraints
wanteds
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanteds
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { Cts
wanted_simple <- Cts -> TcM Cts
TcM.zonkSimples (WantedConstraints -> Cts
wc_simple WantedConstraints
wanteds)
; let (Cts
outer_simple, Cts
inner_simple) = forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag Ct -> Bool
is_mono Cts
wanted_simple
is_mono :: Ct -> Bool
is_mono Ct
ct = Ct -> Bool
isWantedCt Ct
ct Bool -> Bool -> Bool
&& Ct -> TcTyVar
ctEvId Ct
ct TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
co_vars
; let inner_wanted :: WantedConstraints
inner_wanted = WantedConstraints
wanteds { wc_simple :: Cts
wc_simple = Cts
inner_simple }
; Bag Implication
implics <- if WantedConstraints -> Bool
isEmptyWC WantedConstraints
inner_wanted
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Bag a
emptyBag
else do Implication
implic1 <- TcM Implication
newImplication
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$
Implication
implic1 { ic_tclvl :: TcLevel
ic_tclvl = TcLevel
rhs_tclvl
, ic_skols :: [TcTyVar]
ic_skols = [TcTyVar]
qtvs
, ic_given :: [TcTyVar]
ic_given = [TcTyVar]
full_theta_vars
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
inner_wanted
, ic_binds :: EvBindsVar
ic_binds = EvBindsVar
ev_binds_var
, ic_given_eqs :: HasGivenEqs
ic_given_eqs = HasGivenEqs
MaybeGivenEqs
, ic_info :: SkolemInfo
ic_info = SkolemInfo
skol_info }
; WantedConstraints -> TcM ()
emitConstraints (WantedConstraints
emptyWC { wc_simple :: Cts
wc_simple = Cts
outer_simple
, wc_impl :: Bag Implication
wc_impl = Bag Implication
implics }) }
where
full_theta :: [Type]
full_theta = forall a b. (a -> b) -> [a] -> [b]
map TcTyVar -> Type
idType [TcTyVar]
full_theta_vars
skol_info :: SkolemInfo
skol_info = [(Name, Type)] -> SkolemInfo
InferSkol [ (Name
name, [TyCoVarBinder] -> [Type] -> Type -> Type
mkSigmaTy [] [Type]
full_theta Type
ty)
| (Name
name, Type
ty) <- [(Name, Type)]
name_taus ]
ctsPreds :: Cts -> [PredType]
ctsPreds :: Cts -> [Type]
ctsPreds Cts
cts = [ CtEvidence -> Type
ctEvPred CtEvidence
ev | Ct
ct <- forall a. Bag a -> [a]
bagToList Cts
cts
, let ev :: CtEvidence
ev = Ct -> CtEvidence
ctEvidence Ct
ct ]
findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType
findInferredDiff :: [Type] -> [Type] -> TcM [Type]
findInferredDiff [Type]
annotated_theta [Type]
inferred_theta
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
annotated_theta
= forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
inferred_theta
| Bool
otherwise
= forall r. TcM r -> TcM r
pushTcLevelM_ forall a b. (a -> b) -> a -> b
$
do { TcLclEnv
lcl_env <- forall gbl lcl. TcRnIf gbl lcl lcl
TcM.getLclEnv
; [TcTyVar]
given_ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall gbl lcl. Type -> TcRnIf gbl lcl TcTyVar
TcM.newEvVar [Type]
annotated_theta
; [CtEvidence]
wanteds <- CtOrigin -> [Type] -> TcM [CtEvidence]
newWanteds CtOrigin
AnnOrigin [Type]
inferred_theta
; let given_loc :: CtLoc
given_loc = TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc TcLevel
topTcLevel SkolemInfo
UnkSkol TcLclEnv
lcl_env
given_cts :: [Ct]
given_cts = CtLoc -> [TcTyVar] -> [Ct]
mkGivens CtLoc
given_loc [TcTyVar]
given_ids
; WantedConstraints
residual <- forall a. TcS a -> TcM a
runTcSDeriveds forall a b. (a -> b) -> a -> b
$
do { ()
_ <- [Ct] -> TcS ()
solveSimpleGivens [Ct]
given_cts
; Cts -> TcS WantedConstraints
solveSimpleWanteds (forall a. [a] -> Bag a
listToBag (forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> Ct
mkNonCanonical [CtEvidence]
wanteds)) }
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type
box_pred forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> Type
ctPred) forall a b. (a -> b) -> a -> b
$
forall a. Bag a -> [a]
bagToList forall a b. (a -> b) -> a -> b
$
WantedConstraints -> Cts
wc_simple WantedConstraints
residual) }
where
box_pred :: PredType -> PredType
box_pred :: Type -> Type
box_pred Type
pred = case Type -> Pred
classifyPredType Type
pred of
EqPred EqRel
rel Type
ty1 Type
ty2
| Just (Class
cls,[Type]
tys) <- EqRel -> Type -> Type -> Maybe (Class, [Type])
boxEqPred EqRel
rel Type
ty1 Type
ty2
-> Class -> [Type] -> Type
mkClassPred Class
cls [Type]
tys
| Bool
otherwise
-> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"findInferredDiff" (forall a. Outputable a => a -> SDoc
ppr Type
pred)
Pred
_other -> Type
pred
decideQuantification
:: InferMode
-> TcLevel
-> [(Name, TcTauType)]
-> [TcIdSigInst]
-> [PredType]
-> TcM ( [TcTyVar]
, [PredType]
, VarSet)
decideQuantification :: InferMode
-> TcLevel
-> [(Name, Type)]
-> [TcIdSigInst]
-> [Type]
-> TcM ([TcTyVar], [Type], VarSet)
decideQuantification InferMode
infer_mode TcLevel
rhs_tclvl [(Name, Type)]
name_taus [TcIdSigInst]
psigs [Type]
candidates
= do {
; (VarSet
mono_tvs, [Type]
candidates, VarSet
co_vars) <- InferMode
-> [(Name, Type)]
-> [TcIdSigInst]
-> [Type]
-> TcM (VarSet, [Type], VarSet)
decideMonoTyVars InferMode
infer_mode
[(Name, Type)]
name_taus [TcIdSigInst]
psigs [Type]
candidates
; [Type]
candidates <- TcLevel -> VarSet -> [Type] -> TcM [Type]
defaultTyVarsAndSimplify TcLevel
rhs_tclvl VarSet
mono_tvs [Type]
candidates
; [TcTyVar]
qtvs <- [(Name, Type)] -> [TcIdSigInst] -> [Type] -> TcM [TcTyVar]
decideQuantifiedTyVars [(Name, Type)]
name_taus [TcIdSigInst]
psigs [Type]
candidates
; [Type]
candidates <- [Type] -> TcM [Type]
TcM.zonkTcTypes [Type]
candidates
; [Type]
psig_theta <- [Type] -> TcM [Type]
TcM.zonkTcTypes (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TcIdSigInst -> [Type]
sig_inst_theta [TcIdSigInst]
psigs)
; let min_theta :: [Type]
min_theta = forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
VarSet -> [Type] -> [Type]
pickQuantifiablePreds ([TcTyVar] -> VarSet
mkVarSet [TcTyVar]
qtvs) [Type]
candidates
min_psig_theta :: [Type]
min_psig_theta = forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs forall a. a -> a
id [Type]
psig_theta
; [Type]
theta <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
psig_theta
then forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
min_theta
else do { [Type]
diff <- [Type] -> [Type] -> TcM [Type]
findInferredDiff [Type]
min_psig_theta [Type]
min_theta
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
min_psig_theta forall a. [a] -> [a] -> [a]
++ [Type]
diff) }
; String -> SDoc -> TcM ()
traceTc String
"decideQuantification"
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"infer_mode:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InferMode
infer_mode
, String -> SDoc
text String
"candidates:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
candidates
, String -> SDoc
text String
"psig_theta:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
psig_theta
, String -> SDoc
text String
"mono_tvs:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
mono_tvs
, String -> SDoc
text String
"co_vars:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
co_vars
, String -> SDoc
text String
"qtvs:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
qtvs
, String -> SDoc
text String
"theta:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
theta ])
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TcTyVar]
qtvs, [Type]
theta, VarSet
co_vars) }
decideMonoTyVars :: InferMode
-> [(Name,TcType)]
-> [TcIdSigInst]
-> [PredType]
-> TcM (TcTyCoVarSet, [PredType], CoVarSet)
decideMonoTyVars :: InferMode
-> [(Name, Type)]
-> [TcIdSigInst]
-> [Type]
-> TcM (VarSet, [Type], VarSet)
decideMonoTyVars InferMode
infer_mode [(Name, Type)]
name_taus [TcIdSigInst]
psigs [Type]
candidates
= do { ([Type]
no_quant, [Type]
maybe_quant) <- InferMode -> [Type] -> TcM ([Type], [Type])
pick InferMode
infer_mode [Type]
candidates
; [TcTyVar]
psig_qtvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TcTyVar -> TcM TcTyVar
zonkTcTyVarToTyVar forall a b. (a -> b) -> a -> b
$ forall tv argf. [VarBndr tv argf] -> [tv]
binderVars forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols) [TcIdSigInst]
psigs
; [Type]
psig_theta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM Type
TcM.zonkTcType forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TcIdSigInst -> [Type]
sig_inst_theta [TcIdSigInst]
psigs
; [Type]
taus <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> TcM Type
TcM.zonkTcType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, Type)]
name_taus
; TcLevel
tc_lvl <- TcM TcLevel
TcM.getTcLevel
; let psig_tys :: [Type]
psig_tys = [TcTyVar] -> [Type]
mkTyVarTys [TcTyVar]
psig_qtvs forall a. [a] -> [a] -> [a]
++ [Type]
psig_theta
co_vars :: VarSet
co_vars = [Type] -> VarSet
coVarsOfTypes ([Type]
psig_tys forall a. [a] -> [a] -> [a]
++ [Type]
taus)
co_var_tvs :: VarSet
co_var_tvs = VarSet -> VarSet
closeOverKinds VarSet
co_vars
mono_tvs0 :: VarSet
mono_tvs0 = (TcTyVar -> Bool) -> VarSet -> VarSet
filterVarSet (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcLevel -> TcTyVar -> Bool
isQuantifiableTv TcLevel
tc_lvl) forall a b. (a -> b) -> a -> b
$
[Type] -> VarSet
tyCoVarsOfTypes [Type]
candidates
mono_tvs1 :: VarSet
mono_tvs1 = VarSet
mono_tvs0 VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
co_var_tvs
eq_constraints :: [Type]
eq_constraints = forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
isEqPrimPred [Type]
candidates
mono_tvs2 :: VarSet
mono_tvs2 = [Type] -> VarSet -> VarSet
growThetaTyVars [Type]
eq_constraints VarSet
mono_tvs1
constrained_tvs :: VarSet
constrained_tvs = (TcTyVar -> Bool) -> VarSet -> VarSet
filterVarSet (TcLevel -> TcTyVar -> Bool
isQuantifiableTv TcLevel
tc_lvl) forall a b. (a -> b) -> a -> b
$
([Type] -> VarSet -> VarSet
growThetaTyVars [Type]
eq_constraints
([Type] -> VarSet
tyCoVarsOfTypes [Type]
no_quant)
VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
mono_tvs2)
VarSet -> [TcTyVar] -> VarSet
`delVarSetList` [TcTyVar]
psig_qtvs
mono_tvs :: VarSet
mono_tvs = VarSet
mono_tvs2 VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
constrained_tvs
; Bool
warn_mono <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMonomorphism
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (case InferMode
infer_mode of { InferMode
ApplyMR -> Bool
warn_mono; InferMode
_ -> Bool
False}) forall a b. (a -> b) -> a -> b
$
WarnReason -> Bool -> SDoc -> TcM ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMonomorphism)
(VarSet
constrained_tvs VarSet -> VarSet -> Bool
`intersectsVarSet` [Type] -> VarSet
tyCoVarsOfTypes [Type]
taus)
SDoc
mr_msg
; String -> SDoc -> TcM ()
traceTc String
"decideMonoTyVars" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"infer_mode =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InferMode
infer_mode
, String -> SDoc
text String
"mono_tvs0 =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
mono_tvs0
, String -> SDoc
text String
"no_quant =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
no_quant
, String -> SDoc
text String
"maybe_quant =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
maybe_quant
, String -> SDoc
text String
"eq_constraints =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
eq_constraints
, String -> SDoc
text String
"mono_tvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
mono_tvs
, String -> SDoc
text String
"co_vars =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
co_vars ]
; forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
mono_tvs, [Type]
maybe_quant, VarSet
co_vars) }
where
pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])
pick :: InferMode -> [Type] -> TcM ([Type], [Type])
pick InferMode
NoRestrictions [Type]
cand = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Type]
cand)
pick InferMode
ApplyMR [Type]
cand = forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
cand, [])
pick InferMode
EagerDefaulting [Type]
cand = do { Bool
os <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Type -> Bool
is_int_ct Bool
os) [Type]
cand) }
is_int_ct :: Bool -> Type -> Bool
is_int_ct Bool
ovl_strings Type
pred
| Just (Class
cls, [Type]
_) <- Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
pred
= Bool -> Class -> Bool
isInteractiveClass Bool
ovl_strings Class
cls
| Bool
otherwise
= Bool
False
pp_bndrs :: SDoc
pp_bndrs = forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, Type)]
name_taus
mr_msg :: SDoc
mr_msg =
SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"The Monomorphism Restriction applies to the binding"
SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [(Name, Type)]
name_taus
, String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc
pp_bndrs ])
Int
2 ([SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Consider giving"
, String -> SDoc
text (if forall a. [a] -> Bool
isSingleton [(Name, Type)]
name_taus then String
"it" else String
"them")
, String -> SDoc
text String
"a type signature"])
defaultTyVarsAndSimplify :: TcLevel
-> TyCoVarSet
-> [PredType]
-> TcM [PredType]
defaultTyVarsAndSimplify :: TcLevel -> VarSet -> [Type] -> TcM [Type]
defaultTyVarsAndSimplify TcLevel
rhs_tclvl VarSet
mono_tvs [Type]
candidates
= do {
; String -> SDoc -> TcM ()
traceTc String
"decideMonoTyVars: promotion:" (forall a. Outputable a => a -> SDoc
ppr VarSet
mono_tvs)
; Bool
any_promoted <- VarSet -> TcM Bool
promoteTyVarSet VarSet
mono_tvs
; DV {dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
cand_kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
cand_tvs}
<- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Type]
candidates
; Bool
poly_kinds <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
; [Bool]
default_kvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Bool -> TcTyVar -> TcM Bool
default_one Bool
poly_kinds Bool
True)
(DTyVarSet -> [TcTyVar]
dVarSetElems DTyVarSet
cand_kvs)
; [Bool]
default_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Bool -> TcTyVar -> TcM Bool
default_one Bool
poly_kinds Bool
False)
(DTyVarSet -> [TcTyVar]
dVarSetElems (DTyVarSet
cand_tvs DTyVarSet -> DTyVarSet -> DTyVarSet
`minusDVarSet` DTyVarSet
cand_kvs))
; let some_default :: Bool
some_default = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
default_kvs Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
default_tvs
; case () of
()
_ | Bool
some_default -> [Type] -> TcM [Type]
simplify_cand [Type]
candidates
| Bool
any_promoted -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM Type
TcM.zonkTcType [Type]
candidates
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
candidates
}
where
default_one :: Bool -> Bool -> TcTyVar -> TcM Bool
default_one Bool
poly_kinds Bool
is_kind_var TcTyVar
tv
| Bool -> Bool
not (TcTyVar -> Bool
isMetaTyVar TcTyVar
tv)
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| TcTyVar
tv TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
mono_tvs
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise
= Bool -> TcTyVar -> TcM Bool
defaultTyVar (Bool -> Bool
not Bool
poly_kinds Bool -> Bool -> Bool
&& Bool
is_kind_var) TcTyVar
tv
simplify_cand :: [Type] -> TcM [Type]
simplify_cand [Type]
candidates
= do { [CtEvidence]
clone_wanteds <- CtOrigin -> [Type] -> TcM [CtEvidence]
newWanteds CtOrigin
DefaultOrigin [Type]
candidates
; WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples } <- forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
rhs_tclvl forall a b. (a -> b) -> a -> b
$
[CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM [CtEvidence]
clone_wanteds
; let new_candidates :: [Type]
new_candidates = Cts -> [Type]
ctsPreds Cts
simples
; String -> SDoc -> TcM ()
traceTc String
"Simplified after defaulting" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Before:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
candidates
, String -> SDoc
text String
"After:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
new_candidates ]
; forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
new_candidates }
decideQuantifiedTyVars
:: [(Name,TcType)]
-> [TcIdSigInst]
-> [PredType]
-> TcM [TyVar]
decideQuantifiedTyVars :: [(Name, Type)] -> [TcIdSigInst] -> [Type] -> TcM [TcTyVar]
decideQuantifiedTyVars [(Name, Type)]
name_taus [TcIdSigInst]
psigs [Type]
candidates
= do {
; [Type]
psig_tv_tys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcTyVar -> TcM Type
TcM.zonkTcTyVar [ TcTyVar
tv | TcIdSigInst
sig <- [TcIdSigInst]
psigs
, (Name
_,Bndr TcTyVar
tv Specificity
_) <- TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols TcIdSigInst
sig ]
; [Type]
psig_theta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM Type
TcM.zonkTcType [ Type
pred | TcIdSigInst
sig <- [TcIdSigInst]
psigs
, Type
pred <- TcIdSigInst -> [Type]
sig_inst_theta TcIdSigInst
sig ]
; [Type]
tau_tys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> TcM Type
TcM.zonkTcType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, Type)]
name_taus
; let
psig_tys :: [Type]
psig_tys = [Type]
psig_tv_tys forall a. [a] -> [a] -> [a]
++ [Type]
psig_theta
seed_tys :: [Type]
seed_tys = [Type]
psig_tys forall a. [a] -> [a] -> [a]
++ [Type]
tau_tys
grown_tcvs :: VarSet
grown_tcvs = [Type] -> VarSet -> VarSet
growThetaTyVars [Type]
candidates ([Type] -> VarSet
tyCoVarsOfTypes [Type]
seed_tys)
; dv :: CandidatesQTvs
dv@DV {dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
cand_kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
cand_tvs} <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes forall a b. (a -> b) -> a -> b
$
[Type]
psig_tys forall a. [a] -> [a] -> [a]
++ [Type]
candidates forall a. [a] -> [a] -> [a]
++ [Type]
tau_tys
; let pick :: DTyVarSet -> DTyVarSet
pick = (DTyVarSet -> VarSet -> DTyVarSet
`dVarSetIntersectVarSet` VarSet
grown_tcvs)
dvs_plus :: CandidatesQTvs
dvs_plus = CandidatesQTvs
dv { dv_kvs :: DTyVarSet
dv_kvs = DTyVarSet -> DTyVarSet
pick DTyVarSet
cand_kvs, dv_tvs :: DTyVarSet
dv_tvs = DTyVarSet -> DTyVarSet
pick DTyVarSet
cand_tvs }
; String -> SDoc -> TcM ()
traceTc String
"decideQuantifiedTyVars" ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tau_tys =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
tau_tys
, String -> SDoc
text String
"candidates =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
candidates
, String -> SDoc
text String
"cand_kvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DTyVarSet
cand_kvs
, String -> SDoc
text String
"cand_tvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DTyVarSet
cand_tvs
, String -> SDoc
text String
"tau_tys =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
tau_tys
, String -> SDoc
text String
"seed_tys =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
seed_tys
, String -> SDoc
text String
"seed_tcvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ([Type] -> VarSet
tyCoVarsOfTypes [Type]
seed_tys)
, String -> SDoc
text String
"grown_tcvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
grown_tcvs
, String -> SDoc
text String
"dvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
dvs_plus])
; CandidatesQTvs -> TcM [TcTyVar]
quantifyTyVars CandidatesQTvs
dvs_plus }
growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet
growThetaTyVars :: [Type] -> VarSet -> VarSet
growThetaTyVars [Type]
theta VarSet
tcvs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta = VarSet
tcvs
| Bool
otherwise = (VarSet -> VarSet) -> VarSet -> VarSet
transCloVarSet VarSet -> VarSet
mk_next VarSet
seed_tcvs
where
seed_tcvs :: VarSet
seed_tcvs = VarSet
tcvs VarSet -> VarSet -> VarSet
`unionVarSet` [Type] -> VarSet
tyCoVarsOfTypes [Type]
ips
([Type]
ips, [Type]
non_ips) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Type -> Bool
isIPLikePred [Type]
theta
mk_next :: VarSet -> VarSet
mk_next :: VarSet -> VarSet
mk_next VarSet
so_far = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (VarSet -> Type -> VarSet -> VarSet
grow_one VarSet
so_far) VarSet
emptyVarSet [Type]
non_ips
grow_one :: VarSet -> Type -> VarSet -> VarSet
grow_one VarSet
so_far Type
pred VarSet
tcvs
| VarSet
pred_tcvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
so_far = VarSet
tcvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
pred_tcvs
| Bool
otherwise = VarSet
tcvs
where
pred_tcvs :: VarSet
pred_tcvs = Type -> VarSet
tyCoVarsOfType Type
pred
simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
simplifyWantedsTcM [CtEvidence]
wanted
= do { String -> SDoc -> TcM ()
traceTc String
"simplifyWantedsTcM {" (forall a. Outputable a => a -> SDoc
ppr [CtEvidence]
wanted)
; (WantedConstraints
result, EvBindMap
_) <- forall a. TcS a -> TcM (a, EvBindMap)
runTcS (WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop ([CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence]
wanted))
; WantedConstraints
result <- WantedConstraints -> TcM WantedConstraints
TcM.zonkWC WantedConstraints
result
; String -> SDoc -> TcM ()
traceTc String
"simplifyWantedsTcM }" (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
result)
; forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
result }
solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints
solveWantedsAndDrop WantedConstraints
wanted
= do { WantedConstraints
wc <- WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wanted
; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints -> WantedConstraints
dropDerivedWC WantedConstraints
wc) }
solveWanteds :: WantedConstraints -> TcS WantedConstraints
solveWanteds :: WantedConstraints -> TcS WantedConstraints
solveWanteds wc :: WantedConstraints
wc@(WC { wc_holes :: WantedConstraints -> Bag Hole
wc_holes = Bag Hole
holes })
= do { TcLevel
cur_lvl <- TcS TcLevel
TcS.getTcLevel
; String -> SDoc -> TcS ()
traceTcS String
"solveWanteds {" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Level =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcLevel
cur_lvl
, forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wc ]
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; WantedConstraints
solved_wc <- Int
-> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints
simplify_loop Int
0 (DynFlags -> IntWithInf
solverIterations DynFlags
dflags) Bool
True WantedConstraints
wc
; Bag Hole
holes' <- Bag Hole -> TcS (Bag Hole)
simplifyHoles Bag Hole
holes
; let final_wc :: WantedConstraints
final_wc = WantedConstraints
solved_wc { wc_holes :: Bag Hole
wc_holes = Bag Hole
holes' }
; EvBindsVar
ev_binds_var <- TcS EvBindsVar
getTcEvBindsVar
; EvBindMap
bb <- EvBindsVar -> TcS EvBindMap
TcS.getTcEvBindsMap EvBindsVar
ev_binds_var
; String -> SDoc -> TcS ()
traceTcS String
"solveWanteds }" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"final wc =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
final_wc
, String -> SDoc
text String
"current evbinds =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (EvBindMap -> Bag EvBind
evBindMapBinds EvBindMap
bb) ]
; forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
final_wc }
simplify_loop :: Int -> IntWithInf -> Bool
-> WantedConstraints -> TcS WantedConstraints
simplify_loop :: Int
-> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints
simplify_loop Int
n IntWithInf
limit Bool
definitely_redo_implications
wc :: WantedConstraints
wc@(WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics })
= do { SDoc -> TcS ()
csTraceTcS forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"simplify_loop iteration=" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"definitely_redo =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
definitely_redo_implications SDoc -> SDoc -> SDoc
<> SDoc
comma
, Int -> SDoc
int (forall a. Bag a -> Int
lengthBag Cts
simples) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"simples to solve" ])
; String -> SDoc -> TcS ()
traceTcS String
"simplify_loop: wc =" (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wc)
; (Int
unifs1, WantedConstraints
wc1) <- forall a. TcS a -> TcS (Int, a)
reportUnifications forall a b. (a -> b) -> a -> b
$
Cts -> TcS WantedConstraints
solveSimpleWanteds Cts
simples
; WantedConstraints
wc2 <- if Bool -> Bool
not Bool
definitely_redo_implications
Bool -> Bool -> Bool
&& Int
unifs1 forall a. Eq a => a -> a -> Bool
== Int
0
Bool -> Bool -> Bool
&& forall a. Bag a -> Bool
isEmptyBag (WantedConstraints -> Bag Implication
wc_impl WantedConstraints
wc1)
then forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
wc { wc_simple :: Cts
wc_simple = WantedConstraints -> Cts
wc_simple WantedConstraints
wc1 })
else do { Bag Implication
implics2 <- Bag Implication -> TcS (Bag Implication)
solveNestedImplications forall a b. (a -> b) -> a -> b
$
Bag Implication
implics forall a. Bag a -> Bag a -> Bag a
`unionBags` (WantedConstraints -> Bag Implication
wc_impl WantedConstraints
wc1)
; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
wc { wc_simple :: Cts
wc_simple = WantedConstraints -> Cts
wc_simple WantedConstraints
wc1
, wc_impl :: Bag Implication
wc_impl = Bag Implication
implics2 }) }
; Bool
unif_happened <- TcS Bool
resetUnificationFlag
; Int
-> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints
maybe_simplify_again (Int
nforall a. Num a => a -> a -> a
+Int
1) IntWithInf
limit Bool
unif_happened WantedConstraints
wc2 }
maybe_simplify_again :: Int -> IntWithInf -> Bool
-> WantedConstraints -> TcS WantedConstraints
maybe_simplify_again :: Int
-> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints
maybe_simplify_again Int
n IntWithInf
limit Bool
unif_happened wc :: WantedConstraints
wc@(WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples })
| Int
n Int -> IntWithInf -> Bool
`intGtLimit` IntWithInf
limit
= do {
SDoc -> TcS ()
addErrTcS (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"solveWanteds: too many iterations"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text String
"limit =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr IntWithInf
limit))
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unsolved:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wc
, String -> SDoc
text String
"Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
]))
; forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc }
| Bool
unif_happened
= Int
-> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints
simplify_loop Int
n IntWithInf
limit Bool
True WantedConstraints
wc
| WantedConstraints -> Bool
superClassesMightHelp WantedConstraints
wc
=
do { [Ct]
pending_given <- TcS [Ct]
getPendingGivenScs
; let ([Ct]
pending_wanted, Cts
simples1) = Cts -> ([Ct], Cts)
getPendingWantedScs Cts
simples
; if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
pending_given Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
pending_wanted
then forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
else
do { [Ct]
new_given <- [Ct] -> TcS [Ct]
makeSuperClasses [Ct]
pending_given
; [Ct]
new_wanted <- [Ct] -> TcS [Ct]
makeSuperClasses [Ct]
pending_wanted
; [Ct] -> TcS ()
solveSimpleGivens [Ct]
new_given
; Int
-> IntWithInf -> Bool -> WantedConstraints -> TcS WantedConstraints
simplify_loop Int
n IntWithInf
limit (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
pending_given)) forall a b. (a -> b) -> a -> b
$
WantedConstraints
wc { wc_simple :: Cts
wc_simple = Cts
simples1 forall a. Bag a -> Bag a -> Bag a
`unionBags` forall a. [a] -> Bag a
listToBag [Ct]
new_wanted } } }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
solveNestedImplications :: Bag Implication
-> TcS (Bag Implication)
solveNestedImplications :: Bag Implication -> TcS (Bag Implication)
solveNestedImplications Bag Implication
implics
| forall a. Bag a -> Bool
isEmptyBag Bag Implication
implics
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bag a
emptyBag)
| Bool
otherwise
= do { String -> SDoc -> TcS ()
traceTcS String
"solveNestedImplications starting {" SDoc
empty
; Bag (Maybe Implication)
unsolved_implics <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Implication -> TcS (Maybe Implication)
solveImplication Bag Implication
implics
; String -> SDoc -> TcS ()
traceTcS String
"solveNestedImplications end }" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"unsolved_implics =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bag (Maybe Implication)
unsolved_implics ]
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bag (Maybe a) -> Bag a
catBagMaybes Bag (Maybe Implication)
unsolved_implics) }
solveImplication :: Implication
-> TcS (Maybe Implication)
solveImplication :: Implication -> TcS (Maybe Implication)
solveImplication imp :: Implication
imp@(Implic { ic_tclvl :: Implication -> TcLevel
ic_tclvl = TcLevel
tclvl
, ic_binds :: Implication -> EvBindsVar
ic_binds = EvBindsVar
ev_binds_var
, ic_given :: Implication -> [TcTyVar]
ic_given = [TcTyVar]
given_ids
, ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wanteds
, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
info
, ic_status :: Implication -> ImplicStatus
ic_status = ImplicStatus
status })
| ImplicStatus -> Bool
isSolvedStatus ImplicStatus
status
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Implication
imp)
| Bool
otherwise
= do { InertSet
inerts <- TcS InertSet
getTcSInerts
; String -> SDoc -> TcS ()
traceTcS String
"solveImplication {" (forall a. Outputable a => a -> SDoc
ppr Implication
imp SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Inerts" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InertSet
inerts)
; (HasGivenEqs
has_given_eqs, Cts
given_insols, WantedConstraints
residual_wanted)
<- forall a. EvBindsVar -> TcLevel -> TcS a -> TcS a
nestImplicTcS EvBindsVar
ev_binds_var TcLevel
tclvl forall a b. (a -> b) -> a -> b
$
do { let loc :: CtLoc
loc = TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc TcLevel
tclvl SkolemInfo
info (Implication -> TcLclEnv
ic_env Implication
imp)
givens :: [Ct]
givens = CtLoc -> [TcTyVar] -> [Ct]
mkGivens CtLoc
loc [TcTyVar]
given_ids
; [Ct] -> TcS ()
solveSimpleGivens [Ct]
givens
; WantedConstraints
residual_wanted <- WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wanteds
; (HasGivenEqs
has_eqs, Cts
given_insols) <- TcLevel -> TcS (HasGivenEqs, Cts)
getHasGivenEqs TcLevel
tclvl
; forall (m :: * -> *) a. Monad m => a -> m a
return (HasGivenEqs
has_eqs, Cts
given_insols, WantedConstraints
residual_wanted) }
; String -> SDoc -> TcS ()
traceTcS String
"solveImplication 2"
(forall a. Outputable a => a -> SDoc
ppr Cts
given_insols SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr WantedConstraints
residual_wanted)
; let final_wanted :: WantedConstraints
final_wanted = WantedConstraints
residual_wanted WantedConstraints -> Cts -> WantedConstraints
`addInsols` Cts
given_insols
; Maybe Implication
res_implic <- Implication -> TcS (Maybe Implication)
setImplicationStatus (Implication
imp { ic_given_eqs :: HasGivenEqs
ic_given_eqs = HasGivenEqs
has_given_eqs
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
final_wanted })
; EvBindMap
evbinds <- EvBindsVar -> TcS EvBindMap
TcS.getTcEvBindsMap EvBindsVar
ev_binds_var
; VarSet
tcvs <- EvBindsVar -> TcS VarSet
TcS.getTcEvTyCoVars EvBindsVar
ev_binds_var
; String -> SDoc -> TcS ()
traceTcS String
"solveImplication end }" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"has_given_eqs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HasGivenEqs
has_given_eqs
, String -> SDoc
text String
"res_implic =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Maybe Implication
res_implic
, String -> SDoc
text String
"implication evbinds =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (EvBindMap -> Bag EvBind
evBindMapBinds EvBindMap
evbinds)
, String -> SDoc
text String
"implication tvcs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
tcvs ]
; forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Implication
res_implic }
setImplicationStatus :: Implication -> TcS (Maybe Implication)
setImplicationStatus :: Implication -> TcS (Maybe Implication)
setImplicationStatus implic :: Implication
implic@(Implic { ic_status :: Implication -> ImplicStatus
ic_status = ImplicStatus
status
, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
info
, ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wc
, ic_given :: Implication -> [TcTyVar]
ic_given = [TcTyVar]
givens })
| ASSERT2( not (isSolvedStatus status ), ppr info )
Bool -> Bool
not (WantedConstraints -> Bool
isSolvedWC WantedConstraints
pruned_wc)
= do { String -> SDoc -> TcS ()
traceTcS String
"setImplicationStatus(not-all-solved) {" (forall a. Outputable a => a -> SDoc
ppr Implication
implic)
; Implication
implic <- Implication -> TcS Implication
neededEvVars Implication
implic
; let new_status :: ImplicStatus
new_status | WantedConstraints -> Bool
insolubleWC WantedConstraints
pruned_wc = ImplicStatus
IC_Insoluble
| Bool
otherwise = ImplicStatus
IC_Unsolved
new_implic :: Implication
new_implic = Implication
implic { ic_status :: ImplicStatus
ic_status = ImplicStatus
new_status
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
pruned_wc }
; String -> SDoc -> TcS ()
traceTcS String
"setImplicationStatus(not-all-solved) }" (forall a. Outputable a => a -> SDoc
ppr Implication
new_implic)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Implication
new_implic }
| Bool
otherwise
= do { String -> SDoc -> TcS ()
traceTcS String
"setImplicationStatus(all-solved) {" (forall a. Outputable a => a -> SDoc
ppr Implication
implic)
; implic :: Implication
implic@(Implic { ic_need_inner :: Implication -> VarSet
ic_need_inner = VarSet
need_inner
, ic_need_outer :: Implication -> VarSet
ic_need_outer = VarSet
need_outer }) <- Implication -> TcS Implication
neededEvVars Implication
implic
; Bool
bad_telescope <- Implication -> TcS Bool
checkBadTelescope Implication
implic
; let ([TcTyVar]
used_givens, [TcTyVar]
unused_givens)
| SkolemInfo -> Bool
warnRedundantGivens SkolemInfo
info
= forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
need_inner) [TcTyVar]
givens
| Bool
otherwise = ([TcTyVar]
givens, [])
minimal_used_givens :: [TcTyVar]
minimal_used_givens = forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs TcTyVar -> Type
evVarPred [TcTyVar]
used_givens
is_minimal :: TcTyVar -> Bool
is_minimal = (TcTyVar -> VarSet -> Bool
`elemVarSet` [TcTyVar] -> VarSet
mkVarSet [TcTyVar]
minimal_used_givens)
warn_givens :: [TcTyVar]
warn_givens
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
unused_givens) = [TcTyVar]
unused_givens
| SkolemInfo -> Bool
warnRedundantGivens SkolemInfo
info = forall a. (a -> Bool) -> [a] -> [a]
filterOut TcTyVar -> Bool
is_minimal [TcTyVar]
used_givens
| Bool
otherwise = []
discard_entire_implication :: Bool
discard_entire_implication
= forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
warn_givens
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bad_telescope
Bool -> Bool -> Bool
&& WantedConstraints -> Bool
isEmptyWC WantedConstraints
pruned_wc
Bool -> Bool -> Bool
&& VarSet -> Bool
isEmptyVarSet VarSet
need_outer
final_status :: ImplicStatus
final_status
| Bool
bad_telescope = ImplicStatus
IC_BadTelescope
| Bool
otherwise = IC_Solved { ics_dead :: [TcTyVar]
ics_dead = [TcTyVar]
warn_givens }
final_implic :: Implication
final_implic = Implication
implic { ic_status :: ImplicStatus
ic_status = ImplicStatus
final_status
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
pruned_wc }
; String -> SDoc -> TcS ()
traceTcS String
"setImplicationStatus(all-solved) }" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"discard:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
discard_entire_implication
, String -> SDoc
text String
"new_implic:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Implication
final_implic ]
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
discard_entire_implication
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just Implication
final_implic }
where
WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics, wc_holes :: WantedConstraints -> Bag Hole
wc_holes = Bag Hole
holes } = WantedConstraints
wc
pruned_simples :: Cts
pruned_simples = Cts -> Cts
dropDerivedSimples Cts
simples
pruned_implics :: Bag Implication
pruned_implics = forall a. (a -> Bool) -> Bag a -> Bag a
filterBag Implication -> Bool
keep_me Bag Implication
implics
pruned_wc :: WantedConstraints
pruned_wc = WC { wc_simple :: Cts
wc_simple = Cts
pruned_simples
, wc_impl :: Bag Implication
wc_impl = Bag Implication
pruned_implics
, wc_holes :: Bag Hole
wc_holes = Bag Hole
holes }
keep_me :: Implication -> Bool
keep_me :: Implication -> Bool
keep_me Implication
ic
| IC_Solved { ics_dead :: ImplicStatus -> [TcTyVar]
ics_dead = [TcTyVar]
dead_givens } <- Implication -> ImplicStatus
ic_status Implication
ic
, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
dead_givens
, forall a. Bag a -> Bool
isEmptyBag (WantedConstraints -> Bag Implication
wc_impl (Implication -> WantedConstraints
ic_wanted Implication
ic))
= Bool
False
| Bool
otherwise
= Bool
True
checkBadTelescope :: Implication -> TcS Bool
checkBadTelescope :: Implication -> TcS Bool
checkBadTelescope (Implic { ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
info
, ic_skols :: Implication -> [TcTyVar]
ic_skols = [TcTyVar]
skols })
| SkolemInfo -> Bool
checkTelescopeSkol SkolemInfo
info
= do{ [TcTyVar]
skols <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcTyVar -> TcS TcTyVar
TcS.zonkTyCoVarKind [TcTyVar]
skols
; forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet -> [TcTyVar] -> Bool
go VarSet
emptyVarSet (forall a. [a] -> [a]
reverse [TcTyVar]
skols))}
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
go :: TyVarSet
-> [TcTyVar]
-> Bool
go :: VarSet -> [TcTyVar] -> Bool
go VarSet
_ [] = Bool
False
go VarSet
later_skols (TcTyVar
one_skol : [TcTyVar]
earlier_skols)
| Type -> VarSet
tyCoVarsOfType (TcTyVar -> Type
tyVarKind TcTyVar
one_skol) VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
later_skols
= Bool
True
| Bool
otherwise
= VarSet -> [TcTyVar] -> Bool
go (VarSet
later_skols VarSet -> TcTyVar -> VarSet
`extendVarSet` TcTyVar
one_skol) [TcTyVar]
earlier_skols
warnRedundantGivens :: SkolemInfo -> Bool
warnRedundantGivens :: SkolemInfo -> Bool
warnRedundantGivens (SigSkol UserTypeCtxt
ctxt Type
_ [(Name, TcTyVar)]
_)
= case UserTypeCtxt
ctxt of
FunSigCtxt Name
_ Bool
warn_redundant -> Bool
warn_redundant
UserTypeCtxt
ExprSigCtxt -> Bool
True
UserTypeCtxt
_ -> Bool
False
warnRedundantGivens (InstSkol {}) = Bool
True
warnRedundantGivens SkolemInfo
_ = Bool
False
neededEvVars :: Implication -> TcS Implication
neededEvVars :: Implication -> TcS Implication
neededEvVars implic :: Implication
implic@(Implic { ic_given :: Implication -> [TcTyVar]
ic_given = [TcTyVar]
givens
, ic_binds :: Implication -> EvBindsVar
ic_binds = EvBindsVar
ev_binds_var
, ic_wanted :: Implication -> WantedConstraints
ic_wanted = WC { wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics }
, ic_need_inner :: Implication -> VarSet
ic_need_inner = VarSet
old_needs })
= do { EvBindMap
ev_binds <- EvBindsVar -> TcS EvBindMap
TcS.getTcEvBindsMap EvBindsVar
ev_binds_var
; VarSet
tcvs <- EvBindsVar -> TcS VarSet
TcS.getTcEvTyCoVars EvBindsVar
ev_binds_var
; let seeds1 :: VarSet
seeds1 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Implication -> VarSet -> VarSet
add_implic_seeds VarSet
old_needs Bag Implication
implics
seeds2 :: VarSet
seeds2 = forall a. (EvBind -> a -> a) -> a -> EvBindMap -> a
nonDetStrictFoldEvBindMap EvBind -> VarSet -> VarSet
add_wanted VarSet
seeds1 EvBindMap
ev_binds
seeds3 :: VarSet
seeds3 = VarSet
seeds2 VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
tcvs
need_inner :: VarSet
need_inner = EvBindMap -> VarSet -> VarSet
findNeededEvVars EvBindMap
ev_binds VarSet
seeds3
live_ev_binds :: EvBindMap
live_ev_binds = (EvBind -> Bool) -> EvBindMap -> EvBindMap
filterEvBindMap (VarSet -> EvBind -> Bool
needed_ev_bind VarSet
need_inner) EvBindMap
ev_binds
need_outer :: VarSet
need_outer = VarSet -> EvBindMap -> VarSet
varSetMinusEvBindMap VarSet
need_inner EvBindMap
live_ev_binds
VarSet -> [TcTyVar] -> VarSet
`delVarSetList` [TcTyVar]
givens
; EvBindsVar -> EvBindMap -> TcS ()
TcS.setTcEvBindsMap EvBindsVar
ev_binds_var EvBindMap
live_ev_binds
; String -> SDoc -> TcS ()
traceTcS String
"neededEvVars" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"old_needs:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
old_needs
, String -> SDoc
text String
"seeds3:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
seeds3
, String -> SDoc
text String
"tcvs:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
tcvs
, String -> SDoc
text String
"ev_binds:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr EvBindMap
ev_binds
, String -> SDoc
text String
"live_ev_binds:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr EvBindMap
live_ev_binds ]
; forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implic { ic_need_inner :: VarSet
ic_need_inner = VarSet
need_inner
, ic_need_outer :: VarSet
ic_need_outer = VarSet
need_outer }) }
where
add_implic_seeds :: Implication -> VarSet -> VarSet
add_implic_seeds (Implic { ic_need_outer :: Implication -> VarSet
ic_need_outer = VarSet
needs }) VarSet
acc
= VarSet
needs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
acc
needed_ev_bind :: VarSet -> EvBind -> Bool
needed_ev_bind VarSet
needed (EvBind { eb_lhs :: EvBind -> TcTyVar
eb_lhs = TcTyVar
ev_var
, eb_is_given :: EvBind -> Bool
eb_is_given = Bool
is_given })
| Bool
is_given = TcTyVar
ev_var TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
needed
| Bool
otherwise = Bool
True
add_wanted :: EvBind -> VarSet -> VarSet
add_wanted :: EvBind -> VarSet -> VarSet
add_wanted (EvBind { eb_is_given :: EvBind -> Bool
eb_is_given = Bool
is_given, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
rhs }) VarSet
needs
| Bool
is_given = VarSet
needs
| Bool
otherwise = EvTerm -> VarSet
evVarsOfTerm EvTerm
rhs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
needs
simplifyHoles :: Bag Hole -> TcS (Bag Hole)
simplifyHoles :: Bag Hole -> TcS (Bag Hole)
simplifyHoles = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Hole -> TcS Hole
simpl_hole
where
simpl_hole :: Hole -> TcS Hole
simpl_hole :: Hole -> TcS Hole
simpl_hole h :: Hole
h@(Hole { hole_sort :: Hole -> HoleSort
hole_sort = HoleSort
ConstraintHole }) = forall (m :: * -> *) a. Monad m => a -> m a
return Hole
h
simpl_hole h :: Hole
h@(Hole { hole_ty :: Hole -> Type
hole_ty = Type
ty, hole_loc :: Hole -> CtLoc
hole_loc = CtLoc
loc })
= do { Type
ty' <- CtLoc -> Type -> TcS Type
rewriteType CtLoc
loc Type
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Hole
h { hole_ty :: Type
hole_ty = Type
ty' }) }
defaultTyVarTcS :: TcTyVar -> TcS Bool
defaultTyVarTcS :: TcTyVar -> TcS Bool
defaultTyVarTcS TcTyVar
the_tv
| TcTyVar -> Bool
isRuntimeRepVar TcTyVar
the_tv
, Bool -> Bool
not (TcTyVar -> Bool
isTyVarTyVar TcTyVar
the_tv)
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultTyVarTcS RuntimeRep" (forall a. Outputable a => a -> SDoc
ppr TcTyVar
the_tv)
; TcTyVar -> Type -> TcS ()
unifyTyVar TcTyVar
the_tv Type
liftedRepTy
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| TcTyVar -> Bool
isMultiplicityVar TcTyVar
the_tv
, Bool -> Bool
not (TcTyVar -> Bool
isTyVarTyVar TcTyVar
the_tv)
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultTyVarTcS Multiplicity" (forall a. Outputable a => a -> SDoc
ppr TcTyVar
the_tv)
; TcTyVar -> Type -> TcS ()
unifyTyVar TcTyVar
the_tv Type
manyDataConTy
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
approximateWC :: Bool -> WantedConstraints -> Cts
approximateWC :: Bool -> WantedConstraints -> Cts
approximateWC Bool
float_past_equalities WantedConstraints
wc
= VarSet -> WantedConstraints -> Cts
float_wc VarSet
emptyVarSet WantedConstraints
wc
where
float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
float_wc :: VarSet -> WantedConstraints -> Cts
float_wc VarSet
trapping_tvs (WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics })
= forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (VarSet -> Ct -> Bool
is_floatable VarSet
trapping_tvs) Cts
simples forall a. Bag a -> Bag a -> Bag a
`unionBags`
forall a b. (a -> Bag b) -> Bag a -> Bag b
concatMapBag (VarSet -> Implication -> Cts
float_implic VarSet
trapping_tvs) Bag Implication
implics
float_implic :: TcTyCoVarSet -> Implication -> Cts
float_implic :: VarSet -> Implication -> Cts
float_implic VarSet
trapping_tvs Implication
imp
| Bool
float_past_equalities Bool -> Bool -> Bool
|| Implication -> HasGivenEqs
ic_given_eqs Implication
imp forall a. Eq a => a -> a -> Bool
/= HasGivenEqs
MaybeGivenEqs
= VarSet -> WantedConstraints -> Cts
float_wc VarSet
new_trapping_tvs (Implication -> WantedConstraints
ic_wanted Implication
imp)
| Bool
otherwise
= Cts
emptyCts
where
new_trapping_tvs :: VarSet
new_trapping_tvs = VarSet
trapping_tvs VarSet -> [TcTyVar] -> VarSet
`extendVarSetList` Implication -> [TcTyVar]
ic_skols Implication
imp
is_floatable :: VarSet -> Ct -> Bool
is_floatable VarSet
skol_tvs Ct
ct
| Ct -> Bool
isGivenCt Ct
ct = Bool
False
| Ct -> Bool
insolubleEqCt Ct
ct = Bool
False
| Bool
otherwise = Ct -> VarSet
tyCoVarsOfCt Ct
ct VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
skol_tvs
applyDefaultingRules :: WantedConstraints -> TcS Bool
applyDefaultingRules :: WantedConstraints -> TcS Bool
applyDefaultingRules WantedConstraints
wanteds
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanteds
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise
= do { info :: ([Type], (Bool, Bool))
info@([Type]
default_tys, (Bool, Bool)
_) <- TcS ([Type], (Bool, Bool))
getDefaultInfo
; WantedConstraints
wanteds <- WantedConstraints -> TcS WantedConstraints
TcS.zonkWC WantedConstraints
wanteds
; let groups :: [(TcTyVar, [Ct])]
groups = ([Type], (Bool, Bool)) -> WantedConstraints -> [(TcTyVar, [Ct])]
findDefaultableGroups ([Type], (Bool, Bool))
info WantedConstraints
wanteds
; String -> SDoc -> TcS ()
traceTcS String
"applyDefaultingRules {" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"wanteds =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanteds
, String -> SDoc
text String
"groups =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [(TcTyVar, [Ct])]
groups
, String -> SDoc
text String
"info =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ([Type], (Bool, Bool))
info ]
; [Bool]
something_happeneds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Type] -> (TcTyVar, [Ct]) -> TcS Bool
disambigGroup [Type]
default_tys) [(TcTyVar, [Ct])]
groups
; String -> SDoc -> TcS ()
traceTcS String
"applyDefaultingRules }" (forall a. Outputable a => a -> SDoc
ppr [Bool]
something_happeneds)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
something_happeneds) }
findDefaultableGroups
:: ( [Type]
, (Bool,Bool) )
-> WantedConstraints
-> [(TyVar, [Ct])]
findDefaultableGroups :: ([Type], (Bool, Bool)) -> WantedConstraints -> [(TcTyVar, [Ct])]
findDefaultableGroups ([Type]
default_tys, (Bool
ovl_strings, Bool
extended_defaults)) WantedConstraints
wanteds
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
default_tys
= []
| Bool
otherwise
= [ (TcTyVar
tv, forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 [(Ct, Class, TcTyVar)]
group)
| group' :: NonEmpty (Ct, Class, TcTyVar)
group'@((Ct
_,Class
_,TcTyVar
tv) :| [(Ct, Class, TcTyVar)]
_) <- [NonEmpty (Ct, Class, TcTyVar)]
unary_groups
, let group :: [(Ct, Class, TcTyVar)]
group = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Ct, Class, TcTyVar)
group'
, TcTyVar -> Bool
defaultable_tyvar TcTyVar
tv
, [Class] -> Bool
defaultable_classes (forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> b
sndOf3 [(Ct, Class, TcTyVar)]
group) ]
where
simples :: Cts
simples = Bool -> WantedConstraints -> Cts
approximateWC Bool
True WantedConstraints
wanteds
([(Ct, Class, TcTyVar)]
unaries, [Ct]
non_unaries) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Ct -> Either (Ct, Class, TcTyVar) Ct
find_unary (forall a. Bag a -> [a]
bagToList Cts
simples)
unary_groups :: [NonEmpty (Ct, Class, TcTyVar)]
unary_groups = forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses forall {a} {a} {b} {a} {b}.
Ord a =>
(a, b, a) -> (a, b, a) -> Ordering
cmp_tv [(Ct, Class, TcTyVar)]
unaries
unary_groups :: [NonEmpty (Ct, Class, TcTyVar)]
unaries :: [(Ct, Class, TcTyVar)]
non_unaries :: [Ct]
find_unary :: Ct -> Either (Ct, Class, TyVar) Ct
find_unary :: Ct -> Either (Ct, Class, TcTyVar) Ct
find_unary Ct
cc
| Just (Class
cls,[Type]
tys) <- Type -> Maybe (Class, [Type])
getClassPredTys_maybe (Ct -> Type
ctPred Ct
cc)
, [Type
ty] <- TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
tys
, Just TcTyVar
tv <- Type -> Maybe TcTyVar
tcGetTyVar_maybe Type
ty
, TcTyVar -> Bool
isMetaTyVar TcTyVar
tv
= forall a b. a -> Either a b
Left (Ct
cc, Class
cls, TcTyVar
tv)
find_unary Ct
cc = forall a b. b -> Either a b
Right Ct
cc
bad_tvs :: TcTyCoVarSet
bad_tvs :: VarSet
bad_tvs = forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet Ct -> VarSet
tyCoVarsOfCt [Ct]
non_unaries
cmp_tv :: (a, b, a) -> (a, b, a) -> Ordering
cmp_tv (a
_,b
_,a
tv1) (a
_,b
_,a
tv2) = a
tv1 forall a. Ord a => a -> a -> Ordering
`compare` a
tv2
defaultable_tyvar :: TcTyVar -> Bool
defaultable_tyvar :: TcTyVar -> Bool
defaultable_tyvar TcTyVar
tv
= let b1 :: Bool
b1 = TcTyVar -> Bool
isTyConableTyVar TcTyVar
tv
b2 :: Bool
b2 = Bool -> Bool
not (TcTyVar
tv TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
bad_tvs)
in Bool
b1 Bool -> Bool -> Bool
&& (Bool
b2 Bool -> Bool -> Bool
|| Bool
extended_defaults)
defaultable_classes :: [Class] -> Bool
defaultable_classes :: [Class] -> Bool
defaultable_classes [Class]
clss
| Bool
extended_defaults = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Class -> Bool
isInteractiveClass Bool
ovl_strings) [Class]
clss
| Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Class -> Bool
is_std_class [Class]
clss Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Class -> Bool
isNumClass Bool
ovl_strings) [Class]
clss)
is_std_class :: Class -> Bool
is_std_class Class
cls = Class -> Bool
isStandardClass Class
cls Bool -> Bool -> Bool
||
(Bool
ovl_strings Bool -> Bool -> Bool
&& (Class
cls forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
isStringClassKey))
disambigGroup :: [Type]
-> (TcTyVar, [Ct])
-> TcS Bool
disambigGroup :: [Type] -> (TcTyVar, [Ct]) -> TcS Bool
disambigGroup [] (TcTyVar, [Ct])
_
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
disambigGroup (Type
default_ty:[Type]
default_tys) group :: (TcTyVar, [Ct])
group@(TcTyVar
the_tv, [Ct]
wanteds)
= do { String -> SDoc -> TcS ()
traceTcS String
"disambigGroup {" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Type
default_ty, forall a. Outputable a => a -> SDoc
ppr TcTyVar
the_tv, forall a. Outputable a => a -> SDoc
ppr [Ct]
wanteds ])
; EvBindsVar
fake_ev_binds_var <- TcS EvBindsVar
TcS.newTcEvBinds
; TcLevel
tclvl <- TcS TcLevel
TcS.getTcLevel
; Bool
success <- forall a. EvBindsVar -> TcLevel -> TcS a -> TcS a
nestImplicTcS EvBindsVar
fake_ev_binds_var (TcLevel -> TcLevel
pushTcLevel TcLevel
tclvl) TcS Bool
try_group
; if Bool
success then
do { TcTyVar -> Type -> TcS ()
unifyTyVar TcTyVar
the_tv Type
default_ty
; forall a. TcM a -> TcS a
wrapWarnTcS forall a b. (a -> b) -> a -> b
$ [Ct] -> Type -> TcM ()
warnDefaulting [Ct]
wanteds Type
default_ty
; String -> SDoc -> TcS ()
traceTcS String
"disambigGroup succeeded }" (forall a. Outputable a => a -> SDoc
ppr Type
default_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
else
do { String -> SDoc -> TcS ()
traceTcS String
"disambigGroup failed, will try other default types }"
(forall a. Outputable a => a -> SDoc
ppr Type
default_ty)
; [Type] -> (TcTyVar, [Ct]) -> TcS Bool
disambigGroup [Type]
default_tys (TcTyVar, [Ct])
group } }
where
try_group :: TcS Bool
try_group
| Just TCvSubst
subst <- Maybe TCvSubst
mb_subst
= do { TcLclEnv
lcl_env <- TcS TcLclEnv
TcS.getLclEnv
; TcLevel
tc_lvl <- TcS TcLevel
TcS.getTcLevel
; let loc :: CtLoc
loc = TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc TcLevel
tc_lvl SkolemInfo
UnkSkol TcLclEnv
lcl_env
; [CtEvidence]
wanted_evs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtLoc -> Type -> TcS CtEvidence
newWantedEvVarNC CtLoc
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> Type
ctPred)
[Ct]
wanteds
; forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WantedConstraints -> Bool
isEmptyWC forall a b. (a -> b) -> a -> b
$
Cts -> TcS WantedConstraints
solveSimpleWanteds forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> Ct
mkNonCanonical [CtEvidence]
wanted_evs }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
the_ty :: Type
the_ty = TcTyVar -> Type
mkTyVarTy TcTyVar
the_tv
mb_subst :: Maybe TCvSubst
mb_subst = Type -> Type -> Maybe TCvSubst
tcMatchTyKi Type
the_ty Type
default_ty
isInteractiveClass :: Bool
-> Class -> Bool
isInteractiveClass :: Bool -> Class -> Bool
isInteractiveClass Bool
ovl_strings Class
cls
= Bool -> Class -> Bool
isNumClass Bool
ovl_strings Class
cls Bool -> Bool -> Bool
|| (Class -> Unique
classKey Class
cls forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
interactiveClassKeys)
isNumClass :: Bool
-> Class -> Bool
isNumClass :: Bool -> Class -> Bool
isNumClass Bool
ovl_strings Class
cls
= Class -> Bool
isNumericClass Class
cls Bool -> Bool -> Bool
|| (Bool
ovl_strings Bool -> Bool -> Bool
&& (Class
cls forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
isStringClassKey))