{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Deriv.Utils (
DerivM, DerivEnv(..),
DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec,
DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
isDerivSpecNewtype, isDerivSpecAnyClass,
isDerivSpecVia, zonkDerivSpecMechanism,
DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),
isStandaloneDeriv, isStandaloneWildcardDeriv,
askDerivUserTypeCtxt, mkDerivOrigin,
PredSpec(..), ThetaSpec,
mkDirectThetaSpec, substPredSpec, captureThetaSpecConstraints,
checkOriginativeSideConditions, hasStockDeriving,
std_class_via_coercible, non_coercible_class,
newDerivClsInst, extendLocalInstEnv
) where
import GHC.Prelude
import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Deriv.Generate
import GHC.Tc.Deriv.Functor
import GHC.Tc.Deriv.Generics
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical)
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Unify (tcSubTypeSigma)
import GHC.Tc.Zonk.Type
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Hs
import GHC.Driver.Session
import GHC.Unit.Module (getModule)
import GHC.Unit.Module.ModIface (mi_fix)
import GHC.Types.Fixity.Env (lookupFixity)
import GHC.Iface.Load (loadInterfaceForName)
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Types.Var.Set
import GHC.Builtin.Names
import GHC.Builtin.Names.TH (liftClassKey)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
import Control.Monad.Trans.Reader
import Data.Foldable (traverse_)
import Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.List.SetOps (assocMaybe)
type DerivM = ReaderT DerivEnv TcRn
isStandaloneDeriv :: DerivM Bool
isStandaloneDeriv :: DerivM Bool
isStandaloneDeriv = (DerivEnv -> Bool) -> DerivM Bool
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (DerivContext -> Bool
go (DerivContext -> Bool)
-> (DerivEnv -> DerivContext) -> DerivEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivEnv -> DerivContext
denv_ctxt)
where
go :: DerivContext -> Bool
go :: DerivContext -> Bool
go (InferContext Maybe SrcSpan
wildcard) = Maybe SrcSpan -> Bool
forall a. Maybe a -> Bool
isJust Maybe SrcSpan
wildcard
go (SupplyContext {}) = Bool
True
isStandaloneWildcardDeriv :: DerivM Bool
isStandaloneWildcardDeriv :: DerivM Bool
isStandaloneWildcardDeriv = (DerivEnv -> Bool) -> DerivM Bool
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (DerivContext -> Bool
go (DerivContext -> Bool)
-> (DerivEnv -> DerivContext) -> DerivEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivEnv -> DerivContext
denv_ctxt)
where
go :: DerivContext -> Bool
go :: DerivContext -> Bool
go (InferContext Maybe SrcSpan
wildcard) = Maybe SrcSpan -> Bool
forall a. Maybe a -> Bool
isJust Maybe SrcSpan
wildcard
go (SupplyContext {}) = Bool
False
askDerivUserTypeCtxt :: DerivM UserTypeCtxt
askDerivUserTypeCtxt :: DerivM UserTypeCtxt
askDerivUserTypeCtxt = (DerivEnv -> UserTypeCtxt) -> DerivM UserTypeCtxt
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (DerivContext -> UserTypeCtxt
go (DerivContext -> UserTypeCtxt)
-> (DerivEnv -> DerivContext) -> DerivEnv -> UserTypeCtxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivEnv -> DerivContext
denv_ctxt)
where
go :: DerivContext -> UserTypeCtxt
go :: DerivContext -> UserTypeCtxt
go (SupplyContext {}) = Bool -> UserTypeCtxt
InstDeclCtxt Bool
True
go (InferContext Just{}) = Bool -> UserTypeCtxt
InstDeclCtxt Bool
True
go (InferContext Maybe SrcSpan
Nothing) = UserTypeCtxt
DerivClauseCtxt
mkDerivOrigin :: Bool -> CtOrigin
mkDerivOrigin :: Bool -> CtOrigin
mkDerivOrigin Bool
standalone_wildcard
| Bool
standalone_wildcard = CtOrigin
StandAloneDerivOrigin
| Bool
otherwise = CtOrigin
DerivClauseOrigin
data DerivEnv = DerivEnv
{ DerivEnv -> Maybe OverlapMode
denv_overlap_mode :: Maybe OverlapMode
, DerivEnv -> [TyVar]
denv_tvs :: [TyVar]
, DerivEnv -> Class
denv_cls :: Class
, DerivEnv -> [Type]
denv_inst_tys :: [Type]
, DerivEnv -> DerivContext
denv_ctxt :: DerivContext
, DerivEnv -> SkolemInfo
denv_skol_info :: SkolemInfo
, DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat :: Maybe (DerivStrategy GhcTc)
}
instance Outputable DerivEnv where
ppr :: DerivEnv -> SDoc
ppr (DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
, denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [Type]
denv_inst_tys = [Type]
inst_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
ctxt
, denv_skol_info :: DerivEnv -> SkolemInfo
denv_skol_info = SkolemInfo
skol_info
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat })
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DerivEnv")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_overlap_mode" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe OverlapMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe OverlapMode
overlap_mode
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_cls" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_inst_tys" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inst_tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_ctxt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DerivContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivContext
ctxt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_skol_info" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"denv_strat" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
mb_strat ])
data DerivSpec theta = DS { forall theta. DerivSpec theta -> SrcSpan
ds_loc :: SrcSpan
, forall theta. DerivSpec theta -> Name
ds_name :: Name
, forall theta. DerivSpec theta -> [TyVar]
ds_tvs :: [TyVar]
, forall theta. DerivSpec theta -> theta
ds_theta :: theta
, forall theta. DerivSpec theta -> Class
ds_cls :: Class
, forall theta. DerivSpec theta -> [Type]
ds_tys :: [Type]
, forall theta. DerivSpec theta -> SkolemInfo
ds_skol_info :: SkolemInfo
, forall theta. DerivSpec theta -> UserTypeCtxt
ds_user_ctxt :: UserTypeCtxt
, forall theta. DerivSpec theta -> Maybe OverlapMode
ds_overlap :: Maybe OverlapMode
, forall theta. DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard :: Maybe SrcSpan
, forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism :: DerivSpecMechanism }
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec :: forall theta. Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec (DS { ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
l, ds_name :: forall theta. DerivSpec theta -> Name
ds_name = Name
n, ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
c,
ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
tys, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = theta
rhs, ds_skol_info :: forall theta. DerivSpec theta -> SkolemInfo
ds_skol_info = SkolemInfo
skol_info,
ds_standalone_wildcard :: forall theta. DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mech })
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DerivSpec")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_loc =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
l
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_name =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_tvs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_cls =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
c
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_tys =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_theta =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> theta -> SDoc
forall a. Outputable a => a -> SDoc
ppr theta
rhs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_skol_info =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_standalone_wildcard =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe SrcSpan
wildcard
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ds_mechanism =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DerivSpecMechanism -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpecMechanism
mech ])
instance Outputable theta => Outputable (DerivSpec theta) where
ppr :: DerivSpec theta -> SDoc
ppr = DerivSpec theta -> SDoc
forall theta. Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec
setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta :: forall theta' theta. theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta theta'
theta DerivSpec theta
ds = DerivSpec theta
ds{ds_theta = theta}
zonkDerivSpec :: DerivSpec ThetaType -> ZonkTcM (DerivSpec ThetaType)
zonkDerivSpec :: DerivSpec [Type] -> ZonkTcM (DerivSpec [Type])
zonkDerivSpec ds :: DerivSpec [Type]
ds@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = [Type]
theta
, ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
tys, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
}) =
ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [TyVar]
-> forall r.
([TyVar] -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([TyVar] -> ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [TyVar]
zonkTyBndrsX [TyVar]
tvs) (([TyVar] -> ZonkTcM (DerivSpec [Type]))
-> ZonkTcM (DerivSpec [Type]))
-> ([TyVar] -> ZonkTcM (DerivSpec [Type]))
-> ZonkTcM (DerivSpec [Type])
forall a b. (a -> b) -> a -> b
$ \ [TyVar]
tvs' -> do
[Type]
theta' <- [Type] -> ZonkTcM [Type]
zonkTcTypesToTypesX [Type]
theta
[Type]
tys' <- [Type] -> ZonkTcM [Type]
zonkTcTypesToTypesX [Type]
tys
DerivSpecMechanism
mechanism' <- DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
zonkDerivSpecMechanism DerivSpecMechanism
mechanism
DerivSpec [Type] -> ZonkTcM (DerivSpec [Type])
forall a. a -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivSpec [Type]
ds{ ds_tvs = tvs', ds_theta = theta'
, ds_tys = tys', ds_mechanism = mechanism'
}
data DerivSpecMechanism
= DerivSpecStock
{ DerivSpecMechanism -> DerivInstTys
dsm_stock_dit :: DerivInstTys
, DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns :: StockGenFns
}
| DerivSpecNewtype
{ DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit :: DerivInstTys
, DerivSpecMechanism -> Type
dsm_newtype_rep_ty :: Type
}
| DerivSpecAnyClass
| DerivSpecVia
{ DerivSpecMechanism -> [Type]
dsm_via_cls_tys :: [Type]
, DerivSpecMechanism -> Type
dsm_via_inst_ty :: Type
, DerivSpecMechanism -> Type
dsm_via_ty :: Type
}
derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
derivSpecMechanismToStrategy DerivSpecStock{} = XStockStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy XStockStrategy GhcTc
NoExtField
noExtField
derivSpecMechanismToStrategy DerivSpecNewtype{} = XNewtypeStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy XNewtypeStrategy GhcTc
NoExtField
noExtField
derivSpecMechanismToStrategy DerivSpecMechanism
DerivSpecAnyClass = XAnyClassStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy XAnyClassStrategy GhcTc
NoExtField
noExtField
derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
t}) = XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcTc
Type
t
isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
:: DerivSpecMechanism -> Bool
isDerivSpecStock :: DerivSpecMechanism -> Bool
isDerivSpecStock (DerivSpecStock{}) = Bool
True
isDerivSpecStock DerivSpecMechanism
_ = Bool
False
isDerivSpecNewtype :: DerivSpecMechanism -> Bool
isDerivSpecNewtype (DerivSpecNewtype{}) = Bool
True
isDerivSpecNewtype DerivSpecMechanism
_ = Bool
False
isDerivSpecAnyClass :: DerivSpecMechanism -> Bool
isDerivSpecAnyClass DerivSpecMechanism
DerivSpecAnyClass = Bool
True
isDerivSpecAnyClass DerivSpecMechanism
_ = Bool
False
isDerivSpecVia :: DerivSpecMechanism -> Bool
isDerivSpecVia (DerivSpecVia{}) = Bool
True
isDerivSpecVia DerivSpecMechanism
_ = Bool
False
zonkDerivSpecMechanism :: DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
zonkDerivSpecMechanism :: DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
zonkDerivSpecMechanism DerivSpecMechanism
mechanism =
case DerivSpecMechanism
mechanism of
DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns
} -> do
DerivInstTys
dit' <- DerivInstTys -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) DerivInstTys
zonkDerivInstTys DerivInstTys
dit
DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a. a -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivSpecMechanism -> ZonkTcM DerivSpecMechanism)
-> DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a b. (a -> b) -> a -> b
$ DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit'
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns
}
DerivSpecNewtype { dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit = DerivInstTys
dit
, dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rep_ty
} -> do
DerivInstTys
dit' <- DerivInstTys -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) DerivInstTys
zonkDerivInstTys DerivInstTys
dit
Type
rep_ty' <- Type -> ZonkTcM Type
zonkTcTypeToTypeX Type
rep_ty
DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a. a -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivSpecMechanism -> ZonkTcM DerivSpecMechanism)
-> DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a b. (a -> b) -> a -> b
$ DerivSpecNewtype { dsm_newtype_dit :: DerivInstTys
dsm_newtype_dit = DerivInstTys
dit'
, dsm_newtype_rep_ty :: Type
dsm_newtype_rep_ty = Type
rep_ty'
}
DerivSpecMechanism
DerivSpecAnyClass ->
DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a. a -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivSpecMechanism
DerivSpecAnyClass
DerivSpecVia { dsm_via_cls_tys :: DerivSpecMechanism -> [Type]
dsm_via_cls_tys = [Type]
cls_tys
, dsm_via_inst_ty :: DerivSpecMechanism -> Type
dsm_via_inst_ty = Type
inst_ty
, dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty
} -> do
[Type]
cls_tys' <- [Type] -> ZonkTcM [Type]
zonkTcTypesToTypesX [Type]
cls_tys
Type
inst_ty' <- Type -> ZonkTcM Type
zonkTcTypeToTypeX Type
inst_ty
Type
via_ty' <- Type -> ZonkTcM Type
zonkTcTypeToTypeX Type
via_ty
DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a. a -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivSpecMechanism -> ZonkTcM DerivSpecMechanism)
-> DerivSpecMechanism -> ZonkTcM DerivSpecMechanism
forall a b. (a -> b) -> a -> b
$ DerivSpecVia { dsm_via_cls_tys :: [Type]
dsm_via_cls_tys = [Type]
cls_tys'
, dsm_via_inst_ty :: Type
dsm_via_inst_ty = Type
inst_ty'
, dsm_via_ty :: Type
dsm_via_ty = Type
via_ty'
}
instance Outputable DerivSpecMechanism where
ppr :: DerivSpecMechanism -> SDoc
ppr (DerivSpecStock{dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit})
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DerivSpecStock")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsm_stock_dit" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DerivInstTys -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivInstTys
dit ])
ppr (DerivSpecNewtype { dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit = DerivInstTys
dit, dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rep_ty })
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DerivSpecNewtype")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsm_newtype_dit" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DerivInstTys -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivInstTys
dit
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsm_newtype_rep_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rep_ty ])
ppr DerivSpecMechanism
DerivSpecAnyClass = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DerivSpecAnyClass"
ppr (DerivSpecVia { dsm_via_cls_tys :: DerivSpecMechanism -> [Type]
dsm_via_cls_tys = [Type]
cls_tys, dsm_via_inst_ty :: DerivSpecMechanism -> Type
dsm_via_inst_ty = Type
inst_ty
, dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty })
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DerivSpecVia")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsm_via_cls_tys" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsm_via_inst_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsm_via_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
via_ty ])
data DerivContext
= InferContext (Maybe SrcSpan)
| SupplyContext ThetaType
instance Outputable DerivContext where
ppr :: DerivContext -> SDoc
ppr (InferContext Maybe SrcSpan
standalone) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"InferContext" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe SrcSpan
standalone
ppr (SupplyContext [Type]
theta) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SupplyContext" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta
data OriginativeDerivStatus
= CanDeriveStock StockGenFns
| StockClassError !DeriveInstanceErrReason
| CanDeriveAnyClass
| NonDerivableClass
data StockGenFns = StockGenFns
{ StockGenFns
-> SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
stock_gen_binds ::
SrcSpan -> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
, StockGenFns -> SrcSpan -> DerivInstTys -> TcM [FamInst]
stock_gen_fam_insts ::
SrcSpan -> DerivInstTys
-> TcM [FamInst]
}
data PredSpec
=
SimplePredSpec
{ PredSpec -> Type
sps_pred :: TcPredType
, PredSpec -> CtOrigin
sps_origin :: CtOrigin
, PredSpec -> TypeOrKind
sps_type_or_kind :: TypeOrKind
}
|
SubTypePredSpec
{ PredSpec -> Type
stps_ty_actual :: TcSigmaType
, PredSpec -> Type
stps_ty_expected :: TcSigmaType
, PredSpec -> CtOrigin
stps_origin :: CtOrigin
}
type ThetaSpec = [PredSpec]
instance Outputable PredSpec where
ppr :: PredSpec -> SDoc
ppr (SimplePredSpec{sps_pred :: PredSpec -> Type
sps_pred = Type
ty}) =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SimplePredSpec")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sps_pred" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty ])
ppr (SubTypePredSpec { stps_ty_actual :: PredSpec -> Type
stps_ty_actual = Type
ty_actual
, stps_ty_expected :: PredSpec -> Type
stps_ty_expected = Type
ty_expected }) =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SubTypePredSpec")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stps_ty_actual" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty_actual
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stps_ty_expected" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty_expected
])
mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaSpec
mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> [Type] -> ThetaSpec
mkDirectThetaSpec CtOrigin
origin TypeOrKind
t_or_k =
(Type -> PredSpec) -> [Type] -> ThetaSpec
forall a b. (a -> b) -> [a] -> [b]
map (\Type
p -> SimplePredSpec
{ sps_pred :: Type
sps_pred = Type
p
, sps_origin :: CtOrigin
sps_origin = CtOrigin
origin
, sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
})
substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec
substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec
substPredSpec Subst
subst PredSpec
ps =
case PredSpec
ps of
SimplePredSpec { sps_pred :: PredSpec -> Type
sps_pred = Type
pred
, sps_origin :: PredSpec -> CtOrigin
sps_origin = CtOrigin
origin
, sps_type_or_kind :: PredSpec -> TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
}
-> SimplePredSpec { sps_pred :: Type
sps_pred = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
pred
, sps_origin :: CtOrigin
sps_origin = CtOrigin
origin
, sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
}
SubTypePredSpec { stps_ty_actual :: PredSpec -> Type
stps_ty_actual = Type
ty_actual
, stps_ty_expected :: PredSpec -> Type
stps_ty_expected = Type
ty_expected
, stps_origin :: PredSpec -> CtOrigin
stps_origin = CtOrigin
origin
}
-> SubTypePredSpec { stps_ty_actual :: Type
stps_ty_actual = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
ty_actual
, stps_ty_expected :: Type
stps_ty_expected = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
ty_expected
, stps_origin :: CtOrigin
stps_origin = CtOrigin
origin
}
captureThetaSpecConstraints ::
UserTypeCtxt
-> ThetaSpec
-> TcM (TcLevel, WantedConstraints)
captureThetaSpecConstraints :: UserTypeCtxt -> ThetaSpec -> TcM (TcLevel, WantedConstraints)
captureThetaSpecConstraints UserTypeCtxt
user_ctxt ThetaSpec
theta =
TcM WantedConstraints -> TcM (TcLevel, WantedConstraints)
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM WantedConstraints -> TcM (TcLevel, WantedConstraints))
-> TcM WantedConstraints -> TcM (TcLevel, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ ThetaSpec -> TcM WantedConstraints
mk_wanteds ThetaSpec
theta
where
mk_wanteds :: ThetaSpec -> TcM WantedConstraints
mk_wanteds :: ThetaSpec -> TcM WantedConstraints
mk_wanteds ThetaSpec
preds
= do { (()
_, WantedConstraints
wanteds) <- TcM () -> TcM ((), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM () -> TcM ((), WantedConstraints))
-> TcM () -> TcM ((), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
(PredSpec -> TcM ()) -> ThetaSpec -> TcM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ PredSpec -> TcM ()
emit_constraints ThetaSpec
preds
; WantedConstraints -> TcM WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WantedConstraints
wanteds }
emit_constraints :: PredSpec -> TcM ()
emit_constraints :: PredSpec -> TcM ()
emit_constraints PredSpec
ps =
case PredSpec
ps of
SimplePredSpec { sps_pred :: PredSpec -> Type
sps_pred = Type
wanted
, sps_origin :: PredSpec -> CtOrigin
sps_origin = CtOrigin
orig
, sps_type_or_kind :: PredSpec -> TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
} -> do
CtEvidence
ev <- CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
newWanted CtOrigin
orig (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
t_or_k) Type
wanted
Ct -> TcM ()
emitSimple (CtEvidence -> Ct
mkNonCanonical CtEvidence
ev)
SubTypePredSpec { stps_ty_actual :: PredSpec -> Type
stps_ty_actual = Type
ty_actual
, stps_ty_expected :: PredSpec -> Type
stps_ty_expected = Type
ty_expected
, stps_origin :: PredSpec -> CtOrigin
stps_origin = CtOrigin
orig
} -> do
HsWrapper
_ <- CtOrigin -> UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma CtOrigin
orig UserTypeCtxt
user_ctxt Type
ty_actual Type
ty_expected
() -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
hasStockDeriving
:: Class -> Maybe StockGenFns
hasStockDeriving :: Class -> Maybe StockGenFns
hasStockDeriving Class
clas
= Assoc Unique StockGenFns -> Unique -> Maybe StockGenFns
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe Assoc Unique StockGenFns
gen_list (Class -> Unique
forall a. Uniquable a => a -> Unique
getUnique Class
clas)
where
gen_list :: [(Unique, StockGenFns)]
gen_list :: Assoc Unique StockGenFns
gen_list =
[ (Unique
eqClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Eq_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
ordClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Ord_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
enumClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Enum_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
boundedClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Bounded_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
ixClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Ix_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
showClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (((Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {t} {a} {c} {a}.
((Name -> Fixity) -> t -> DerivInstTys -> (a, c))
-> t
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
read_or_show_binds (Name -> Fixity)
-> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
(Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Show_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
readClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (((Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {t} {a} {c} {a}.
((Name -> Fixity) -> t -> DerivInstTys -> (a, c))
-> t
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
read_or_show_binds (Name -> Fixity)
-> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
(Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Read_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
dataClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Data_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
functorClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Functor_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
foldableClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Foldable_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
traversableClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Traversable_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
liftClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag AuxBindSpec)
gen_Lift_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
, (Unique
genClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (GenericKind
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {a}.
GenericKind
-> SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
generic_binds GenericKind
Gen0) (GenericKind -> SrcSpan -> DerivInstTys -> TcM [FamInst]
generic_fam_inst GenericKind
Gen0))
, (Unique
gen1ClassKey, (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (GenericKind
-> SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {a}.
GenericKind
-> SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
generic_binds GenericKind
Gen1) (GenericKind -> SrcSpan -> DerivInstTys -> TcM [FamInst]
generic_fam_inst GenericKind
Gen1))
]
mk :: (SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_binds_fn SrcSpan -> DerivInstTys -> TcM [FamInst]
gen_fam_insts_fn = StockGenFns
{ stock_gen_binds :: SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
stock_gen_binds = SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
SrcSpan
-> DerivInstTys
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_binds_fn
, stock_gen_fam_insts :: SrcSpan -> DerivInstTys -> TcM [FamInst]
stock_gen_fam_insts = SrcSpan -> DerivInstTys -> TcM [FamInst]
gen_fam_insts_fn
}
simple_binds :: (t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds t -> t -> (a, c)
gen_fn t
loc t
dit
= let (a
binds, c
aux_specs) = t -> t -> (a, c)
gen_fn t
loc t
dit
in (a, [a], c, [a]) -> m (a, [a], c, [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, [], c
aux_specs, [])
simple_bindsM :: (t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM t -> t -> m (a, c)
gen_fn t
loc t
dit
= do { (a
binds, c
aux_specs) <- t -> t -> m (a, c)
gen_fn t
loc t
dit
; (a, [a], c, [a]) -> m (a, [a], c, [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, [], c
aux_specs, []) }
read_or_show_binds :: ((Name -> Fixity) -> t -> DerivInstTys -> (a, c))
-> t
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
read_or_show_binds (Name -> Fixity) -> t -> DerivInstTys -> (a, c)
gen_fn t
loc DerivInstTys
dit
= do { let tc :: TyCon
tc = DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit
; Name -> Fixity
fix_env <- TyCon -> TcM (Name -> Fixity)
getDataConFixityFun TyCon
tc
; let (a
binds, c
aux_specs) = (Name -> Fixity) -> t -> DerivInstTys -> (a, c)
gen_fn Name -> Fixity
fix_env t
loc DerivInstTys
dit
field_names :: [Name]
field_names = TyCon -> [Name]
all_field_names TyCon
tc
; (a, [a], c, [Name])
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, [], c
aux_specs, [Name]
field_names) }
generic_binds :: GenericKind
-> SrcSpan
-> DerivInstTys
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
generic_binds GenericKind
gk SrcSpan
loc DerivInstTys
dit
= do { let tc :: TyCon
tc = DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs) <- GenericKind
-> SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs])
gen_Generic_binds GenericKind
gk SrcSpan
loc DerivInstTys
dit
; let field_names :: [Name]
field_names = TyCon -> [Name]
all_field_names TyCon
tc
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, Bag a
forall a. Bag a
emptyBag, [Name]
field_names) }
generic_fam_inst :: GenericKind -> SrcSpan -> DerivInstTys -> TcM [FamInst]
generic_fam_inst GenericKind
gk SrcSpan
loc DerivInstTys
dit
= do { let tc :: TyCon
tc = DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit
; Name -> Fixity
fix_env <- TyCon -> TcM (Name -> Fixity)
getDataConFixityFun TyCon
tc
; FamInst
faminst <- GenericKind
-> (Name -> Fixity) -> SrcSpan -> DerivInstTys -> TcM FamInst
gen_Generic_fam_inst GenericKind
gk Name -> Fixity
fix_env SrcSpan
loc DerivInstTys
dit
; [FamInst] -> TcM [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [FamInst
faminst] }
no_fam_insts :: p -> p -> f [a]
no_fam_insts p
_ p
_ = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
all_field_names :: TyCon -> [Name]
all_field_names = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector ([FieldLabel] -> [Name])
-> (TyCon -> [FieldLabel]) -> TyCon -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataCon -> [FieldLabel]) -> [DataCon] -> [FieldLabel]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [FieldLabel]
dataConFieldLabels
([DataCon] -> [FieldLabel])
-> (TyCon -> [DataCon]) -> TyCon -> [FieldLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons
getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
getDataConFixityFun TyCon
tc
= do { Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name
then do { FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
; (Name -> Fixity) -> TcM (Name -> Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv -> Name -> Fixity
lookupFixity FixityEnv
fix_env) }
else do { ModIface
iface <- SDoc -> Name -> TcRn ModIface
loadInterfaceForName SDoc
doc Name
name
; (Name -> Fixity) -> TcM (Name -> Fixity)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> OccName -> Fixity
mi_fix ModIface
iface (OccName -> Fixity) -> (Name -> OccName) -> Name -> Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) } }
where
name :: Name
name = TyCon -> Name
tyConName TyCon
tc
doc :: SDoc
doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Data con fixities for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions dit :: DerivInstTys
dit@(DerivInstTys{dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys}) =
do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
DynFlags
dflags <- ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if
| Just Condition
cond <- DerivContext -> Class -> Maybe Condition
stockSideConditions DerivContext
deriv_ctxt Class
cls
-> case Condition
cond DynFlags
dflags DerivInstTys
dit of
NotValid DeriveInstanceErrReason
err -> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginativeDerivStatus -> DerivM OriginativeDerivStatus)
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason -> OriginativeDerivStatus
StockClassError DeriveInstanceErrReason
err
Validity' DeriveInstanceErrReason
IsValid | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
cls_tys)
, Just StockGenFns
gen_fn <- Class -> Maybe StockGenFns
hasStockDeriving Class
cls
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginativeDerivStatus -> DerivM OriginativeDerivStatus)
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ StockGenFns -> OriginativeDerivStatus
CanDeriveStock StockGenFns
gen_fn
| Bool
otherwise
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginativeDerivStatus -> DerivM OriginativeDerivStatus)
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason -> OriginativeDerivStatus
StockClassError (DeriveInstanceErrReason -> OriginativeDerivStatus)
-> DeriveInstanceErrReason -> OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> DeriveInstanceErrReason
classArgsErr Class
cls [Type]
cls_tys
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OriginativeDerivStatus
CanDeriveAnyClass
| Bool
otherwise
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OriginativeDerivStatus
NonDerivableClass
classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason
classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason
classArgsErr Class
cls [Type]
cls_tys = Type -> DeriveInstanceErrReason
DerivErrNotAClass (Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_tys)
stockSideConditions :: DerivContext -> Class -> Maybe Condition
stockSideConditions :: DerivContext -> Class -> Maybe Condition
stockSideConditions DerivContext
deriv_ctxt Class
cls
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
eqClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_args Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ordClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_args Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
showClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_args Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
readClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_args Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
enumClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Condition
cond_isEnumeration)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ixClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_enumOrProduct Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
boundedClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition
cond_std Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_enumOrProduct Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
dataClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveDataTypeable Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Class -> Condition
cond_args Class
cls)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
functorClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveFunctor Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Bool -> Bool -> Condition
cond_functorOK Bool
True Bool
False)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
foldableClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveFoldable Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Bool -> Bool -> Condition
cond_functorOK Bool
False Bool
True)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
traversableClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveTraversable Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Bool -> Bool -> Condition
cond_functorOK Bool
False Bool
False)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
genClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveGeneric Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Condition
cond_RepresentableOk)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
gen1ClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveGeneric Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Condition
cond_Representable1Ok)
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftClassKey = Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Extension -> Condition
checkFlag Extension
LangExt.DeriveLift Condition -> Condition -> Condition
`andCond`
Condition
cond_vanilla Condition -> Condition -> Condition
`andCond`
Class -> Condition
cond_args Class
cls)
| Bool
otherwise = Maybe Condition
forall a. Maybe a
Nothing
where
cls_key :: Unique
cls_key = Class -> Unique
forall a. Uniquable a => a -> Unique
getUnique Class
cls
cond_std :: Condition
cond_std = DerivContext -> Bool -> Condition
cond_stdOK DerivContext
deriv_ctxt Bool
False
cond_vanilla :: Condition
cond_vanilla = DerivContext -> Bool -> Condition
cond_stdOK DerivContext
deriv_ctxt Bool
True
type Condition
= DynFlags
-> DerivInstTys
-> Validity' DeriveInstanceErrReason
andCond :: Condition -> Condition -> Condition
andCond :: Condition -> Condition -> Condition
andCond Condition
c1 Condition
c2 DynFlags
dflags DerivInstTys
dit
= Condition
c1 DynFlags
dflags DerivInstTys
dit Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Condition
c2 DynFlags
dflags DerivInstTys
dit
cond_stdOK
:: DerivContext
-> Bool
-> Condition
cond_stdOK :: DerivContext -> Bool -> Condition
cond_stdOK DerivContext
deriv_ctxt Bool
permissive DynFlags
dflags
dit :: DerivInstTys
dit@(DerivInstTys{dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
= Validity' DeriveInstanceErrReason
valid_ADT Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' DeriveInstanceErrReason
valid_misc
where
valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason
valid_ADT :: Validity' DeriveInstanceErrReason
valid_ADT
| TyCon -> Bool
isAlgTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isDataFamilyTyCon TyCon
tc
= Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
| Bool
otherwise
= DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid DeriveInstanceErrReason
DerivErrLastArgMustBeApp
valid_misc :: Validity' DeriveInstanceErrReason
valid_misc
= case DerivContext
deriv_ctxt of
SupplyContext [Type]
_ -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
InferContext Maybe SrcSpan
wildcard
| [DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons
, Bool -> Bool
not Bool
permissive
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.EmptyDataDeriving DynFlags
dflags)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (TyCon -> DeriveInstanceErrReason
no_cons_why TyCon
rep_tc)
| Bool -> Bool
not ([DeriveInstanceBadConstructor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DeriveInstanceBadConstructor]
con_whys)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor (HasWildcard -> Maybe HasWildcard
forall a. a -> Maybe a
Just (HasWildcard -> Maybe HasWildcard)
-> HasWildcard -> Maybe HasWildcard
forall a b. (a -> b) -> a -> b
$ Maybe SrcSpan -> HasWildcard
forall {a}. Maybe a -> HasWildcard
has_wildcard Maybe SrcSpan
wildcard) [DeriveInstanceBadConstructor]
con_whys
| Bool
otherwise
-> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
has_wildcard :: Maybe a -> HasWildcard
has_wildcard Maybe a
wildcard
= case Maybe a
wildcard of
Just a
_ -> HasWildcard
YesHasWildcard
Maybe a
Nothing -> HasWildcard
NoHasWildcard
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
con_whys :: [DeriveInstanceBadConstructor]
con_whys = [Validity' DeriveInstanceBadConstructor]
-> [DeriveInstanceBadConstructor]
forall a. [Validity' a] -> [a]
getInvalids ((DataCon -> Validity' DeriveInstanceBadConstructor)
-> [DataCon] -> [Validity' DeriveInstanceBadConstructor]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity' DeriveInstanceBadConstructor
check_con [DataCon]
data_cons)
check_con :: DataCon -> Validity' DeriveInstanceBadConstructor
check_con :: DataCon -> Validity' DeriveInstanceBadConstructor
check_con DataCon
con
| Bool -> Bool
not ([EqSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec)
= (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConIsGADT
| Bool -> Bool
not ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
ex_tvs)
= (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConHasExistentials
| Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta)
= (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConHasConstraints
| Bool -> Bool
not (Bool
permissive Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTauTy (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
con DerivInstTys
dit))
= (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConHasHigherRankType
| Bool
otherwise
= Validity' DeriveInstanceBadConstructor
forall a. Validity' a
IsValid
where
([TyVar]
_, [TyVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Scaled Type]
_, Type
_) = DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
con
bad :: (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
mkErr = DeriveInstanceBadConstructor
-> Validity' DeriveInstanceBadConstructor
forall a. a -> Validity' a
NotValid (DeriveInstanceBadConstructor
-> Validity' DeriveInstanceBadConstructor)
-> DeriveInstanceBadConstructor
-> Validity' DeriveInstanceBadConstructor
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveInstanceBadConstructor
mkErr DataCon
con
no_cons_why :: TyCon -> DeriveInstanceErrReason
no_cons_why :: TyCon -> DeriveInstanceErrReason
no_cons_why = TyCon -> DeriveInstanceErrReason
DerivErrNoConstructors
cond_RepresentableOk :: Condition
cond_RepresentableOk :: Condition
cond_RepresentableOk DynFlags
_ DerivInstTys
dit =
case DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics DerivInstTys
dit of
Validity' [DeriveGenericsErrReason]
IsValid -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
NotValid [DeriveGenericsErrReason]
generic_errs -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ [DeriveGenericsErrReason] -> DeriveInstanceErrReason
DerivErrGenerics [DeriveGenericsErrReason]
generic_errs
cond_Representable1Ok :: Condition
cond_Representable1Ok :: Condition
cond_Representable1Ok DynFlags
_ DerivInstTys
dit =
case DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics1 DerivInstTys
dit of
Validity' [DeriveGenericsErrReason]
IsValid -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
NotValid [DeriveGenericsErrReason]
generic_errs -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ [DeriveGenericsErrReason] -> DeriveInstanceErrReason
DerivErrGenerics [DeriveGenericsErrReason]
generic_errs
cond_enumOrProduct :: Class -> Condition
cond_enumOrProduct :: Class -> Condition
cond_enumOrProduct Class
cls = Condition
cond_isEnumeration Condition -> Condition -> Condition
`orCond`
(Condition
cond_isProduct Condition -> Condition -> Condition
`andCond` Class -> Condition
cond_args Class
cls)
where
orCond :: Condition -> Condition -> Condition
orCond :: Condition -> Condition -> Condition
orCond Condition
c1 Condition
c2 DynFlags
dflags DerivInstTys
dit
= case (Condition
c1 DynFlags
dflags DerivInstTys
dit, Condition
c2 DynFlags
dflags DerivInstTys
dit) of
(Validity' DeriveInstanceErrReason
IsValid, Validity' DeriveInstanceErrReason
_) -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
(Validity' DeriveInstanceErrReason
_, Validity' DeriveInstanceErrReason
IsValid) -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
(NotValid DeriveInstanceErrReason
x, NotValid DeriveInstanceErrReason
y) -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason
-> DeriveInstanceErrReason -> DeriveInstanceErrReason
DerivErrEnumOrProduct DeriveInstanceErrReason
x DeriveInstanceErrReason
y
cond_args :: Class -> Condition
cond_args :: Class -> Condition
cond_args Class
cls DynFlags
_ dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
= case [Type]
bad_args of
[] -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
(Type
ty:[Type]
_) -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Type -> DeriveInstanceErrReason
DerivErrDunnoHowToDeriveForType Type
ty
where
bad_args :: [Type]
bad_args = [ Type
arg_ty | DataCon
con <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
, Type
arg_ty <- DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
con DerivInstTys
dit
, Type -> Bool
mightBeUnliftedType Type
arg_ty
, Bool -> Bool
not (Type -> Bool
ok_ty Type
arg_ty) ]
cls_key :: Unique
cls_key = Class -> Unique
classKey Class
cls
ok_ty :: Type -> Bool
ok_ty Type
arg_ty
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
eqClassKey = Type
-> [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -> Bool
forall a. Type -> [(Type, a)] -> Bool
check_in Type
arg_ty [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ordClassKey = Type
-> [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -> Bool
forall a. Type -> [(Type, a)] -> Bool
check_in Type
arg_ty [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
showClassKey = Type
-> [(Type,
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Bool
forall a. Type -> [(Type, a)] -> Bool
check_in Type
arg_ty [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
[(Type,
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs))]
boxConTbl
| Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftClassKey = Bool
True
| Bool
otherwise = Bool
False
check_in :: Type -> [(Type,a)] -> Bool
check_in :: forall a. Type -> [(Type, a)] -> Bool
check_in Type
arg_ty [(Type, a)]
tbl = ((Type, a) -> Bool) -> [(Type, a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
eqType Type
arg_ty (Type -> Bool) -> ((Type, a) -> Type) -> (Type, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, a) -> Type
forall a b. (a, b) -> a
fst) [(Type, a)]
tbl
cond_isEnumeration :: Condition
cond_isEnumeration :: Condition
cond_isEnumeration DynFlags
_ (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
| TyCon -> Bool
isEnumerationTyCon TyCon
rep_tc = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
| Bool
otherwise = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrMustBeEnumType TyCon
rep_tc
cond_isProduct :: Condition
cond_isProduct :: Condition
cond_isProduct DynFlags
_ (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
| Just DataCon
_ <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
rep_tc
= Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
| Bool
otherwise
= DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrMustHaveExactlyOneConstructor TyCon
rep_tc
cond_functorOK :: Bool -> Bool -> Condition
cond_functorOK :: Bool -> Bool -> Condition
cond_functorOK Bool
allowFunctions Bool
allowExQuantifiedLastTyVar DynFlags
_
dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
| [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tc_tvs
= DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrMustHaveSomeParameters TyCon
rep_tc
| Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_stupid_theta)
= DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> DeriveInstanceErrReason
DerivErrMustNotHaveClassContext TyCon
rep_tc [Type]
bad_stupid_theta
| Bool
otherwise
= [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
forall a. [Validity' a] -> Validity' a
allValid ((DataCon -> Validity' DeriveInstanceErrReason)
-> [DataCon] -> [Validity' DeriveInstanceErrReason]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity' DeriveInstanceErrReason
check_con [DataCon]
data_cons)
where
tc_tvs :: [TyVar]
tc_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
last_tv :: TyVar
last_tv = [TyVar] -> TyVar
forall a. HasCallStack => [a] -> a
last [TyVar]
tc_tvs
bad_stupid_theta :: [Type]
bad_stupid_theta = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
is_bad (TyCon -> [Type]
tyConStupidTheta TyCon
rep_tc)
is_bad :: Type -> Bool
is_bad Type
pred = TyVar
last_tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
pred
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
check_con :: DataCon -> Validity' DeriveInstanceErrReason
check_con DataCon
con = [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
forall a. [Validity' a] -> Validity' a
allValid (DataCon -> Validity' DeriveInstanceErrReason
check_universal DataCon
con Validity' DeriveInstanceErrReason
-> [Validity' DeriveInstanceErrReason]
-> [Validity' DeriveInstanceErrReason]
forall a. a -> [a] -> [a]
: FFoldType (Validity' DeriveInstanceErrReason)
-> DataCon -> DerivInstTys -> [Validity' DeriveInstanceErrReason]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs (DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
ft_check DataCon
con) DataCon
con DerivInstTys
dit)
check_universal :: DataCon -> Validity' DeriveInstanceErrReason
check_universal :: DataCon -> Validity' DeriveInstanceErrReason
check_universal DataCon
con
| Bool
allowExQuantifiedLastTyVar
= Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
| Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe ([Type] -> Type
forall a. HasCallStack => [a] -> a
last (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs (DataCon -> Type
dataConOrigResTy DataCon
con)))
, TyVar
tv TyVar -> [TyVar] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DataCon -> [TyVar]
dataConUnivTyVars DataCon
con
, Bool -> Bool
not (TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` [Type] -> VarSet
exactTyCoVarsOfTypes (DataCon -> [Type]
dataConTheta DataCon
con))
= Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
| Bool
otherwise
= DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConExistential DataCon
con]
ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
ft_check DataCon
con = FT { ft_triv :: Validity' DeriveInstanceErrReason
ft_triv = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid, ft_var :: Validity' DeriveInstanceErrReason
ft_var = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
, ft_co_var :: Validity' DeriveInstanceErrReason
ft_co_var = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConCovariant DataCon
con]
, ft_fun :: Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
ft_fun = \Validity' DeriveInstanceErrReason
x Validity' DeriveInstanceErrReason
y -> if Bool
allowFunctions then Validity' DeriveInstanceErrReason
x Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' DeriveInstanceErrReason
y
else DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConFunTypes DataCon
con]
, ft_tup :: TyCon
-> [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
ft_tup = \TyCon
_ [Validity' DeriveInstanceErrReason]
xs -> [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
forall a. [Validity' a] -> Validity' a
allValid [Validity' DeriveInstanceErrReason]
xs
, ft_ty_app :: Type
-> Type
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
ft_ty_app = \Type
_ Type
_ Validity' DeriveInstanceErrReason
x -> Validity' DeriveInstanceErrReason
x
, ft_bad_app :: Validity' DeriveInstanceErrReason
ft_bad_app = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConWrongArg DataCon
con]
, ft_forall :: TyVar
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
ft_forall = \TyVar
_ Validity' DeriveInstanceErrReason
x -> Validity' DeriveInstanceErrReason
x }
checkFlag :: LangExt.Extension -> Condition
checkFlag :: Extension -> Condition
checkFlag Extension
flag DynFlags
dflags DerivInstTys
_
| Extension -> DynFlags -> Bool
xopt Extension
flag DynFlags
dflags = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
| Bool
otherwise = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid DeriveInstanceErrReason
why
where
why :: DeriveInstanceErrReason
why = Extension -> DeriveInstanceErrReason
DerivErrLangExtRequired Extension
the_flag
the_flag :: Extension
the_flag = case [ FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
f | FlagSpec Extension
f <- [FlagSpec Extension]
xFlags , FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag FlagSpec Extension
f Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
== Extension
flag ] of
[Extension
s] -> Extension
s
[Extension]
other -> String -> SDoc -> Extension
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkFlag" ([Extension] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Extension]
other)
std_class_via_coercible :: Class -> Bool
std_class_via_coercible :: Class -> Bool
std_class_via_coercible Class
clas
= Class -> Unique
classKey Class
clas Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
eqClassKey, Unique
ordClassKey, Unique
ixClassKey, Unique
boundedClassKey]
non_coercible_class :: Class -> Bool
non_coercible_class :: Class -> Bool
non_coercible_class Class
cls
= 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
readClassKey, Unique
showClassKey, Unique
dataClassKey
, Unique
genClassKey, Unique
gen1ClassKey, Unique
typeableClassKey
, Unique
traversableClassKey, Unique
liftClassKey ])
newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst
newDerivClsInst :: DerivSpec [Type] -> TcM ClsInst
newDerivClsInst (DS { ds_name :: forall theta. DerivSpec theta -> Name
ds_name = Name
dfun_name, ds_overlap :: forall theta. DerivSpec theta -> Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = [Type]
theta
, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
tys })
= Maybe OverlapMode
-> Name -> [TyVar] -> [Type] -> Class -> [Type] -> TcM ClsInst
newClsInst Maybe OverlapMode
overlap_mode Name
dfun_name [TyVar]
tvs [Type]
theta Class
clas [Type]
tys
extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
extendLocalInstEnv :: forall a. [ClsInst] -> TcM a -> TcM a
extendLocalInstEnv [ClsInst]
dfuns TcM a
thing_inside
= do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let inst_env' :: InstEnv
inst_env' = InstEnv -> [ClsInst] -> InstEnv
extendInstEnvList (TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
env) [ClsInst]
dfuns
env' :: TcGblEnv
env' = TcGblEnv
env { tcg_inst_env = inst_env' }
; TcGblEnv -> TcM a -> TcM a
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' TcM a
thing_inside }