{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where
import GHC.Prelude
import GHC.Hs
import GHC.Builtin.Names
import GHC.Core.Class
import GHC.Core.Predicate ( Pred (..), classifyPredType )
import GHC.Data.Maybe ( firstJusts, maybeToList )
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.HsType
import GHC.Tc.Solver.Monad ( runTcS )
import GHC.Tc.Solver.Solve ( solveWanteds )
import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC )
import GHC.Tc.Types.Origin ( CtOrigin(DefaultOrigin) )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType ( newWanted )
import GHC.Tc.Utils.TcType
import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) )
import GHC.Types.SrcLoc
import GHC.Unit.Types (ghcInternalUnit, moduleUnit)
import GHC.Utils.Outputable
import qualified GHC.LanguageExtensions as LangExt
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.Traversable ( for )
tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
tcDefaultDecls [LDefaultDecl GhcRn]
decls =
do
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let here = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
is_internal_unit = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
here Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
ghcInternalUnit
case (is_internal_unit, decls) of
(Bool
_, []) -> [LocatedA ClassDefaults] -> TcM [LocatedA ClassDefaults]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
(Bool
True, [L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
Nothing [])]) -> do
h2010_dflt_clss <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) [Class])
-> NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall (m :: * -> *) (t :: * -> *) b a.
(Applicative m, Foldable t, Monoid b) =>
(a -> m b) -> t a -> m b
foldMapM ((Maybe Class -> [Class])
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
-> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Class -> [Class]
forall a. Maybe a -> [a]
maybeToList (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
-> IOEnv (Env TcGblEnv TcLclEnv) [Class])
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class))
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Class, Messages TcRnMessage) -> Maybe Class)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Class, Messages TcRnMessage) -> Maybe Class
forall a b. (a, b) -> a
fst (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class))
-> (Name
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage))
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRn Class
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc (TcRn Class
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage))
-> (Name -> TcRn Class)
-> Name
-> IOEnv
(Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcRn Class
tcLookupClass) (NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) [Class])
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
-> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
forall {gbl} {lcl}. IOEnv (Env gbl lcl) (NonEmpty Name)
getH2010DefaultNames
case NE.nonEmpty h2010_dflt_clss of
Maybe (NonEmpty Class)
Nothing -> [LocatedA ClassDefaults] -> TcM [LocatedA ClassDefaults]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just NonEmpty Class
h2010_dflt_clss' -> NonEmpty Class
-> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
toClassDefaults NonEmpty Class
h2010_dflt_clss' [LDefaultDecl GhcRn]
decls
(Bool, [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)])
_ -> do
h2010_dflt_clss <- TcM (NonEmpty Class)
getH2010DefaultClasses
toClassDefaults h2010_dflt_clss decls
where
getH2010DefaultClasses :: TcM (NonEmpty Class)
getH2010DefaultClasses :: TcM (NonEmpty Class)
getH2010DefaultClasses = (Name -> TcRn Class) -> NonEmpty Name -> TcM (NonEmpty Class)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Name -> TcRn Class
tcLookupClass (NonEmpty Name -> TcM (NonEmpty Class))
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
-> TcM (NonEmpty Class)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
forall {gbl} {lcl}. IOEnv (Env gbl lcl) (NonEmpty Name)
getH2010DefaultNames
getH2010DefaultNames :: IOEnv (Env gbl lcl) (NonEmpty Name)
getH2010DefaultNames
= do { ovl_str <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
; let deflt_str = if Bool
ovl_str
then [Name
isStringClassName]
else []
; let deflt_interactive = if Bool
ext_deflt
then [Name]
interactiveClassNames
else []
; let extra_clss_names = [Name]
deflt_str [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
deflt_interactive
; return $ numClassName :| extra_clss_names
}
declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type]))
declarationParts :: NonEmpty Class
-> LDefaultDecl GhcRn
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
declarationParts NonEmpty Class
h2010_dflt_clss decl :: LDefaultDecl GhcRn
decl@(L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
mb_cls_name [LHsType GhcRn]
dflt_hs_tys))
= SrcSpan
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) (TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType])))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
forall a b. (a -> b) -> a -> b
$
case Maybe (LIdP GhcRn)
mb_cls_name of
Maybe (LIdP GhcRn)
Nothing ->
do { tau_tys <- ErrCtxtMsg -> TcM [TcType] -> TcM [TcType]
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list :: Bool
ddec_in_type_list = Bool
True })
(TcM [TcType] -> TcM [TcType]) -> TcM [TcType] -> TcM [TcType]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [TcType]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonEmpty Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
check_instance_any NonEmpty Class
h2010_dflt_clss) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
dflt_hs_tys
; return $ Just (Nothing, decl, tau_tys) }
Just LIdP GhcRn
cls_name ->
do { named_deflt <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedDefaults
; checkErr named_deflt (TcRnIllegalNamedDefault decl)
; mb_cls <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = False })
$ tcDefaultDeclClass cls_name
; for mb_cls $ \ Class
cls ->
do { tau_tys <- ErrCtxtMsg -> TcM [TcType] -> TcM [TcType]
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list :: Bool
ddec_in_type_list = Bool
True })
(TcM [TcType] -> TcM [TcType]) -> TcM [TcType] -> TcM [TcType]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [TcType]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonEmpty Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
check_instance_any (Class -> NonEmpty Class
forall a. a -> NonEmpty a
NE.singleton Class
cls)) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
dflt_hs_tys
; return (Just cls, decl, tau_tys)
} }
toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
toClassDefaults :: NonEmpty Class
-> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
toClassDefaults NonEmpty Class
h2010_dflt_clss [LDefaultDecl GhcRn]
dfs = do
dfs <- (GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe
(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
[TcType])))
-> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
[TcType])]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonEmpty Class
-> LDefaultDecl GhcRn
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
declarationParts NonEmpty Class
h2010_dflt_clss) [LDefaultDecl GhcRn]
[GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
dfs
return $ concatMap (go False) dfs
where
go :: Bool
-> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
[TcType])
-> [LocatedA ClassDefaults]
go Bool
h98 = \case
(Maybe Class
Nothing, GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
rn_decl, [TcType]
tys) -> ((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
[TcType])
-> [LocatedA ClassDefaults])
-> [(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
[TcType])]
-> [LocatedA ClassDefaults]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool
-> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
[TcType])
-> [LocatedA ClassDefaults]
go Bool
True) [(Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls, GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
rn_decl, [TcType]
tys) | Class
cls <- NonEmpty Class -> [Class]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Class
h2010_dflt_clss]
(Just Class
cls, (L SrcSpanAnnA
locn DefaultDecl GhcRn
_), [TcType]
tys) -> [(SrcSpanAnnA -> ClassDefaults -> LocatedA ClassDefaults
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locn (ClassDefaults -> LocatedA ClassDefaults)
-> ClassDefaults -> LocatedA ClassDefaults
forall a b. (a -> b) -> a -> b
$ Class
-> [TcType]
-> DefaultProvenance
-> Maybe (WarningTxt GhcRn)
-> ClassDefaults
ClassDefaults Class
cls [TcType]
tys (SrcSpan -> Bool -> DefaultProvenance
DP_Local (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) Bool
h98) Maybe (WarningTxt GhcRn)
forall a. Maybe a
Nothing)]
extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a
extendDefaultEnvWithLocalDefaults :: forall a. [LocatedA ClassDefaults] -> TcM a -> TcM a
extendDefaultEnvWithLocalDefaults [LocatedA ClassDefaults]
decls TcM a
action = do
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let default_env = TcGblEnv -> DefaultEnv
tcg_default TcGblEnv
tcg_env
new_default_env <- insertDefaultDecls default_env decls
updGblEnv (\TcGblEnv
gbl -> TcGblEnv
gbl { tcg_default = new_default_env } ) $ action
insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
insertDefaultDecls = (LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv)
-> DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
insertDefaultDecl
insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
insertDefaultDecl (L SrcSpanAnnA
decl_loc ClassDefaults
new_cls_defaults ) DefaultEnv
default_env =
case DefaultEnv -> Name -> Maybe ClassDefaults
lookupDefaultEnv DefaultEnv
default_env (Class -> Name
className Class
cls) of
Just ClassDefaults
cls_defaults
| DP_Local {} <- ClassDefaults -> DefaultProvenance
cd_provenance ClassDefaults
cls_defaults
-> do { SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
decl_loc) (TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Class -> ClassDefaults -> TcRnMessage
TcRnMultipleDefaultDeclarations Class
cls ClassDefaults
cls_defaults)
; DefaultEnv -> TcM DefaultEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return DefaultEnv
default_env }
Maybe ClassDefaults
_ -> DefaultEnv -> TcM DefaultEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DefaultEnv -> TcM DefaultEnv) -> DefaultEnv -> TcM DefaultEnv
forall a b. (a -> b) -> a -> b
$ ClassDefaults -> DefaultEnv -> DefaultEnv
insertDefaultEnv ClassDefaults
new_cls_defaults DefaultEnv
default_env
where
cls :: Class
cls = ClassDefaults -> Class
cd_class ClassDefaults
new_cls_defaults
check_instance_any :: NonEmpty Class
-> LHsType GhcRn
-> TcM (Maybe Type)
check_instance_any :: NonEmpty Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
check_instance_any NonEmpty Class
deflt_clss LHsType GhcRn
ty
= do { oks <- (Class -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> NonEmpty Class
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty (Maybe TcType))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (\ Class
cls -> Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
simplifyDefault Class
cls LHsType GhcRn
ty) NonEmpty Class
deflt_clss
; case firstJusts oks of
Maybe TcType
Nothing ->
do { TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> NonEmpty Class -> TcRnMessage
TcRnBadDefaultType LHsType GhcRn
ty NonEmpty Class
deflt_clss
; Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TcType
forall a. Maybe a
Nothing }
Just TcType
ty ->
Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
forall a b. (a -> b) -> a -> b
$ TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
ty
}
simplifyDefault
:: Class
-> LHsType GhcRn
-> TcM (Maybe Type)
simplifyDefault :: Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
simplifyDefault Class
cls dflt_ty :: LHsType GhcRn
dflt_ty@(L SrcSpanAnnA
l HsType GhcRn
_)
= do { let app_ty :: LHsType GhcRn
app_ty :: LHsType GhcRn
app_ty = SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
NoExtField
noExtField (PromotionFlag -> IdP GhcRn -> LHsType GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted (Class -> Name
className Class
cls)) LHsType GhcRn
dflt_ty
; (inst_pred, wtds) <- TcM TcType -> TcM (TcType, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM TcType -> TcM (TcType, WantedConstraints))
-> TcM TcType -> TcM (TcType, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcType -> TcM TcType
tcCheckLHsType LHsType GhcRn
app_ty TcType
constraintKind
; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred
; let all_wanteds = WantedConstraints
wtds WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` [CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence
wtd_inst]
; (unsolved, _) <- runTcS $ solveWanteds all_wanteds
; traceTc "simplifyDefault" $
vcat [ text "cls:" <+> ppr cls
, text "dflt_ty:" <+> ppr dflt_ty
, text "inst_pred:" <+> ppr inst_pred
, text "all_wanteds " <+> ppr all_wanteds
, text "unsolved:" <+> ppr unsolved ]
; let is_instance = WantedConstraints -> Bool
isEmptyWC WantedConstraints
unsolved
; return $
if | is_instance
, ClassPred _ tys <- classifyPredType inst_pred
, Just tys_ne <- NE.nonEmpty tys
-> Just $ NE.last tys_ne
| otherwise
-> Nothing
}