module GHC.Tc.Solver.Default(
tryDefaulting, tryUnsatisfiableGivens,
isInteractiveClass, isNumClass
) where
import GHC.Prelude
import GHC.Tc.Errors
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Evidence
import GHC.Tc.Solver.Solve ( solveSimpleWanteds, setImplicationStatus )
import GHC.Tc.Solver.Dict ( solveCallStack )
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcMType as TcM
import GHC.Tc.Utils.Monad as TcM
import GHC.Tc.Zonk.TcType as TcM
import GHC.Tc.Solver.Solve( solveWanteds )
import GHC.Tc.Solver.Monad as TcS
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc( mkGivenLoc )
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Core.Class
import GHC.Core.Reduction( Reduction, reductionCoercion )
import GHC.Core
import GHC.Core.DataCon
import GHC.Core.Make
import GHC.Core.Coercion( mkNomReflCo, isReflCo )
import GHC.Core.Unify ( tcMatchTyKis )
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.TyCon ( TyCon )
import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList )
import GHC.Types.Unique.Set
import GHC.Types.Id
import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Types.TyThing ( MonadThings(lookupId) )
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Id.Make ( unboxedUnitExpr )
import GHC.Driver.DynFlags
import GHC.Unit.Module ( getModule )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Data.Bag
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.State.Strict ( StateT(runStateT), put )
import Data.Foldable ( toList, traverse_ )
import Data.List ( intersect )
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import GHC.Data.Maybe ( isJust, mapMaybe, catMaybes )
import Data.Monoid ( First(..) )
tryDefaulting :: WantedConstraints -> TcS WantedConstraints
tryDefaulting :: WantedConstraints -> TcS WantedConstraints
tryDefaulting WantedConstraints
wc
= do { dflags <- TcS DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; traceTcS "tryDefaulting:before" (ppr wc)
; wc1 <- tryTyVarDefaulting dflags wc
; wc2 <- tryConstraintDefaulting wc1
; wc3 <- tryTypeClassDefaulting wc2
; wc4 <- tryUnsatisfiableGivens wc3
; traceTcS "tryDefaulting:after" (ppr wc4)
; return wc4 }
solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints
solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints
solveAgainIf Bool
False WantedConstraints
wc = WantedConstraints -> TcS WantedConstraints
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
solveAgainIf Bool
True WantedConstraints
wc = TcS WantedConstraints -> TcS WantedConstraints
forall a. TcS a -> TcS a
nestTcS (WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wc)
tryTyVarDefaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints
tryTyVarDefaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints
tryTyVarDefaulting DynFlags
dflags WantedConstraints
wc
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wc
= WantedConstraints -> TcS WantedConstraints
forall a. a -> TcS a
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
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
| Bool
otherwise
= do {
; free_tvs <- [TcTyVar] -> TcS [TcTyVar]
TcS.zonkTyCoVarsAndFVList (WantedConstraints -> [TcTyVar]
tyCoVarsOfWCList WantedConstraints
wc)
; let defaultable_tvs = (TcTyVar -> Bool) -> [TcTyVar] -> [TcTyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TcTyVar -> Bool
can_default [TcTyVar]
free_tvs
can_default TcTyVar
tv
= TcTyVar -> Bool
isTyVar TcTyVar
tv
Bool -> Bool -> Bool
&& TcTyVar -> Bool
isMetaTyVar TcTyVar
tv
Bool -> Bool -> Bool
&& Bool -> Bool
not (TcTyVar
tv TcTyVar -> VarSet -> Bool
`elemVarSet` WantedConstraints -> VarSet
nonDefaultableTyVarsOfWC WantedConstraints
wc)
; unification_s <- mapM defaultTyVarTcS defaultable_tvs
; solveAgainIf (or unification_s) wc }
type UnificationDone = Bool
noUnification, didUnification :: UnificationDone
noUnification :: Bool
noUnification = Bool
False
didUnification :: Bool
didUnification = Bool
True
defaultTyVarTcS :: TcTyVar -> TcS UnificationDone
defaultTyVarTcS :: TcTyVar -> TcS Bool
defaultTyVarTcS TcTyVar
the_tv
| TcTyVar -> Bool
isTyVarTyVar TcTyVar
the_tv
= Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
noUnification
| TcTyVar -> Bool
isRuntimeRepVar TcTyVar
the_tv
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultTyVarTcS RuntimeRep" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
the_tv)
; TcTyVar -> TcType -> TcS ()
unifyTyVar TcTyVar
the_tv TcType
liftedRepTy
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
didUnification }
| TcTyVar -> Bool
isLevityVar TcTyVar
the_tv
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultTyVarTcS Levity" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
the_tv)
; TcTyVar -> TcType -> TcS ()
unifyTyVar TcTyVar
the_tv TcType
liftedDataConTy
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
didUnification }
| TcTyVar -> Bool
isMultiplicityVar TcTyVar
the_tv
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultTyVarTcS Multiplicity" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
the_tv)
; TcTyVar -> TcType -> TcS ()
unifyTyVar TcTyVar
the_tv TcType
ManyTy
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
didUnification }
| Bool
otherwise
= Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
noUnification
tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints
tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints
tryUnsatisfiableGivens WantedConstraints
wc =
do { (final_wc, did_work) <- (StateT Bool TcS WantedConstraints
-> Bool -> TcS (WantedConstraints, Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` Bool
False) (StateT Bool TcS WantedConstraints
-> TcS (WantedConstraints, Bool))
-> StateT Bool TcS WantedConstraints
-> TcS (WantedConstraints, Bool)
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> StateT Bool TcS WantedConstraints
go_wc WantedConstraints
wc
; solveAgainIf did_work final_wc }
where
go_wc :: WantedConstraints -> StateT Bool TcS WantedConstraints
go_wc (WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
wtds, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
impls, wc_errors :: WantedConstraints -> Bag DelayedError
wc_errors = Bag DelayedError
errs })
= do impls' <- (Implication -> StateT Bool TcS (Maybe Implication))
-> Bag Implication -> StateT Bool TcS (Bag Implication)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Bag a -> m (Bag b)
mapMaybeBagM Implication -> StateT Bool TcS (Maybe Implication)
go_impl Bag Implication
impls
return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs }
go_impl :: Implication -> StateT Bool TcS (Maybe Implication)
go_impl Implication
impl
| ImplicStatus -> Bool
isSolvedStatus (Implication -> ImplicStatus
ic_status Implication
impl)
= Maybe Implication -> StateT Bool TcS (Maybe Implication)
forall a. a -> StateT Bool TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Implication -> StateT Bool TcS (Maybe Implication))
-> Maybe Implication -> StateT Bool TcS (Maybe Implication)
forall a b. (a -> b) -> a -> b
$ Implication -> Maybe Implication
forall a. a -> Maybe a
Just Implication
impl
| (TcTyVar, TcType)
unsat_given:[(TcTyVar, TcType)]
_ <- (TcTyVar -> Maybe (TcTyVar, TcType))
-> [TcTyVar] -> [(TcTyVar, TcType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcTyVar -> Maybe (TcTyVar, TcType)
unsatisfiableEv_maybe (Implication -> [TcTyVar]
ic_given Implication
impl)
= do { Bool -> StateT Bool TcS ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
True
; TcS (Maybe Implication) -> StateT Bool TcS (Maybe Implication)
forall (m :: * -> *) a. Monad m => m a -> StateT Bool m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcS (Maybe Implication) -> StateT Bool TcS (Maybe Implication))
-> TcS (Maybe Implication) -> StateT Bool TcS (Maybe Implication)
forall a b. (a -> b) -> a -> b
$ (TcTyVar, TcType) -> Implication -> TcS (Maybe Implication)
solveImplicationUsingUnsatGiven (TcTyVar, TcType)
unsat_given Implication
impl }
| Bool
otherwise
= do { wcs' <- WantedConstraints -> StateT Bool TcS WantedConstraints
go_wc (Implication -> WantedConstraints
ic_wanted Implication
impl)
; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } }
unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type)
unsatisfiableEv_maybe :: TcTyVar -> Maybe (TcTyVar, TcType)
unsatisfiableEv_maybe TcTyVar
v = (TcTyVar
v,) (TcType -> (TcTyVar, TcType))
-> Maybe TcType -> Maybe (TcTyVar, TcType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcType -> Maybe TcType
isUnsatisfiableCt_maybe (TcTyVar -> TcType
idType TcTyVar
v)
solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS (Maybe Implication)
solveImplicationUsingUnsatGiven :: (TcTyVar, TcType) -> Implication -> TcS (Maybe Implication)
solveImplicationUsingUnsatGiven
unsat_given :: (TcTyVar, TcType)
unsat_given@(TcTyVar
given_ev,TcType
_)
impl :: Implication
impl@(Implic { ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wtd, ic_tclvl :: Implication -> TcLevel
ic_tclvl = TcLevel
tclvl, ic_binds :: Implication -> EvBindsVar
ic_binds = EvBindsVar
ev_binds_var, ic_need_inner :: Implication -> VarSet
ic_need_inner = VarSet
inner })
| EvBindsVar -> Bool
isCoEvBindsVar EvBindsVar
ev_binds_var
= Maybe Implication -> TcS (Maybe Implication)
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Implication -> TcS (Maybe Implication))
-> Maybe Implication -> TcS (Maybe Implication)
forall a b. (a -> b) -> a -> b
$ Implication -> Maybe Implication
forall a. a -> Maybe a
Just Implication
impl
| Bool
otherwise
= do { wcs <- EvBindsVar
-> TcLevel -> TcS WantedConstraints -> TcS WantedConstraints
forall a. EvBindsVar -> TcLevel -> TcS a -> TcS a
nestImplicTcS EvBindsVar
ev_binds_var TcLevel
tclvl (TcS WantedConstraints -> TcS WantedConstraints)
-> TcS WantedConstraints -> TcS WantedConstraints
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> TcS WantedConstraints
go_wc WantedConstraints
wtd
; setImplicationStatus $
impl { ic_wanted = wcs
, ic_need_inner = inner `extendVarSet` given_ev } }
where
go_wc :: WantedConstraints -> TcS WantedConstraints
go_wc :: WantedConstraints -> TcS WantedConstraints
go_wc wc :: WantedConstraints
wc@(WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
wtds, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
impls })
= do { (Ct -> TcS ()) -> Cts -> TcS ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ Ct -> TcS ()
go_simple Cts
wtds
; impls <- (Implication -> TcS (Maybe Implication))
-> Bag Implication -> TcS (Bag Implication)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Bag a -> m (Bag b)
mapMaybeBagM ((TcTyVar, TcType) -> Implication -> TcS (Maybe Implication)
solveImplicationUsingUnsatGiven (TcTyVar, TcType)
unsat_given) Bag Implication
impls
; return $ wc { wc_simple = emptyBag, wc_impl = impls } }
go_simple :: Ct -> TcS ()
go_simple :: Ct -> TcS ()
go_simple Ct
ct = case Ct -> CtEvidence
ctEvidence Ct
ct of
CtWanted { ctev_pred :: CtEvidence -> TcType
ctev_pred = TcType
pty, ctev_dest :: CtEvidence -> TcEvDest
ctev_dest = TcEvDest
dst }
-> do { ev_expr <- (TcTyVar, TcType) -> TcType -> TcS EvExpr
unsatisfiableEvExpr (TcTyVar, TcType)
unsat_given TcType
pty
; setWantedEvTerm dst EvNonCanonical $ EvExpr ev_expr }
CtEvidence
_ -> () -> TcS ()
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr
unsatisfiableEvExpr :: (TcTyVar, TcType) -> TcType -> TcS EvExpr
unsatisfiableEvExpr (TcTyVar
unsat_ev, TcType
given_msg) TcType
wtd_ty
= do { mod <- TcS Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if mod == gHC_INTERNAL_TYPEERROR then return (Var unsat_ev) else
do { unsatisfiable_id <- tcLookupId unsatisfiableIdName
; let
fun_ty = HasDebugCallStack =>
FunTyFlag -> TcType -> TcType -> TcType -> TcType
FunTyFlag -> TcType -> TcType -> TcType -> TcType
mkFunTy FunTyFlag
visArgConstraintLike TcType
ManyTy TcType
unboxedUnitTy TcType
wtd_ty
mkDictBox = case TcType -> BoxingInfo (ZonkAny 0)
forall b. TcType -> BoxingInfo b
boxingDataCon TcType
fun_ty of
BI_Box { bi_data_con :: forall b. BoxingInfo b -> DataCon
bi_data_con = DataCon
mkDictBox } -> DataCon
mkDictBox
BoxingInfo (ZonkAny 0)
_ -> String -> SDoc -> DataCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsatisfiableEvExpr: no DictBox!" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
wtd_ty)
dictBox = DataCon -> TyCon
dataConTyCon DataCon
mkDictBox
; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty
; let scrut_ty = TyCon -> [TcType] -> TcType
mkTyConApp TyCon
dictBox [TcType
fun_ty]
scrut =
EvExpr -> [EvExpr] -> EvExpr
mkCoreApps (TcTyVar -> EvExpr
forall b. TcTyVar -> Expr b
Var TcTyVar
unsatisfiable_id)
[ TcType -> EvExpr
forall b. TcType -> Expr b
Type TcType
liftedRepTy
, TcType -> EvExpr
forall b. TcType -> Expr b
Type TcType
given_msg
, TcType -> EvExpr
forall b. TcType -> Expr b
Type TcType
scrut_ty
, TcTyVar -> EvExpr
forall b. TcTyVar -> Expr b
Var TcTyVar
unsat_ev ]
ev_expr =
EvExpr -> Scaled TcType -> TcType -> [CoreAlt] -> EvExpr
mkWildCase EvExpr
scrut (TcType -> Scaled TcType
forall a. a -> Scaled a
unrestricted (TcType -> Scaled TcType) -> TcType -> Scaled TcType
forall a b. (a -> b) -> a -> b
$ TcType
scrut_ty) TcType
wtd_ty
[ AltCon -> [TcTyVar] -> EvExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
mkDictBox) [TcTyVar
ev_bndr] (EvExpr -> CoreAlt) -> EvExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$
EvExpr -> [EvExpr] -> EvExpr
mkCoreApps (TcTyVar -> EvExpr
forall b. TcTyVar -> Expr b
Var TcTyVar
ev_bndr) [EvExpr
unboxedUnitExpr]
]
; return ev_expr } }
type CtDefaultingStrategy = Ct -> TcS Bool
tryConstraintDefaulting :: WantedConstraints -> TcS WantedConstraints
tryConstraintDefaulting :: WantedConstraints -> TcS WantedConstraints
tryConstraintDefaulting WantedConstraints
wc
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wc
= WantedConstraints -> TcS WantedConstraints
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
| Bool
otherwise
= do { (n_unifs, better_wc) <- TcS WantedConstraints -> TcS (Int, WantedConstraints)
forall a. TcS a -> TcS (Int, a)
reportUnifications (WantedConstraints -> TcS WantedConstraints
go_wc WantedConstraints
wc)
; solveAgainIf (n_unifs > 0) better_wc }
where
go_wc :: WantedConstraints -> TcS WantedConstraints
go_wc :: WantedConstraints -> TcS WantedConstraints
go_wc wc :: WantedConstraints
wc@(WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics })
= do { mb_simples <- (Ct -> TcS (Maybe Ct)) -> Cts -> TcS Cts
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Bag a -> m (Bag b)
mapMaybeBagM Ct -> TcS (Maybe Ct)
go_simple Cts
simples
; mb_implics <- mapMaybeBagM go_implic implics
; return (wc { wc_simple = mb_simples, wc_impl = mb_implics }) }
go_simple :: Ct -> TcS (Maybe Ct)
go_simple :: Ct -> TcS (Maybe Ct)
go_simple Ct
ct = do { solved <- CtDefaultingStrategy
tryCtDefaultingStrategy Ct
ct
; if solved then return Nothing
else return (Just ct) }
go_implic :: Implication -> TcS (Maybe Implication)
go_implic :: Implication -> TcS (Maybe Implication)
go_implic Implication
implic
| ImplicStatus -> Bool
isSolvedStatus (Implication -> ImplicStatus
ic_status Implication
implic)
= Maybe Implication -> TcS (Maybe Implication)
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication -> Maybe Implication
forall a. a -> Maybe a
Just Implication
implic)
| Bool
otherwise
= do { wanteds <- EvBindsVar -> TcS WantedConstraints -> TcS WantedConstraints
forall a. EvBindsVar -> TcS a -> TcS a
setEvBindsTcS (Implication -> EvBindsVar
ic_binds Implication
implic) (TcS WantedConstraints -> TcS WantedConstraints)
-> TcS WantedConstraints -> TcS WantedConstraints
forall a b. (a -> b) -> a -> b
$
WantedConstraints -> TcS WantedConstraints
go_wc (Implication -> WantedConstraints
ic_wanted Implication
implic)
; setImplicationStatus (implic { ic_wanted = wanteds }) }
tryCtDefaultingStrategy :: CtDefaultingStrategy
tryCtDefaultingStrategy :: CtDefaultingStrategy
tryCtDefaultingStrategy
= (CtDefaultingStrategy
-> CtDefaultingStrategy -> CtDefaultingStrategy)
-> [CtDefaultingStrategy] -> CtDefaultingStrategy
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 CtDefaultingStrategy
-> CtDefaultingStrategy -> CtDefaultingStrategy
combineStrategies
[ CtDefaultingStrategy
defaultCallStack
, CtDefaultingStrategy
defaultExceptionContext
, CtDefaultingStrategy
defaultEquality ]
defaultExceptionContext :: CtDefaultingStrategy
defaultExceptionContext :: CtDefaultingStrategy
defaultExceptionContext Ct
ct
| ClassPred Class
cls [TcType]
tys <- TcType -> Pred
classifyPredType (Ct -> TcType
ctPred Ct
ct)
, Maybe FastString -> Bool
forall a. Maybe a -> Bool
isJust (Class -> [TcType] -> Maybe FastString
isExceptionContextPred Class
cls [TcType]
tys)
= do { TcRnMessage -> TcS ()
warnTcS (TcRnMessage -> TcS ()) -> TcRnMessage -> TcS ()
forall a b. (a -> b) -> a -> b
$ CtLoc -> TcRnMessage
TcRnDefaultedExceptionContext (Ct -> CtLoc
ctLoc Ct
ct)
; empty_ec_id <- Name -> TcS TcTyVar
forall (m :: * -> *). MonadThings m => Name -> m TcTyVar
lookupId Name
emptyExceptionContextName
; let ev = Ct -> CtEvidence
ctEvidence Ct
ct
ev_tm = EvExpr -> TcCoercion -> EvTerm
mkEvCast (TcTyVar -> EvExpr
forall b. TcTyVar -> Expr b
Var TcTyVar
empty_ec_id) (TcType -> TcCoercion
wrapIP (CtEvidence -> TcType
ctEvPred CtEvidence
ev))
; setEvBindIfWanted ev EvCanonical ev_tm
; return True }
| Bool
otherwise
= Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
defaultCallStack :: CtDefaultingStrategy
defaultCallStack :: CtDefaultingStrategy
defaultCallStack Ct
ct
| ClassPred Class
cls [TcType]
tys <- TcType -> Pred
classifyPredType (Ct -> TcType
ctPred Ct
ct)
, Maybe FastString -> Bool
forall a. Maybe a -> Bool
isJust (Class -> [TcType] -> Maybe FastString
isCallStackPred Class
cls [TcType]
tys)
= do { CtEvidence -> EvCallStack -> TcS ()
solveCallStack (Ct -> CtEvidence
ctEvidence Ct
ct) EvCallStack
EvCsEmpty
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| Bool
otherwise
= Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
defaultEquality :: CtDefaultingStrategy
defaultEquality :: CtDefaultingStrategy
defaultEquality Ct
ct
| EqPred EqRel
NomEq TcType
ty1 TcType
ty2 <- TcType -> Pred
classifyPredType (Ct -> TcType
ctPred Ct
ct)
= do {
z_ty1 <- TcType -> TcS TcType
TcS.zonkTcType TcType
ty1
; z_ty2 <- TcS.zonkTcType ty2
; case (getTyVar_maybe z_ty1, getTyVar_maybe z_ty2) of
(Just TcTyVar
z_tv1, Maybe TcTyVar
_) -> TcTyVar -> TcType -> TcS Bool
try_default_tv TcTyVar
z_tv1 TcType
z_ty2
(Maybe TcTyVar
_, Just TcTyVar
z_tv2) -> TcTyVar -> TcType -> TcS Bool
try_default_tv TcTyVar
z_tv2 TcType
z_ty1
(Maybe TcTyVar, Maybe TcTyVar)
_ -> Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False }
| Bool
otherwise
= Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
try_default_tv :: TcTyVar -> TcType -> TcS Bool
try_default_tv TcTyVar
lhs_tv TcType
rhs_ty
| MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info, mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
lvl } <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
lhs_tv
, TcTyVar -> TcType
tyVarKind TcTyVar
lhs_tv HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` HasDebugCallStack => TcType -> TcType
TcType -> TcType
typeKind TcType
rhs_ty
, MetaInfo -> TcType -> Bool
checkTopShape MetaInfo
info TcType
rhs_ty
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultEquality 1" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
lhs_tv SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
rhs_ty)
; let flags :: TyEqFlags ()
flags :: TyEqFlags ()
flags = TEF { tef_foralls :: Bool
tef_foralls = Bool
False
, tef_fam_app :: TyEqFamApp ()
tef_fam_app = TyEqFamApp ()
forall a. TyEqFamApp a
TEFA_Recurse
, tef_lhs :: CanEqLHS
tef_lhs = TcTyVar -> CanEqLHS
TyVarLHS TcTyVar
lhs_tv
, tef_unifying :: AreUnifying
tef_unifying = MetaInfo -> TcLevel -> LevelCheck -> AreUnifying
Unifying MetaInfo
info TcLevel
lvl (Bool -> LevelCheck
LC_Promote Bool
True)
, tef_occurs :: CheckTyEqProblem
tef_occurs = CheckTyEqProblem
cteInsolubleOccurs }
; res :: PuResult () Reduction <- TcM (PuResult () Reduction) -> TcS (PuResult () Reduction)
forall a. TcM a -> TcS a
wrapTcS (TyEqFlags () -> TcType -> TcM (PuResult () Reduction)
forall a. TyEqFlags a -> TcType -> TcM (PuResult a Reduction)
checkTyEqRhs TyEqFlags ()
flags TcType
rhs_ty)
; case res of
PuFail {} -> String -> TcS Bool
cant_default_tv String
"checkTyEqRhs"
PuOK Bag ()
_ Reduction
redn -> Bool -> SDoc -> TcS Bool -> TcS Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TcCoercion -> Bool
isReflCo (Reduction -> TcCoercion
reductionCoercion Reduction
redn)) (Reduction -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reduction
redn) (TcS Bool -> TcS Bool) -> TcS Bool -> TcS Bool
forall a b. (a -> b) -> a -> b
$
TcS Bool
default_tv }
| Bool
otherwise
= String -> TcS Bool
cant_default_tv String
"fall through"
where
cant_default_tv :: String -> TcS Bool
cant_default_tv String
msg
= do { String -> SDoc -> TcS ()
traceTcS (String
"defaultEquality fails: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) (SDoc -> TcS ()) -> SDoc -> TcS ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
lhs_tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
rhs_ty
, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcTyVar -> TcType
tyVarKind TcTyVar
lhs_tv)
, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => TcType -> TcType
TcType -> TcType
typeKind TcType
rhs_ty) ]
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False }
default_tv :: TcS Bool
default_tv
= do { String -> SDoc -> TcS ()
traceTcS String
"defaultEquality success:" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
rhs_ty)
; TcTyVar -> TcType -> TcS ()
unifyTyVar TcTyVar
lhs_tv TcType
rhs_ty
; CtEvidence -> CanonicalEvidence -> EvTerm -> TcS ()
setEvBindIfWanted (Ct -> CtEvidence
ctEvidence Ct
ct) CanonicalEvidence
EvCanonical (EvTerm -> TcS ()) -> EvTerm -> TcS ()
forall a b. (a -> b) -> a -> b
$
TcCoercion -> EvTerm
evCoercion (TcType -> TcCoercion
mkNomReflCo TcType
rhs_ty)
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
combineStrategies :: CtDefaultingStrategy -> CtDefaultingStrategy -> CtDefaultingStrategy
combineStrategies :: CtDefaultingStrategy
-> CtDefaultingStrategy -> CtDefaultingStrategy
combineStrategies CtDefaultingStrategy
default1 CtDefaultingStrategy
default2 Ct
ct
= do { solved <- CtDefaultingStrategy
default1 Ct
ct
; case solved of
Bool
True -> Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool
False -> CtDefaultingStrategy
default2 Ct
ct
}
tryTypeClassDefaulting :: WantedConstraints -> TcS WantedConstraints
tryTypeClassDefaulting :: WantedConstraints -> TcS WantedConstraints
tryTypeClassDefaulting WantedConstraints
wc
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wc Bool -> Bool -> Bool
|| WantedConstraints -> Bool
insolubleWC WantedConstraints
wc
= WantedConstraints -> TcS WantedConstraints
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
wc
| Bool
otherwise
= do { something_happened <- WantedConstraints -> TcS Bool
applyDefaultingRules WantedConstraints
wc
; solveAgainIf something_happened wc }
applyDefaultingRules :: WantedConstraints -> TcS Bool
applyDefaultingRules :: WantedConstraints -> TcS Bool
applyDefaultingRules WantedConstraints
wanteds
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanteds
= Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise
= do { (default_env, extended_rules) <- TcS (DefaultEnv, Bool)
getDefaultInfo
; wanteds <- TcS.zonkWC wanteds
; tcg_env <- TcS.getGblEnv
; let plugins = TcGblEnv -> [FillDefaulting]
tcg_defaulting_plugins TcGblEnv
tcg_env
default_tys = DefaultEnv -> [ClassDefaults]
defaultList DefaultEnv
default_env
; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else
do {
; traceTcS "defaultingPlugins {" (ppr wanteds)
; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins
; traceTcS "defaultingPlugins }" (ppr defaultedGroups)
; return (wanteds, defaultedGroups)
}
; let groups = ([ClassDefaults], Bool) -> WantedConstraints -> [(TcTyVar, [Ct])]
findDefaultableGroups ([ClassDefaults]
default_tys, Bool
extended_rules) WantedConstraints
wanteds
; traceTcS "applyDefaultingRules {" $
vcat [ text "wanteds =" <+> ppr wanteds
, text "groups =" <+> ppr groups
, text "info =" <+> ppr (default_tys, extended_rules) ]
; something_happeneds <- mapM (disambigGroup wanteds default_tys) groups
; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
; return $ or something_happeneds || or plugin_defaulted }
where
run_defaulting_plugin :: WantedConstraints
-> FillDefaulting -> TcS (WantedConstraints, Bool)
run_defaulting_plugin WantedConstraints
wanteds FillDefaulting
p
= do { groups <- TcPluginM [DefaultingProposal] -> TcS [DefaultingProposal]
forall a. TcPluginM a -> TcS a
runTcPluginTcS (FillDefaulting
p WantedConstraints
wanteds)
; defaultedGroups <-
filterM (\DefaultingProposal
g -> WantedConstraints -> [Ct] -> ProposalSequence -> TcS Bool
disambigMultiGroup
WantedConstraints
wanteds
(DefaultingProposal -> [Ct]
deProposalCts DefaultingProposal
g)
([Proposal] -> ProposalSequence
ProposalSequence ([(TcTyVar, TcType)] -> Proposal
Proposal ([(TcTyVar, TcType)] -> Proposal)
-> [[(TcTyVar, TcType)]] -> [Proposal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefaultingProposal -> [[(TcTyVar, TcType)]]
deProposals DefaultingProposal
g)))
groups
; traceTcS "defaultingPlugin " $ ppr defaultedGroups
; case defaultedGroups of
[] -> (WantedConstraints, Bool) -> TcS (WantedConstraints, Bool)
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
wanteds, Bool
False)
[DefaultingProposal]
_ -> do
wanteds' <- WantedConstraints -> TcS WantedConstraints
TcS.zonkWC WantedConstraints
wanteds
return (wanteds', True) }
findDefaultableGroups
:: ( [ClassDefaults]
, Bool )
-> WantedConstraints
-> [(TyVar, [Ct])]
findDefaultableGroups :: ([ClassDefaults], Bool) -> WantedConstraints -> [(TcTyVar, [Ct])]
findDefaultableGroups ([ClassDefaults]
default_tys, Bool
extended_defaults) WantedConstraints
wanteds
| [ClassDefaults] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassDefaults]
default_tys
= []
| Bool
otherwise
= [ (TcTyVar
tv, ((Ct, Class, TcTyVar) -> Ct) -> [(Ct, Class, TcTyVar)] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map (Ct, Class, TcTyVar) -> Ct
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 = NonEmpty (Ct, Class, TcTyVar) -> [(Ct, Class, TcTyVar)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Ct, Class, TcTyVar)
group'
, TcTyVar -> Bool
defaultable_tyvar TcTyVar
tv
, [TyCon] -> Bool
defaultable_classes (((Ct, Class, TcTyVar) -> TyCon)
-> [(Ct, Class, TcTyVar)] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> TyCon
classTyCon (Class -> TyCon)
-> ((Ct, Class, TcTyVar) -> Class) -> (Ct, Class, TcTyVar) -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ct, Class, TcTyVar) -> Class
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) = (Ct -> Either (Ct, Class, TcTyVar) Ct)
-> [Ct] -> ([(Ct, Class, TcTyVar)], [Ct])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Ct -> Either (Ct, Class, TcTyVar) Ct
find_unary (Cts -> [Ct]
forall a. Bag a -> [a]
bagToList Cts
simples)
unary_groups :: [NonEmpty (Ct, Class, TcTyVar)]
unary_groups = ((Ct, Class, TcTyVar) -> (Ct, Class, TcTyVar) -> Ordering)
-> [(Ct, Class, TcTyVar)] -> [NonEmpty (Ct, Class, TcTyVar)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses (Ct, Class, TcTyVar) -> (Ct, Class, TcTyVar) -> Ordering
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,[TcType]
tys) <- TcType -> Maybe (Class, [TcType])
getClassPredTys_maybe (Ct -> TcType
ctPred Ct
cc)
, [TcType
ty] <- TyCon -> [TcType] -> [TcType]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [TcType]
tys
, Just TcTyVar
tv <- TcType -> Maybe TcTyVar
getTyVar_maybe TcType
ty
, TcTyVar -> Bool
isMetaTyVar TcTyVar
tv
= (Ct, Class, TcTyVar) -> Either (Ct, Class, TcTyVar) Ct
forall a b. a -> Either a b
Left (Ct
cc, Class
cls, TcTyVar
tv)
find_unary Ct
cc = Ct -> Either (Ct, Class, TcTyVar) Ct
forall a b. b -> Either a b
Right Ct
cc
bad_tvs :: TcTyCoVarSet
bad_tvs :: VarSet
bad_tvs = (Ct -> VarSet) -> [Ct] -> VarSet
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 a -> a -> Ordering
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 :: [TyCon] -> Bool
defaultable_classes :: [TyCon] -> Bool
defaultable_classes [TyCon]
clss = Bool -> Bool
not (Bool -> Bool) -> ([TyCon] -> Bool) -> [TyCon] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyCon] -> Bool) -> ([TyCon] -> [TyCon]) -> [TyCon] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyCon] -> [TyCon] -> [TyCon]
forall a. Eq a => [a] -> [a] -> [a]
intersect [TyCon]
clss ([TyCon] -> Bool) -> [TyCon] -> Bool
forall a b. (a -> b) -> a -> b
$ (ClassDefaults -> TyCon) -> [ClassDefaults] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map ClassDefaults -> TyCon
cd_class [ClassDefaults]
default_tys
newtype ProposalSequence = ProposalSequence{ProposalSequence -> [Proposal]
getProposalSequence :: [Proposal]}
newtype Proposal = Proposal [(TcTyVar, Type)]
instance Outputable ProposalSequence where
ppr :: ProposalSequence -> SDoc
ppr (ProposalSequence [Proposal]
proposals) = [Proposal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Proposal]
proposals
instance Outputable Proposal where
ppr :: Proposal -> SDoc
ppr (Proposal [(TcTyVar, TcType)]
assignments) = [(TcTyVar, TcType)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(TcTyVar, TcType)]
assignments
disambigGroup :: WantedConstraints
-> [ClassDefaults]
-> (TcTyVar, [Ct])
-> TcS Bool
disambigGroup :: WantedConstraints -> [ClassDefaults] -> (TcTyVar, [Ct]) -> TcS Bool
disambigGroup WantedConstraints
orig_wanteds [ClassDefaults]
default_ctys (TcTyVar
tv, [Ct]
wanteds)
= WantedConstraints
-> [Ct]
-> [ProposalSequence]
-> (NonEmpty ([TcTyVar], Subst) -> Bool)
-> TcS Bool
disambigProposalSequences WantedConstraints
orig_wanteds [Ct]
wanteds [ProposalSequence]
proposalSequences NonEmpty ([TcTyVar], Subst) -> Bool
allConsistent
where
proposalSequences :: [ProposalSequence]
proposalSequences = [ [Proposal] -> ProposalSequence
ProposalSequence [[(TcTyVar, TcType)] -> Proposal
Proposal [(TcTyVar
tv, TcType
ty)] | TcType
ty <- [TcType]
tys]
| ClassDefaults{cd_types :: ClassDefaults -> [TcType]
cd_types = [TcType]
tys} <- [ClassDefaults]
defaultses ]
allConsistent :: NonEmpty ([TcTyVar], Subst) -> Bool
allConsistent (([TcTyVar]
_, Subst
sub) :| [([TcTyVar], Subst)]
subs) = (([TcTyVar], Subst) -> Bool) -> [([TcTyVar], Subst)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TcTyVar -> Subst -> Subst -> Bool
eqSubAt TcTyVar
tv Subst
sub (Subst -> Bool)
-> (([TcTyVar], Subst) -> Subst) -> ([TcTyVar], Subst) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TcTyVar], Subst) -> Subst
forall a b. (a, b) -> b
snd) [([TcTyVar], Subst)]
subs
defaultses :: [ClassDefaults]
defaultses =
[ ClassDefaults
defaults | defaults :: ClassDefaults
defaults@ClassDefaults{cd_class :: ClassDefaults -> TyCon
cd_class = TyCon
cls} <- [ClassDefaults]
default_ctys
, (Ct -> Bool) -> [Ct] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCon -> Ct -> Bool
isDictForClass TyCon
cls) [Ct]
wanteds ]
isDictForClass :: TyCon -> Ct -> Bool
isDictForClass TyCon
clcon Ct
ct = ((Class, [TcType]) -> Bool) -> Maybe (Class, [TcType]) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TyCon
clcon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
==) (TyCon -> Bool)
-> ((Class, [TcType]) -> TyCon) -> (Class, [TcType]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> TyCon
classTyCon (Class -> TyCon)
-> ((Class, [TcType]) -> Class) -> (Class, [TcType]) -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Class, [TcType]) -> Class
forall a b. (a, b) -> a
fst) (TcType -> Maybe (Class, [TcType])
getClassPredTys_maybe (TcType -> Maybe (Class, [TcType]))
-> TcType -> Maybe (Class, [TcType])
forall a b. (a -> b) -> a -> b
$ Ct -> TcType
ctPred Ct
ct)
eqSubAt :: TcTyVar -> Subst -> Subst -> Bool
eqSubAt :: TcTyVar -> Subst -> Subst -> Bool
eqSubAt TcTyVar
tvar Subst
s1 Subst
s2 = Maybe Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TcType -> TcType -> Bool)
-> Maybe TcType -> Maybe TcType -> Maybe Bool
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
tcEqType (Subst -> TcTyVar -> Maybe TcType
lookupTyVar Subst
s1 TcTyVar
tvar) (Subst -> TcTyVar -> Maybe TcType
lookupTyVar Subst
s2 TcTyVar
tvar)
disambigMultiGroup :: WantedConstraints
-> [Ct]
-> ProposalSequence
-> TcS Bool
disambigMultiGroup :: WantedConstraints -> [Ct] -> ProposalSequence -> TcS Bool
disambigMultiGroup WantedConstraints
orig_wanteds [Ct]
wanteds ProposalSequence
proposalSequence
= WantedConstraints
-> [Ct]
-> [ProposalSequence]
-> (NonEmpty ([TcTyVar], Subst) -> Bool)
-> TcS Bool
disambigProposalSequences WantedConstraints
orig_wanteds [Ct]
wanteds [ProposalSequence
proposalSequence] (Bool -> NonEmpty ([TcTyVar], Subst) -> Bool
forall a b. a -> b -> a
const Bool
True)
disambigProposalSequences :: WantedConstraints
-> [Ct]
-> [ProposalSequence]
-> (NonEmpty ([TcTyVar], Subst) -> Bool)
-> TcS Bool
disambigProposalSequences :: WantedConstraints
-> [Ct]
-> [ProposalSequence]
-> (NonEmpty ([TcTyVar], Subst) -> Bool)
-> TcS Bool
disambigProposalSequences WantedConstraints
orig_wanteds [Ct]
wanteds [ProposalSequence]
proposalSequences NonEmpty ([TcTyVar], Subst) -> Bool
allConsistent
= do { (ProposalSequence -> TcS ()) -> [ProposalSequence] -> TcS ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Proposal -> TcS ()) -> [Proposal] -> TcS ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Proposal -> TcS ()
reportInvalidDefaultedTyVars ([Proposal] -> TcS ())
-> (ProposalSequence -> [Proposal]) -> ProposalSequence -> TcS ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProposalSequence -> [Proposal]
getProposalSequence) [ProposalSequence]
proposalSequences
; fake_ev_binds_var <- TcS EvBindsVar
TcS.newTcEvBinds
; tclvl <- TcS.getTcLevel
; successes <- fmap catMaybes $
nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $
mapM firstSuccess proposalSequences
; traceTcS "disambigProposalSequences" (vcat [ ppr wanteds
, ppr proposalSequences
, ppr successes ])
; case successes of
success :: ([TcTyVar], Subst)
success@([TcTyVar]
tvs, Subst
subst) : [([TcTyVar], Subst)]
rest
| NonEmpty ([TcTyVar], Subst) -> Bool
allConsistent (([TcTyVar], Subst)
success ([TcTyVar], Subst)
-> [([TcTyVar], Subst)] -> NonEmpty ([TcTyVar], Subst)
forall a. a -> [a] -> NonEmpty a
:| [([TcTyVar], Subst)]
rest)
-> do { [TcTyVar] -> Subst -> TcS ()
applyDefaultSubst [TcTyVar]
tvs Subst
subst
; let warn :: TcTyVar -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn TcTyVar
tv = (TcType -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Ct] -> TcTyVar -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnDefaulting [Ct]
wanteds TcTyVar
tv) (Subst -> TcTyVar -> Maybe TcType
lookupTyVar Subst
subst TcTyVar
tv)
; IOEnv (Env TcGblEnv TcLclEnv) () -> TcS ()
forall a. TcM a -> TcS a
wrapWarnTcS (IOEnv (Env TcGblEnv TcLclEnv) () -> TcS ())
-> IOEnv (Env TcGblEnv TcLclEnv) () -> TcS ()
forall a b. (a -> b) -> a -> b
$ (TcTyVar -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [TcTyVar] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TcTyVar -> IOEnv (Env TcGblEnv TcLclEnv) ()
warn [TcTyVar]
tvs
; String -> SDoc -> TcS ()
traceTcS String
"disambigProposalSequences succeeded }" ([ProposalSequence] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ProposalSequence]
proposalSequences)
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
[([TcTyVar], Subst)]
_ ->
do { String -> SDoc -> TcS ()
traceTcS String
"disambigProposalSequences failed }" ([ProposalSequence] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ProposalSequence]
proposalSequences)
; Bool -> TcS Bool
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False } }
where
reportInvalidDefaultedTyVars :: Proposal -> TcS ()
firstSuccess :: ProposalSequence -> TcS (Maybe ([TcTyVar], Subst))
firstSuccess :: ProposalSequence -> TcS (Maybe ([TcTyVar], Subst))
firstSuccess (ProposalSequence [Proposal]
proposals)
= First ([TcTyVar], Subst) -> Maybe ([TcTyVar], Subst)
forall a. First a -> Maybe a
getFirst (First ([TcTyVar], Subst) -> Maybe ([TcTyVar], Subst))
-> TcS (First ([TcTyVar], Subst)) -> TcS (Maybe ([TcTyVar], Subst))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proposal -> TcS (First ([TcTyVar], Subst)))
-> [Proposal] -> TcS (First ([TcTyVar], Subst))
forall (m :: * -> *) (t :: * -> *) b a.
(Applicative m, Foldable t, Monoid b) =>
(a -> m b) -> t a -> m b
foldMapM ((Maybe ([TcTyVar], Subst) -> First ([TcTyVar], Subst))
-> TcS (Maybe ([TcTyVar], Subst)) -> TcS (First ([TcTyVar], Subst))
forall a b. (a -> b) -> TcS a -> TcS b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ([TcTyVar], Subst) -> First ([TcTyVar], Subst)
forall a. Maybe a -> First a
First (TcS (Maybe ([TcTyVar], Subst)) -> TcS (First ([TcTyVar], Subst)))
-> (Proposal -> TcS (Maybe ([TcTyVar], Subst)))
-> Proposal
-> TcS (First ([TcTyVar], Subst))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ct] -> Proposal -> TcS (Maybe ([TcTyVar], Subst))
tryDefaultGroup [Ct]
wanteds) [Proposal]
proposals
reportInvalidDefaultedTyVars :: Proposal -> TcS ()
reportInvalidDefaultedTyVars proposal :: Proposal
proposal@(Proposal [(TcTyVar, TcType)]
assignments)
= do { let tvs :: [TcTyVar]
tvs = (TcTyVar, TcType) -> TcTyVar
forall a b. (a, b) -> a
fst ((TcTyVar, TcType) -> TcTyVar) -> [(TcTyVar, TcType)] -> [TcTyVar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TcTyVar, TcType)]
assignments
; invalid_tvs <- (TcTyVar -> TcS Bool) -> [TcTyVar] -> TcS [TcTyVar]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterOutM TcTyVar -> TcS Bool
TcS.isUnfilledMetaTyVar [TcTyVar]
tvs
; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty invalid_tvs) }
applyDefaultSubst :: [TcTyVar] -> Subst -> TcS ()
applyDefaultSubst :: [TcTyVar] -> Subst -> TcS ()
applyDefaultSubst [TcTyVar]
tvs Subst
subst =
do { deep_tvs <- (TcTyVar -> TcS Bool) -> [TcTyVar] -> TcS [TcTyVar]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM TcTyVar -> TcS Bool
TcS.isUnfilledMetaTyVar ([TcTyVar] -> TcS [TcTyVar]) -> [TcTyVar] -> TcS [TcTyVar]
forall a b. (a -> b) -> a -> b
$ VarSet -> [TcTyVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (VarSet -> [TcTyVar]) -> VarSet -> [TcTyVar]
forall a b. (a -> b) -> a -> b
$ VarSet -> VarSet
closeOverKinds ([TcTyVar] -> VarSet
mkVarSet [TcTyVar]
tvs)
; forM_ deep_tvs $ \ TcTyVar
tv -> (TcType -> TcS ()) -> Maybe TcType -> TcS ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcTyVar -> TcType -> TcS ()
unifyTyVar TcTyVar
tv) (VarEnv TcType -> TcTyVar -> Maybe TcType
forall a. VarEnv a -> TcTyVar -> Maybe a
lookupVarEnv (Subst -> VarEnv TcType
getTvSubstEnv Subst
subst) TcTyVar
tv)
}
tryDefaultGroup :: [Ct]
-> Proposal
-> TcS (Maybe ([TcTyVar], Subst))
tryDefaultGroup :: [Ct] -> Proposal -> TcS (Maybe ([TcTyVar], Subst))
tryDefaultGroup [Ct]
wanteds (Proposal [(TcTyVar, TcType)]
assignments)
| let ([TcTyVar]
tvs, [TcType]
default_tys) = [(TcTyVar, TcType)] -> ([TcTyVar], [TcType])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TcTyVar, TcType)]
assignments
, Just Subst
subst <- [TcType] -> [TcType] -> Maybe Subst
tcMatchTyKis ([TcTyVar] -> [TcType]
mkTyVarTys [TcTyVar]
tvs) [TcType]
default_tys
= do { lcl_env <- TcS TcLclEnv
TcS.getLclEnv
; tc_lvl <- TcS.getTcLevel
; let loc = TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc
mkGivenLoc TcLevel
tc_lvl (SkolemInfo -> SkolemInfoAnon
getSkolemInfo SkolemInfo
HasDebugCallStack => SkolemInfo
unkSkol) (TcLclEnv -> CtLocEnv
mkCtLocEnv TcLclEnv
lcl_env)
; wanted_evs <- sequence [ newWantedNC loc rewriters pred'
| wanted <- wanteds
, CtWanted { ctev_pred = pred
, ctev_rewriters = rewriters }
<- return (ctEvidence wanted)
, let pred' = HasDebugCallStack => Subst -> TcType -> TcType
Subst -> TcType -> TcType
substTy Subst
subst TcType
pred ]
; residual_wc <- solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs
; return $ if isEmptyWC residual_wc then Just (tvs, subst) else Nothing }
| Bool
otherwise
= Maybe ([TcTyVar], Subst) -> TcS (Maybe ([TcTyVar], Subst))
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([TcTyVar], Subst)
forall a. Maybe a
Nothing
errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS ()
errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS ()
errInvalidDefaultedTyVar WantedConstraints
wanteds (Proposal [(TcTyVar, TcType)]
assignments) NonEmpty TcTyVar
problematic_tvs
= TcRnMessage -> TcS ()
forall a. TcRnMessage -> TcS a
failTcS (TcRnMessage -> TcS ()) -> TcRnMessage -> TcS ()
forall a b. (a -> b) -> a -> b
$ [Ct] -> [(TcTyVar, TcType)] -> NonEmpty TcTyVar -> TcRnMessage
TcRnInvalidDefaultedTyVar [Ct]
tidy_wanteds [(TcTyVar, TcType)]
tidy_assignments NonEmpty TcTyVar
tidy_problems
where
proposal_tvs :: [TcTyVar]
proposal_tvs = ((TcTyVar, TcType) -> [TcTyVar])
-> [(TcTyVar, TcType)] -> [TcTyVar]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(TcTyVar
tv, TcType
ty) -> TcTyVar
tv TcTyVar -> [TcTyVar] -> [TcTyVar]
forall a. a -> [a] -> [a]
: TcType -> [TcTyVar]
tyCoVarsOfTypeList TcType
ty) [(TcTyVar, TcType)]
assignments
tidy_env :: TidyEnv
tidy_env = TidyEnv -> [TcTyVar] -> TidyEnv
tidyFreeTyCoVars TidyEnv
emptyTidyEnv ([TcTyVar] -> TidyEnv) -> [TcTyVar] -> TidyEnv
forall a b. (a -> b) -> a -> b
$ [TcTyVar]
proposal_tvs [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ NonEmpty TcTyVar -> [TcTyVar]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TcTyVar
problematic_tvs
tidy_wanteds :: [Ct]
tidy_wanteds = (Ct -> Ct) -> [Ct] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Ct -> Ct
tidyCt TidyEnv
tidy_env) ([Ct] -> [Ct]) -> [Ct] -> [Ct]
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> [Ct]
flattenWC WantedConstraints
wanteds
tidy_assignments :: [(TcTyVar, TcType)]
tidy_assignments = [(TidyEnv -> TcTyVar -> TcTyVar
tidyTyCoVarOcc TidyEnv
tidy_env TcTyVar
tv, TidyEnv -> TcType -> TcType
tidyType TidyEnv
tidy_env TcType
ty) | (TcTyVar
tv, TcType
ty) <- [(TcTyVar, TcType)]
assignments]
tidy_problems :: NonEmpty TcTyVar
tidy_problems = (TcTyVar -> TcTyVar) -> NonEmpty TcTyVar -> NonEmpty TcTyVar
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TidyEnv -> TcTyVar -> TcTyVar
tidyTyCoVarOcc TidyEnv
tidy_env) NonEmpty TcTyVar
problematic_tvs
flattenWC :: WantedConstraints -> [Ct]
flattenWC :: WantedConstraints -> [Ct]
flattenWC (WC { wc_simple :: WantedConstraints -> Cts
wc_simple = Cts
cts, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
impls })
= Cts -> [Ct]
ctsElts Cts
cts [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ (Implication -> [Ct]) -> Bag Implication -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (WantedConstraints -> [Ct]
flattenWC (WantedConstraints -> [Ct])
-> (Implication -> WantedConstraints) -> Implication -> [Ct]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Implication -> WantedConstraints
ic_wanted) Bag Implication
impls
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 Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
isStringClassKey))