{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Deriv.Infer
( inferConstraints
, simplifyInstanceContexts
)
where
import GHC.Prelude
import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Pair
import GHC.Builtin.Names
import GHC.Tc.Deriv.Utils
import GHC.Tc.Utils.Env
import GHC.Tc.Deriv.Generate
import GHC.Tc.Deriv.Functor
import GHC.Tc.Deriv.Generics
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Utils.TcType
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr (pprTyVars)
import GHC.Core.Type
import GHC.Tc.Solver
import GHC.Tc.Solver.Monad ( runTcS )
import GHC.Tc.Validity (validDerivPred)
import GHC.Tc.Utils.Unify (buildImplicationFor)
import GHC.Builtin.Types (typeToTypeKind)
import GHC.Core.Unify (tcUnifyTy)
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Types.Var.Set
import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ask)
import Data.List (sortBy)
import Data.Maybe
inferConstraints :: DerivSpecMechanism
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
inferConstraints :: DerivSpecMechanism
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
inferConstraints DerivSpecMechanism
mechanism
= do { DerivEnv { denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_cls :: DerivEnv -> Class
denv_cls = Class
main_cls
, denv_inst_tys :: DerivEnv -> [TcType]
denv_inst_tys = [TcType]
inst_tys } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
; Bool
wildcard <- DerivM Bool
isStandaloneWildcardDeriv
; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints =
case DerivSpecMechanism
mechanism of
DerivSpecStock{dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit}
-> do (ThetaSpec
thetas, [TyVar]
tvs, [TcType]
inst_tys, DerivInstTys
dit') <- DerivInstTys -> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
inferConstraintsStock DerivInstTys
dit
(ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( ThetaSpec
thetas, [TyVar]
tvs, [TcType]
inst_tys
, DerivSpecMechanism
mechanism{dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit'} )
DerivSpecMechanism
DerivSpecAnyClass
-> DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints_simple DerivM ThetaSpec
inferConstraintsAnyclass
DerivSpecNewtype { dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit =
DerivInstTys{dit_cls_tys :: DerivInstTys -> [TcType]
dit_cls_tys = [TcType]
cls_tys}
, dsm_newtype_rep_ty :: DerivSpecMechanism -> TcType
dsm_newtype_rep_ty = TcType
rep_ty }
-> DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints_simple (DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism))
-> DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
forall a b. (a -> b) -> a -> b
$
[TcType] -> TcType -> DerivM ThetaSpec
inferConstraintsCoerceBased [TcType]
cls_tys TcType
rep_ty
DerivSpecVia { dsm_via_cls_tys :: DerivSpecMechanism -> [TcType]
dsm_via_cls_tys = [TcType]
cls_tys
, dsm_via_ty :: DerivSpecMechanism -> TcType
dsm_via_ty = TcType
via_ty }
-> DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints_simple (DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism))
-> DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
forall a b. (a -> b) -> a -> b
$
[TcType] -> TcType -> DerivM ThetaSpec
inferConstraintsCoerceBased [TcType]
cls_tys TcType
via_ty
infer_constraints_simple
:: DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints_simple :: DerivM ThetaSpec
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints_simple DerivM ThetaSpec
infer_thetas = do
ThetaSpec
thetas <- DerivM ThetaSpec
infer_thetas
(ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThetaSpec
thetas, [TyVar]
tvs, [TcType]
inst_tys, DerivSpecMechanism
mechanism)
cls_tvs :: [TyVar]
cls_tvs = Class -> [TyVar]
classTyVars Class
main_cls
sc_constraints :: ThetaSpec
sc_constraints = Bool -> SDoc -> ThetaSpec -> ThetaSpec
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([TyVar] -> [TcType] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [TyVar]
cls_tvs [TcType]
inst_tys)
(Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
main_cls SDoc -> SDoc -> SDoc
<+> [TcType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcType]
inst_tys) (ThetaSpec -> ThetaSpec) -> ThetaSpec -> ThetaSpec
forall a b. (a -> b) -> a -> b
$
CtOrigin -> TypeOrKind -> [TcType] -> ThetaSpec
mkDirectThetaSpec
(Bool -> CtOrigin
mkDerivOrigin Bool
wildcard) TypeOrKind
TypeLevel
(HasDebugCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTheta TCvSubst
cls_subst (Class -> [TcType]
classSCTheta Class
main_cls))
cls_subst :: TCvSubst
cls_subst = Bool -> TCvSubst -> TCvSubst
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> [TcType] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [TyVar]
cls_tvs [TcType]
inst_tys) (TCvSubst -> TCvSubst) -> TCvSubst -> TCvSubst
forall a b. (a -> b) -> a -> b
$
[TyVar] -> [TcType] -> TCvSubst
HasDebugCallStack => [TyVar] -> [TcType] -> TCvSubst
zipTvSubst [TyVar]
cls_tvs [TcType]
inst_tys
; (ThetaSpec
inferred_constraints, [TyVar]
tvs', [TcType]
inst_tys', DerivSpecMechanism
mechanism')
<- DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
infer_constraints
; IOEnv (Env TcGblEnv TcLclEnv) () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) () -> ReaderT DerivEnv TcRn ())
-> IOEnv (Env TcGblEnv TcLclEnv) () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"inferConstraints" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
main_cls SDoc -> SDoc -> SDoc
<+> [TcType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcType]
inst_tys'
, ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaSpec
inferred_constraints
]
; (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ThetaSpec
sc_constraints ThetaSpec -> ThetaSpec -> ThetaSpec
forall a. [a] -> [a] -> [a]
++ ThetaSpec
inferred_constraints
, [TyVar]
tvs', [TcType]
inst_tys', DerivSpecMechanism
mechanism' ) }
inferConstraintsStock :: DerivInstTys
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
inferConstraintsStock :: DerivInstTys -> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
inferConstraintsStock dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [TcType]
dit_cls_tys = [TcType]
cls_tys
, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_tc_args :: DerivInstTys -> [TcType]
dit_tc_args = [TcType]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc
, dit_rep_tc_args :: DerivInstTys -> [TcType]
dit_rep_tc_args = [TcType]
rep_tc_args })
= do DerivEnv { denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_cls :: DerivEnv -> Class
denv_cls = Class
main_cls
, denv_inst_tys :: DerivEnv -> [TcType]
denv_inst_tys = [TcType]
inst_tys } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Bool
wildcard <- DerivM Bool
isStandaloneWildcardDeriv
let inst_ty :: TcType
inst_ty = TyCon -> [TcType] -> TcType
mkTyConApp TyCon
tc [TcType]
tc_args
tc_binders :: [TyConBinder]
tc_binders = TyCon -> [TyConBinder]
tyConBinders TyCon
rep_tc
choose_level :: TyConBinder -> TypeOrKind
choose_level TyConBinder
bndr
| TyConBinder -> Bool
isNamedTyConBinder TyConBinder
bndr = TypeOrKind
KindLevel
| Bool
otherwise = TypeOrKind
TypeLevel
t_or_ks :: [TypeOrKind]
t_or_ks = (TyConBinder -> TypeOrKind) -> [TyConBinder] -> [TypeOrKind]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> TypeOrKind
choose_level [TyConBinder]
tc_binders [TypeOrKind] -> [TypeOrKind] -> [TypeOrKind]
forall a. [a] -> [a] -> [a]
++ TypeOrKind -> [TypeOrKind]
forall a. a -> [a]
repeat TypeOrKind
TypeLevel
con_arg_constraints
:: (CtOrigin -> TypeOrKind
-> Type
-> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
con_arg_constraints :: (CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
con_arg_constraints CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)]
get_arg_constraints
= let
([ThetaSpec]
predss, [Maybe TCvSubst]
mbSubsts) = [(ThetaSpec, Maybe TCvSubst)] -> ([ThetaSpec], [Maybe TCvSubst])
forall a b. [(a, b)] -> ([a], [b])
unzip
[ (ThetaSpec, Maybe TCvSubst)
preds_and_mbSubst
| DataCon
data_con <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
, (Int
arg_n, TypeOrKind
arg_t_or_k, TcType
arg_ty)
<- [Int] -> [TypeOrKind] -> [TcType] -> [(Int, TypeOrKind, TcType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1..] [TypeOrKind]
t_or_ks ([TcType] -> [(Int, TypeOrKind, TcType)])
-> [TcType] -> [(Int, TypeOrKind, TcType)]
forall a b. (a -> b) -> a -> b
$
DataCon -> DerivInstTys -> [TcType]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit
, Bool -> Bool
not (HasDebugCallStack => TcType -> Bool
TcType -> Bool
isUnliftedType TcType
arg_ty)
, let orig :: CtOrigin
orig = DataCon -> Int -> Bool -> CtOrigin
DerivOriginDC DataCon
data_con Int
arg_n Bool
wildcard
, (ThetaSpec, Maybe TCvSubst)
preds_and_mbSubst
<- CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)]
get_arg_constraints CtOrigin
orig TypeOrKind
arg_t_or_k TcType
arg_ty
]
stupid_theta :: [TcType]
stupid_theta =
[ [TyVar] -> [TcType] -> TcType -> TcType
HasDebugCallStack => [TyVar] -> [TcType] -> TcType -> TcType
substTyWith (DataCon -> [TyVar]
dataConUnivTyVars DataCon
data_con)
(DataCon -> [TcType] -> [TcType]
dataConInstUnivs DataCon
data_con [TcType]
rep_tc_args)
TcType
stupid_pred
| DataCon
data_con <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
, TcType
stupid_pred <- DataCon -> [TcType]
dataConStupidTheta DataCon
data_con
]
preds :: ThetaSpec
preds = [ThetaSpec] -> ThetaSpec
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ThetaSpec]
predss
subst :: TCvSubst
subst = (TCvSubst -> TCvSubst -> TCvSubst)
-> TCvSubst -> [TCvSubst] -> TCvSubst
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TCvSubst -> TCvSubst -> TCvSubst
composeTCvSubst
TCvSubst
emptyTCvSubst ([Maybe TCvSubst] -> [TCvSubst]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TCvSubst]
mbSubsts)
unmapped_tvs :: [TyVar]
unmapped_tvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> TCvSubst -> Bool
`notElemTCvSubst` TCvSubst
subst
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> TCvSubst -> Bool
`isInScope` TCvSubst
subst)) [TyVar]
tvs
(TCvSubst
subst', [TyVar]
_) = HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
subst [TyVar]
unmapped_tvs
stupid_theta_origin :: ThetaSpec
stupid_theta_origin = CtOrigin -> TypeOrKind -> [TcType] -> ThetaSpec
mkDirectThetaSpec
CtOrigin
deriv_origin TypeOrKind
TypeLevel
(HasDebugCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTheta TCvSubst
subst' [TcType]
stupid_theta)
preds' :: ThetaSpec
preds' = (PredSpec -> PredSpec) -> ThetaSpec -> ThetaSpec
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> PredSpec -> PredSpec
TCvSubst -> PredSpec -> PredSpec
substPredSpec TCvSubst
subst') ThetaSpec
preds
inst_tys' :: [TcType]
inst_tys' = HasDebugCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTys TCvSubst
subst' [TcType]
inst_tys
dit' :: DerivInstTys
dit' = TCvSubst -> DerivInstTys -> DerivInstTys
substDerivInstTys TCvSubst
subst' DerivInstTys
dit
tvs' :: [TyVar]
tvs' = [TcType] -> [TyVar]
tyCoVarsOfTypesWellScoped [TcType]
inst_tys'
in ( ThetaSpec
stupid_theta_origin ThetaSpec -> ThetaSpec -> ThetaSpec
forall a. [a] -> [a] -> [a]
++ ThetaSpec
preds'
, [TyVar]
tvs', [TcType]
inst_tys', DerivInstTys
dit' )
is_generic :: Bool
is_generic = Class
main_cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
genClassKey
is_generic1 :: Bool
is_generic1 = Class
main_cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
gen1ClassKey
is_functor_like :: Bool
is_functor_like = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
inst_ty HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqKind` TcType
typeToTypeKind
Bool -> Bool -> Bool
|| Bool
is_generic1
get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
-> [(ThetaSpec, Maybe TCvSubst)]
get_gen1_constraints :: Class
-> CtOrigin
-> TypeOrKind
-> TcType
-> [(ThetaSpec, Maybe TCvSubst)]
get_gen1_constraints Class
functor_cls CtOrigin
orig TypeOrKind
t_or_k TcType
ty
= CtOrigin
-> TypeOrKind -> Class -> [TcType] -> [(ThetaSpec, Maybe TCvSubst)]
mk_functor_like_constraints CtOrigin
orig TypeOrKind
t_or_k Class
functor_cls ([TcType] -> [(ThetaSpec, Maybe TCvSubst)])
-> [TcType] -> [(ThetaSpec, Maybe TCvSubst)]
forall a b. (a -> b) -> a -> b
$
TyVar -> TcType -> [TcType]
get_gen1_constrained_tys TyVar
last_tv TcType
ty
get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
-> [(ThetaSpec, Maybe TCvSubst)]
get_std_constrained_tys :: CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)]
get_std_constrained_tys CtOrigin
orig TypeOrKind
t_or_k TcType
ty
| Bool
is_functor_like
= CtOrigin
-> TypeOrKind -> Class -> [TcType] -> [(ThetaSpec, Maybe TCvSubst)]
mk_functor_like_constraints CtOrigin
orig TypeOrKind
t_or_k Class
main_cls ([TcType] -> [(ThetaSpec, Maybe TCvSubst)])
-> [TcType] -> [(ThetaSpec, Maybe TCvSubst)]
forall a b. (a -> b) -> a -> b
$
TyVar -> TcType -> [TcType]
deepSubtypesContaining TyVar
last_tv TcType
ty
| Bool
otherwise
= [( [CtOrigin -> TypeOrKind -> Class -> TcType -> PredSpec
mk_cls_pred CtOrigin
orig TypeOrKind
t_or_k Class
main_cls TcType
ty]
, Maybe TCvSubst
forall a. Maybe a
Nothing )]
mk_functor_like_constraints :: CtOrigin -> TypeOrKind
-> Class -> [Type]
-> [(ThetaSpec, Maybe TCvSubst)]
mk_functor_like_constraints :: CtOrigin
-> TypeOrKind -> Class -> [TcType] -> [(ThetaSpec, Maybe TCvSubst)]
mk_functor_like_constraints CtOrigin
orig TypeOrKind
t_or_k Class
cls
= (TcType -> (ThetaSpec, Maybe TCvSubst))
-> [TcType] -> [(ThetaSpec, Maybe TCvSubst)]
forall a b. (a -> b) -> [a] -> [b]
map ((TcType -> (ThetaSpec, Maybe TCvSubst))
-> [TcType] -> [(ThetaSpec, Maybe TCvSubst)])
-> (TcType -> (ThetaSpec, Maybe TCvSubst))
-> [TcType]
-> [(ThetaSpec, Maybe TCvSubst)]
forall a b. (a -> b) -> a -> b
$ \TcType
ty -> let ki :: TcType
ki = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty in
( [ CtOrigin -> TypeOrKind -> Class -> TcType -> PredSpec
mk_cls_pred CtOrigin
orig TypeOrKind
t_or_k Class
cls TcType
ty
, SimplePredSpec :: TcType -> CtOrigin -> TypeOrKind -> PredSpec
SimplePredSpec
{ sps_pred :: TcType
sps_pred = TcType -> TcType -> TcType
mkPrimEqPred TcType
ki TcType
typeToTypeKind
, sps_origin :: CtOrigin
sps_origin = CtOrigin
orig
, sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
KindLevel
}
]
, TcType -> TcType -> Maybe TCvSubst
tcUnifyTy TcType
ki TcType
typeToTypeKind
)
rep_tc_tvs :: [TyVar]
rep_tc_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
last_tv :: TyVar
last_tv = [TyVar] -> TyVar
forall a. [a] -> a
last [TyVar]
rep_tc_tvs
extra_constraints :: ThetaSpec
extra_constraints
| Class
main_cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dataClassKey
, (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TcType -> Bool
isLiftedTypeKind (TcType -> Bool) -> (TcType -> TcType) -> TcType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind) [TcType]
rep_tc_args
= [ CtOrigin -> TypeOrKind -> Class -> TcType -> PredSpec
mk_cls_pred CtOrigin
deriv_origin TypeOrKind
t_or_k Class
main_cls TcType
ty
| (TypeOrKind
t_or_k, TcType
ty) <- [TypeOrKind] -> [TcType] -> [(TypeOrKind, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TypeOrKind]
t_or_ks [TcType]
rep_tc_args]
| Bool
otherwise
= []
mk_cls_pred :: CtOrigin -> TypeOrKind -> Class -> TcType -> PredSpec
mk_cls_pred CtOrigin
orig TypeOrKind
t_or_k Class
cls TcType
ty
= SimplePredSpec :: TcType -> CtOrigin -> TypeOrKind -> PredSpec
SimplePredSpec
{ sps_pred :: TcType
sps_pred = Class -> [TcType] -> TcType
mkClassPred Class
cls ([TcType]
cls_tys' [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType
ty])
, sps_origin :: CtOrigin
sps_origin = CtOrigin
orig
, sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
}
cls_tys' :: [TcType]
cls_tys' | Bool
is_generic1 = []
| Bool
otherwise = [TcType]
cls_tys
deriv_origin :: CtOrigin
deriv_origin = Bool -> CtOrigin
mkDerivOrigin Bool
wildcard
if
| Bool
is_generic
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TyVar]
tvs, [TcType]
inst_tys, DerivInstTys
dit)
| Bool
is_generic1
-> Bool
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar]
rep_tc_tvs [TyVar] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
0) (DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys))
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall a b. (a -> b) -> a -> b
$
Bool
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall a. HasCallStack => Bool -> a -> a
assert ([TcType]
cls_tys [TcType] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1) (DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys))
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall a b. (a -> b) -> a -> b
$
do { Class
functorClass <- IOEnv (Env TcGblEnv TcLclEnv) Class -> ReaderT DerivEnv TcRn Class
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) Class
-> ReaderT DerivEnv TcRn Class)
-> IOEnv (Env TcGblEnv TcLclEnv) Class
-> ReaderT DerivEnv TcRn Class
forall a b. (a -> b) -> a -> b
$ Name -> IOEnv (Env TcGblEnv TcLclEnv) Class
tcLookupClass Name
functorClassName
; (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys))
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall a b. (a -> b) -> a -> b
$ (CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
con_arg_constraints
((CtOrigin
-> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys))
-> (CtOrigin
-> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall a b. (a -> b) -> a -> b
$ Class
-> CtOrigin
-> TypeOrKind
-> TcType
-> [(ThetaSpec, Maybe TCvSubst)]
get_gen1_constraints Class
functorClass }
| Bool
otherwise
-> do { let (ThetaSpec
arg_constraints, [TyVar]
tvs', [TcType]
inst_tys', DerivInstTys
dit')
= (CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)])
-> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
con_arg_constraints CtOrigin -> TypeOrKind -> TcType -> [(ThetaSpec, Maybe TCvSubst)]
get_std_constrained_tys
; IOEnv (Env TcGblEnv TcLclEnv) () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) () -> ReaderT DerivEnv TcRn ())
-> IOEnv (Env TcGblEnv TcLclEnv) () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"inferConstraintsStock" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
main_cls SDoc -> SDoc -> SDoc
<+> [TcType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcType]
inst_tys'
, ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaSpec
arg_constraints
]
; (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ThetaSpec
extra_constraints ThetaSpec -> ThetaSpec -> ThetaSpec
forall a. [a] -> [a] -> [a]
++ ThetaSpec
arg_constraints
, [TyVar]
tvs', [TcType]
inst_tys', DerivInstTys
dit' ) }
inferConstraintsAnyclass :: DerivM ThetaSpec
inferConstraintsAnyclass :: DerivM ThetaSpec
inferConstraintsAnyclass
= do { DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [TcType]
denv_inst_tys = [TcType]
inst_tys } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
; let gen_dms :: [(TyVar, TcType)]
gen_dms = [ (TyVar
sel_id, TcType
dm_ty)
| (TyVar
sel_id, Just (Name
_, GenericDM TcType
dm_ty)) <- Class -> [(TyVar, DefMethInfo)]
classOpItems Class
cls ]
; Bool
wildcard <- DerivM Bool
isStandaloneWildcardDeriv
; let meth_pred :: (Id, Type) -> PredSpec
meth_pred :: (TyVar, TcType) -> PredSpec
meth_pred (TyVar
sel_id, TcType
gen_dm_ty)
= let ([TyVar]
sel_tvs, TcType
_cls_pred, TcType
meth_ty) = TcType -> ([TyVar], TcType, TcType)
tcSplitMethodTy (TyVar -> TcType
varType TyVar
sel_id)
meth_ty' :: TcType
meth_ty' = [TyVar] -> [TcType] -> TcType -> TcType
HasDebugCallStack => [TyVar] -> [TcType] -> TcType -> TcType
substTyWith [TyVar]
sel_tvs [TcType]
inst_tys TcType
meth_ty
gen_dm_ty' :: TcType
gen_dm_ty' = [TyVar] -> [TcType] -> TcType -> TcType
HasDebugCallStack => [TyVar] -> [TcType] -> TcType -> TcType
substTyWith [TyVar]
sel_tvs [TcType]
inst_tys TcType
gen_dm_ty in
SubTypePredSpec :: TcType -> TcType -> CtOrigin -> PredSpec
SubTypePredSpec { stps_ty_actual :: TcType
stps_ty_actual = TcType
gen_dm_ty'
, stps_ty_expected :: TcType
stps_ty_expected = TcType
meth_ty'
, stps_origin :: CtOrigin
stps_origin = Bool -> CtOrigin
mkDerivOrigin Bool
wildcard
}
; ThetaSpec -> DerivM ThetaSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThetaSpec -> DerivM ThetaSpec) -> ThetaSpec -> DerivM ThetaSpec
forall a b. (a -> b) -> a -> b
$ ((TyVar, TcType) -> PredSpec) -> [(TyVar, TcType)] -> ThetaSpec
forall a b. (a -> b) -> [a] -> [b]
map (TyVar, TcType) -> PredSpec
meth_pred [(TyVar, TcType)]
gen_dms }
inferConstraintsCoerceBased :: [Type] -> Type
-> DerivM ThetaSpec
inferConstraintsCoerceBased :: [TcType] -> TcType -> DerivM ThetaSpec
inferConstraintsCoerceBased [TcType]
cls_tys TcType
rep_ty = do
DerivEnv { denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [TcType]
denv_inst_tys = [TcType]
inst_tys } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Bool
sa_wildcard <- DerivM Bool
isStandaloneWildcardDeriv
let
rep_tys :: TcType -> [TcType]
rep_tys TcType
ty = [TcType]
cls_tys [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType
ty]
rep_pred :: TcType -> TcType
rep_pred TcType
ty = Class -> [TcType] -> TcType
mkClassPred Class
cls (TcType -> [TcType]
rep_tys TcType
ty)
rep_pred_o :: TcType -> PredSpec
rep_pred_o TcType
ty = SimplePredSpec :: TcType -> CtOrigin -> TypeOrKind -> PredSpec
SimplePredSpec { sps_pred :: TcType
sps_pred = TcType -> TcType
rep_pred TcType
ty
, sps_origin :: CtOrigin
sps_origin = CtOrigin
deriv_origin
, sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
TypeLevel
}
deriv_origin :: CtOrigin
deriv_origin = Bool -> CtOrigin
mkDerivOrigin Bool
sa_wildcard
meth_preds :: Type -> ThetaSpec
meth_preds :: TcType -> ThetaSpec
meth_preds TcType
ty
| [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
meths = []
| Bool
otherwise = TcType -> PredSpec
rep_pred_o TcType
ty PredSpec -> ThetaSpec -> ThetaSpec
forall a. a -> [a] -> [a]
: TcType -> ThetaSpec
coercible_constraints TcType
ty
meths :: [TyVar]
meths = Class -> [TyVar]
classMethods Class
cls
coercible_constraints :: TcType -> ThetaSpec
coercible_constraints TcType
ty
= [ SimplePredSpec :: TcType -> CtOrigin -> TypeOrKind -> PredSpec
SimplePredSpec
{ sps_pred :: TcType
sps_pred = TcType -> TcType -> TcType
mkReprPrimEqPred TcType
t1 TcType
t2
, sps_origin :: CtOrigin
sps_origin = TyVar -> TcType -> TcType -> Bool -> CtOrigin
DerivOriginCoerce TyVar
meth TcType
t1 TcType
t2 Bool
sa_wildcard
, sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
TypeLevel
}
| TyVar
meth <- [TyVar]
meths
, let (Pair TcType
t1 TcType
t2) = Class -> [TyVar] -> [TcType] -> TcType -> TyVar -> Pair TcType
mkCoerceClassMethEqn Class
cls [TyVar]
tvs
[TcType]
inst_tys TcType
ty TyVar
meth ]
ThetaSpec -> DerivM ThetaSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcType -> ThetaSpec
meth_preds TcType
rep_ty)
simplifyInstanceContexts :: [DerivSpec ThetaSpec]
-> TcM [DerivSpec ThetaType]
simplifyInstanceContexts :: [DerivSpec ThetaSpec] -> TcM [DerivSpec [TcType]]
simplifyInstanceContexts [] = [DerivSpec [TcType]] -> TcM [DerivSpec [TcType]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
simplifyInstanceContexts [DerivSpec ThetaSpec]
infer_specs
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"simplifyInstanceContexts" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ((DerivSpec ThetaSpec -> SDoc) -> [DerivSpec ThetaSpec] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DerivSpec ThetaSpec -> SDoc
forall theta. Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec [DerivSpec ThetaSpec]
infer_specs)
; [DerivSpec [TcType]]
final_specs <- Int -> [[TcType]] -> TcM [DerivSpec [TcType]]
iterate_deriv Int
1 [[TcType]]
initial_solutions
; (DerivSpec [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) (DerivSpec [TcType]))
-> [DerivSpec [TcType]] -> TcM [DerivSpec [TcType]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivSpec [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) (DerivSpec [TcType])
zonkDerivSpec [DerivSpec [TcType]]
final_specs }
where
initial_solutions :: [ThetaType]
initial_solutions :: [[TcType]]
initial_solutions = [ [] | DerivSpec ThetaSpec
_ <- [DerivSpec ThetaSpec]
infer_specs ]
iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
iterate_deriv :: Int -> [[TcType]] -> TcM [DerivSpec [TcType]]
iterate_deriv Int
n [[TcType]]
current_solns
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20
= String -> SDoc -> TcM [DerivSpec [TcType]]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"solveDerivEqns: probable loop"
([SDoc] -> SDoc
vcat ((DerivSpec ThetaSpec -> SDoc) -> [DerivSpec ThetaSpec] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DerivSpec ThetaSpec -> SDoc
forall theta. Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec [DerivSpec ThetaSpec]
infer_specs) SDoc -> SDoc -> SDoc
$$ [[TcType]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [[TcType]]
current_solns)
| Bool
otherwise
= do {
[ClsInst]
inst_specs <- ([TcType]
-> DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) ClsInst)
-> [[TcType]]
-> [DerivSpec ThetaSpec]
-> IOEnv (Env TcGblEnv TcLclEnv) [ClsInst]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\[TcType]
soln -> DerivSpec [TcType] -> IOEnv (Env TcGblEnv TcLclEnv) ClsInst
newDerivClsInst (DerivSpec [TcType] -> IOEnv (Env TcGblEnv TcLclEnv) ClsInst)
-> (DerivSpec ThetaSpec -> DerivSpec [TcType])
-> DerivSpec ThetaSpec
-> IOEnv (Env TcGblEnv TcLclEnv) ClsInst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TcType] -> DerivSpec ThetaSpec -> DerivSpec [TcType]
forall theta' theta. theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta [TcType]
soln)
[[TcType]]
current_solns [DerivSpec ThetaSpec]
infer_specs
; [[TcType]]
new_solns <- TcM [[TcType]] -> TcM [[TcType]]
forall r. TcM r -> TcM r
checkNoErrs (TcM [[TcType]] -> TcM [[TcType]])
-> TcM [[TcType]] -> TcM [[TcType]]
forall a b. (a -> b) -> a -> b
$
[ClsInst] -> TcM [[TcType]] -> TcM [[TcType]]
forall a. [ClsInst] -> TcM a -> TcM a
extendLocalInstEnv [ClsInst]
inst_specs (TcM [[TcType]] -> TcM [[TcType]])
-> TcM [[TcType]] -> TcM [[TcType]]
forall a b. (a -> b) -> a -> b
$
(DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [TcType])
-> [DerivSpec ThetaSpec] -> TcM [[TcType]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
gen_soln [DerivSpec ThetaSpec]
infer_specs
; if ([[TcType]]
current_solns [[TcType]] -> [[TcType]] -> Bool
`eqSolution` [[TcType]]
new_solns) then
[DerivSpec [TcType]] -> TcM [DerivSpec [TcType]]
forall (m :: * -> *) a. Monad m => a -> m a
return [ [TcType] -> DerivSpec ThetaSpec -> DerivSpec [TcType]
forall theta' theta. theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta [TcType]
soln DerivSpec ThetaSpec
spec
| (DerivSpec ThetaSpec
spec, [TcType]
soln) <- [DerivSpec ThetaSpec]
-> [[TcType]] -> [(DerivSpec ThetaSpec, [TcType])]
forall a b. [a] -> [b] -> [(a, b)]
zip [DerivSpec ThetaSpec]
infer_specs [[TcType]]
current_solns ]
else
Int -> [[TcType]] -> TcM [DerivSpec [TcType]]
iterate_deriv (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [[TcType]]
new_solns }
eqSolution :: [[TcType]] -> [[TcType]] -> Bool
eqSolution [[TcType]]
a [[TcType]]
b = ([TcType] -> [TcType] -> Bool) -> [[TcType]] -> [[TcType]] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy ((TcType -> TcType -> Bool) -> [TcType] -> [TcType] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eqListBy TcType -> TcType -> Bool
eqType) ([[TcType]] -> [[TcType]]
canSolution [[TcType]]
a) ([[TcType]] -> [[TcType]]
canSolution [[TcType]]
b)
canSolution :: [[TcType]] -> [[TcType]]
canSolution = ([TcType] -> [TcType]) -> [[TcType]] -> [[TcType]]
forall a b. (a -> b) -> [a] -> [b]
map ((TcType -> TcType -> Ordering) -> [TcType] -> [TcType]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy TcType -> TcType -> Ordering
nonDetCmpType)
gen_soln :: DerivSpec ThetaSpec -> TcM ThetaType
gen_soln :: DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
gen_soln (DS { ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars
, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_tys :: forall theta. DerivSpec theta -> [TcType]
ds_tys = [TcType]
inst_tys, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = ThetaSpec
deriv_rhs
, ds_skol_info :: forall theta. DerivSpec theta -> SkolemInfo
ds_skol_info = SkolemInfo
skol_info, ds_user_ctxt :: forall theta. DerivSpec theta -> UserTypeCtxt
ds_user_ctxt = UserTypeCtxt
user_ctxt })
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv (Env TcGblEnv TcLclEnv) [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType])
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TcType -> SDoc
derivInstCtxt TcType
the_pred) (IOEnv (Env TcGblEnv TcLclEnv) [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType])
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall a b. (a -> b) -> a -> b
$
do { [TcType]
theta <- SkolemInfo
-> UserTypeCtxt
-> [TyVar]
-> ThetaSpec
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
simplifyDeriv SkolemInfo
skol_info UserTypeCtxt
user_ctxt [TyVar]
tyvars ThetaSpec
deriv_rhs
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"GHC.Tc.Deriv" (ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaSpec
deriv_rhs SDoc -> SDoc -> SDoc
$$ [TcType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcType]
theta)
; [TcType] -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall (m :: * -> *) a. Monad m => a -> m a
return [TcType]
theta }
where
the_pred :: TcType
the_pred = Class -> [TcType] -> TcType
mkClassPred Class
clas [TcType]
inst_tys
derivInstCtxt :: PredType -> SDoc
derivInstCtxt :: TcType -> SDoc
derivInstCtxt TcType
pred
= String -> SDoc
text String
"When deriving the instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
pred)
simplifyDeriv :: SkolemInfo
-> UserTypeCtxt
-> [TcTyVar]
-> ThetaSpec
-> TcM ThetaType
simplifyDeriv :: SkolemInfo
-> UserTypeCtxt
-> [TyVar]
-> ThetaSpec
-> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
simplifyDeriv SkolemInfo
skol_info UserTypeCtxt
user_ctxt [TyVar]
tvs ThetaSpec
theta
= do { let skol_set :: VarSet
skol_set = [TyVar] -> VarSet
mkVarSet [TyVar]
tvs
; (TcLevel
tc_lvl, WantedConstraints
wanteds) <- UserTypeCtxt -> ThetaSpec -> TcM (TcLevel, WantedConstraints)
captureThetaSpecConstraints UserTypeCtxt
user_ctxt ThetaSpec
theta
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"simplifyDeriv inputs" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
pprTyVars [TyVar]
tvs SDoc -> SDoc -> SDoc
$$ ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaSpec
theta SDoc -> SDoc -> SDoc
$$ WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanteds, SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info ]
; (WantedConstraints
solved_wanteds, EvBindMap
_) <- TcLevel
-> TcM (WantedConstraints, EvBindMap)
-> TcM (WantedConstraints, EvBindMap)
forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
tc_lvl (TcM (WantedConstraints, EvBindMap)
-> TcM (WantedConstraints, EvBindMap))
-> TcM (WantedConstraints, EvBindMap)
-> TcM (WantedConstraints, EvBindMap)
forall a b. (a -> b) -> a -> b
$
TcS WantedConstraints -> TcM (WantedConstraints, EvBindMap)
forall a. TcS a -> TcM (a, EvBindMap)
runTcS (TcS WantedConstraints -> TcM (WantedConstraints, EvBindMap))
-> TcS WantedConstraints -> TcM (WantedConstraints, EvBindMap)
forall a b. (a -> b) -> a -> b
$
WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wanteds
; WantedConstraints
solved_wanteds <- WantedConstraints -> TcM WantedConstraints
zonkWC WantedConstraints
solved_wanteds
; let residual_simple :: Cts
residual_simple = Bool -> WantedConstraints -> Cts
approximateWC Bool
True WantedConstraints
solved_wanteds
good :: Bag TcType
good = (Ct -> Maybe TcType) -> Cts -> Bag TcType
forall a b. (a -> Maybe b) -> Bag a -> Bag b
mapMaybeBag Ct -> Maybe TcType
get_good Cts
residual_simple
get_good :: Ct -> Maybe PredType
get_good :: Ct -> Maybe TcType
get_good Ct
ct | VarSet -> TcType -> Bool
validDerivPred VarSet
skol_set TcType
p
= TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
p
| Bool
otherwise
= Maybe TcType
forall a. Maybe a
Nothing
where p :: TcType
p = Ct -> TcType
ctPred Ct
ct
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"simplifyDeriv outputs" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs, Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
residual_simple, Bag TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag TcType
good ]
; let min_theta :: [TcType]
min_theta = (TcType -> TcType) -> [TcType] -> [TcType]
forall a. (a -> TcType) -> [a] -> [a]
mkMinimalBySCs TcType -> TcType
forall a. a -> a
id (Bag TcType -> [TcType]
forall a. Bag a -> [a]
bagToList Bag TcType
good)
; [TyVar]
min_theta_vars <- (TcType -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TcType] -> IOEnv (Env TcGblEnv TcLclEnv) [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcType -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall gbl lcl. TcType -> TcRnIf gbl lcl TyVar
newEvVar [TcType]
min_theta
; (Bag Implication
leftover_implic, TcEvBinds
_)
<- TcLevel
-> SkolemInfoAnon
-> [TyVar]
-> [TyVar]
-> WantedConstraints
-> TcM (Bag Implication, TcEvBinds)
buildImplicationFor TcLevel
tc_lvl (SkolemInfo -> SkolemInfoAnon
getSkolemInfo SkolemInfo
skol_info) [TyVar]
tvs
[TyVar]
min_theta_vars WantedConstraints
solved_wanteds
; Bag Implication -> IOEnv (Env TcGblEnv TcLclEnv) ()
simplifyTopImplic Bag Implication
leftover_implic
; [TcType] -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall (m :: * -> *) a. Monad m => a -> m a
return [TcType]
min_theta }