{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.TyCl.Class
( tcClassSigs
, tcClassDecl2
, findMethodBind
, instantiateMethod
, tcClassMinimalDef
, HsSigFun
, mkHsSigFun
, instDeclCtxt1
, instDeclCtxt2
, instDeclCtxt3
, tcATDefault
)
where
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Sig
import GHC.Tc.Types.Evidence ( idHsWrapper )
import GHC.Tc.Gen.Bind
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Core.Type ( piResultTys )
import GHC.Core.Predicate
import GHC.Core.Multiplicity
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
import GHC.Tc.TyCl.Build( TcMethInfo )
import GHC.Core.Class
import GHC.Core.Coercion ( pprCoAxiom )
import GHC.Driver.Session
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Types.Error
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.SourceFile (HscSource(..))
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Data.Maybe
import GHC.Types.Basic
import GHC.Data.Bag
import GHC.Data.BooleanFormula
import Control.Monad
import Data.List ( mapAccumL, partition )
import qualified Data.List.NonEmpty as NE
tcClassSigs :: Name
-> [LSig GhcRn]
-> LHsBinds GhcRn
-> TcM [TcMethInfo]
tcClassSigs :: Name
-> [LSig (GhcPass 'Renamed)]
-> LHsBinds (GhcPass 'Renamed)
-> TcM [TcMethInfo]
tcClassSigs Name
clas [LSig (GhcPass 'Renamed)]
sigs LHsBinds (GhcPass 'Renamed)
def_methods
= do { String -> SDoc -> TcRn ()
traceTc String
"tcClassSigs 1" (forall a. Outputable a => a -> SDoc
ppr Name
clas)
; [(Name, (SrcSpan, Type))]
gen_dm_prs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig) [Located
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
gen_sigs
; let gen_dm_env :: NameEnv (SrcSpan, Type)
gen_dm_env :: NameEnv (SrcSpan, Type)
gen_dm_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, (SrcSpan, Type))]
gen_dm_prs
; [TcMethInfo]
op_info <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM (NameEnv (SrcSpan, Type)
-> ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env)) [Located
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
vanilla_sigs
; let op_names :: NameSet
op_names = [Name] -> NameSet
mkNameSet [ Name
n | (Name
n,Type
_,Maybe (DefMethSpec (SrcSpan, Type))
_) <- [TcMethInfo]
op_info ]
; forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall a. TcRnMessage -> TcM a
failWithTc (Name -> Name -> TcRnMessage
TcRnBadMethodErr Name
clas Name
n)
| Name
n <- [Name]
dm_bind_names, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
op_names) ]
; TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; if TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
then
case forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
def_methods of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
meth : [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
meths -> forall a. TcRnMessage -> TcM a
failWithTc (Name -> NonEmpty (LHsBind (GhcPass 'Renamed)) -> TcRnMessage
TcRnIllegalHsigDefaultMethods Name
clas (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
meth forall a. a -> [a] -> NonEmpty a
NE.:| [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
meths))
else
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall a. TcRnMessage -> TcM a
failWithTc (Name -> Name -> TcRnMessage
TcRnBadGenericMethod Name
clas Name
n)
| (Name
n,(SrcSpan, Type)
_) <- [(Name, (SrcSpan, Type))]
gen_dm_prs, Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dm_bind_names) ]
; String -> SDoc -> TcRn ()
traceTc String
"tcClassSigs 2" (forall a. Outputable a => a -> SDoc
ppr Name
clas)
; forall (m :: * -> *) a. Monad m => a -> m a
return [TcMethInfo]
op_info }
where
vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
vanilla_sigs :: [Located
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
vanilla_sigs = [forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LIdP (GhcPass 'Renamed)]
nm,LHsSigType (GhcPass 'Renamed)
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
False [LIdP (GhcPass 'Renamed)]
nm LHsSigType (GhcPass 'Renamed)
ty) <- [LSig (GhcPass 'Renamed)]
sigs]
gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
gen_sigs :: [Located
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
gen_sigs = [forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LIdP (GhcPass 'Renamed)]
nm,LHsSigType (GhcPass 'Renamed)
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
True [LIdP (GhcPass 'Renamed)]
nm LHsSigType (GhcPass 'Renamed)
ty) <- [LSig (GhcPass 'Renamed)]
sigs]
dm_bind_names :: [Name]
dm_bind_names :: [Name]
dm_bind_names = [Name
op | L SrcSpanAnnA
_ (FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
op}) <- forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
def_methods]
tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
tc_sig :: NameEnv (SrcSpan, Type)
-> ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env ([GenLocated SrcSpanAnnN Name]
op_names, LHsSigType (GhcPass 'Renamed)
op_hs_ty)
= do { String -> SDoc -> TcRn ()
traceTc String
"ClsSig 1" (forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
op_names)
; Type
op_ty <- [GenLocated SrcSpanAnnN Name]
-> LHsSigType (GhcPass 'Renamed) -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
op_names LHsSigType (GhcPass 'Renamed)
op_hs_ty
; String -> SDoc -> TcRn ()
traceTc String
"ClsSig 2" (forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
op_names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return [ (Name
op_name, Type
op_ty, Name -> Maybe (DefMethSpec (SrcSpan, Type))
f Name
op_name) | L SrcSpanAnnN
_ Name
op_name <- [GenLocated SrcSpanAnnN Name]
op_names ] }
where
f :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
f Name
nm | Just (SrcSpan, Type)
lty <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (SrcSpan, Type)
gen_dm_env Name
nm = forall a. a -> Maybe a
Just (forall ty. ty -> DefMethSpec ty
GenericDM (SrcSpan, Type)
lty)
| Name
nm forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dm_bind_names = forall a. a -> Maybe a
Just forall ty. DefMethSpec ty
VanillaDM
| Bool
otherwise = forall a. Maybe a
Nothing
tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig :: ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig ([GenLocated SrcSpanAnnN Name]
op_names, LHsSigType (GhcPass 'Renamed)
gen_hs_ty)
= do { Type
gen_op_ty <- [GenLocated SrcSpanAnnN Name]
-> LHsSigType (GhcPass 'Renamed) -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
op_names LHsSigType (GhcPass 'Renamed)
gen_hs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return [ (Name
op_name, (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc, Type
gen_op_ty))
| L SrcSpanAnnN
loc Name
op_name <- [GenLocated SrcSpanAnnN Name]
op_names ] }
tcClassDecl2 :: LTyClDecl GhcRn
-> TcM (LHsBinds GhcTc)
tcClassDecl2 :: LTyClDecl (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcClassDecl2 (L SrcSpanAnnA
_ (ClassDecl {tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP (GhcPass 'Renamed)
class_name, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig (GhcPass 'Renamed)]
sigs,
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds (GhcPass 'Renamed)
default_binds}))
= forall r. TcRn r -> TcRn r -> TcRn r
recoverM (forall (m :: * -> *) a. Monad m => a -> m a
return forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds) forall a b. (a -> b) -> a -> b
$
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP (GhcPass 'Renamed)
class_name) forall a b. (a -> b) -> a -> b
$
do { Class
clas <- LocatedA Name -> TcM Class
tcLookupLocatedClass (forall a. LocatedN a -> LocatedA a
n2l LIdP (GhcPass 'Renamed)
class_name)
; SkolemInfo
skol_info <- forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
ClassFlavour (forall a. NamedThing a => a -> Name
getName LIdP (GhcPass 'Renamed)
class_name))
; TcLevel
tc_lvl <- TcM TcLevel
getTcLevel
; let ([TcId]
tyvars, [Type]
_, [TcId]
_, [ClassOpItem]
op_items) = Class -> ([TcId], [Type], [TcId], [ClassOpItem])
classBigSig Class
clas
prag_fn :: TcPragEnv
prag_fn = [LSig (GhcPass 'Renamed)]
-> LHsBinds (GhcPass 'Renamed) -> TcPragEnv
mkPragEnv [LSig (GhcPass 'Renamed)]
sigs LHsBinds (GhcPass 'Renamed)
default_binds
sig_fn :: HsSigFun
sig_fn = [LSig (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
sigs
(Subst
_skol_subst, [TcId]
clas_tyvars) = TcLevel -> SkolemInfo -> [TcId] -> (Subst, [TcId])
tcSuperSkolTyVars TcLevel
tc_lvl SkolemInfo
skol_info [TcId]
tyvars
pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas ([TcId] -> [Type]
mkTyVarTys [TcId]
clas_tyvars)
; TcId
this_dict <- forall gbl lcl. Type -> TcRnIf gbl lcl TcId
newEvVar Type
pred
; let tc_item :: ClassOpItem -> TcM (LHsBinds GhcTc)
tc_item = Class
-> [TcId]
-> TcId
-> LHsBinds (GhcPass 'Renamed)
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth Class
clas [TcId]
clas_tyvars TcId
this_dict
LHsBinds (GhcPass 'Renamed)
default_binds HsSigFun
sig_fn TcPragEnv
prag_fn
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds <- forall r. [TcId] -> TcM r -> TcM r
tcExtendTyVarEnv [TcId]
clas_tyvars forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ClassOpItem -> TcM (LHsBinds GhcTc)
tc_item [ClassOpItem]
op_items
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds) }
tcClassDecl2 LTyClDecl (GhcPass 'Renamed)
d = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcClassDecl2" (forall a. Outputable a => a -> SDoc
ppr LTyClDecl (GhcPass 'Renamed)
d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
-> HsSigFun -> TcPragEnv -> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth :: Class
-> [TcId]
-> TcId
-> LHsBinds (GhcPass 'Renamed)
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth Class
_ [TcId]
_ TcId
_ LHsBinds (GhcPass 'Renamed)
_ HsSigFun
_ TcPragEnv
prag_fn (TcId
sel_id, Maybe (Name, DefMethSpec Type)
Nothing)
= do {
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (TcId -> Sig (GhcPass 'Renamed) -> TcRn ()
badDmPrag TcId
sel_id ))
(TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn (TcId -> Name
idName TcId
sel_id))
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Bag a
emptyBag }
tcDefMeth Class
clas [TcId]
tyvars TcId
this_dict LHsBinds (GhcPass 'Renamed)
binds_in HsSigFun
hs_sig_fn TcPragEnv
prag_fn
(TcId
sel_id, Just (Name
dm_name, DefMethSpec Type
dm_spec))
| Just (L SrcSpanAnnA
bind_loc HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
dm_bind, SrcSpan
bndr_loc, [LSig (GhcPass 'Renamed)]
prags) <- Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
(LHsBind (GhcPass 'Renamed), SrcSpan, [LSig (GhcPass 'Renamed)])
findMethodBind Name
sel_name LHsBinds (GhcPass 'Renamed)
binds_in TcPragEnv
prag_fn
= do {
TcId
global_dm_id <- Name -> TcM TcId
tcLookupId Name
dm_name
; TcId
global_dm_id <- TcId -> [LSig (GhcPass 'Renamed)] -> TcM TcId
addInlinePrags TcId
global_dm_id [LSig (GhcPass 'Renamed)]
prags
; Name
local_dm_name <- OccName -> SrcSpan -> TcM Name
newNameAt (forall a. NamedThing a => a -> OccName
getOccName Name
sel_name) SrcSpan
bndr_loc
; [LTcSpecPrag]
spec_prags <- forall a. TcM a -> TcM a
discardConstraints forall a b. (a -> b) -> a -> b
$
TcId -> [LSig (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
global_dm_id [LSig (GhcPass 'Renamed)]
prags
; let dia :: TcRnMessage
dia = Name -> TcRnMessage
TcRnIgnoreSpecialisePragmaOnDefMethod Name
sel_name
; Bool -> TcRnMessage -> TcRn ()
diagnosticTc (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTcSpecPrag]
spec_prags)) TcRnMessage
dia
; let hs_ty :: GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty = HsSigFun
hs_sig_fn Name
sel_name
forall a. Maybe a -> a -> a
`orElse` forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_dm" (forall a. Outputable a => a -> SDoc
ppr Name
sel_name)
local_dm_ty :: Type
local_dm_ty = Class -> TcId -> [Type] -> Type
instantiateMethod Class
clas TcId
global_dm_id ([TcId] -> [Type]
mkTyVarTys [TcId]
tyvars)
lm_bind :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
lm_bind = HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
dm_bind { fun_id :: LIdP (GhcPass 'Renamed)
fun_id = forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
bind_loc) Name
local_dm_name }
warn_redundant :: ReportRedundantConstraints
warn_redundant = case DefMethSpec Type
dm_spec of
GenericDM {} -> LHsSigType (GhcPass 'Renamed) -> ReportRedundantConstraints
lhsSigTypeContextSpan GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty
DefMethSpec Type
VanillaDM -> ReportRedundantConstraints
NoRRC
ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name ReportRedundantConstraints
warn_redundant
; let local_dm_id :: TcId
local_dm_id = HasDebugCallStack => Name -> Type -> Type -> TcId
mkLocalId Name
local_dm_name Type
Many Type
local_dm_ty
local_dm_sig :: TcIdSigInfo
local_dm_sig = CompleteSig { sig_bndr :: TcId
sig_bndr = TcId
local_dm_id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty }
; (TcEvBinds
ev_binds, (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [TcId]
_))
<- forall result.
SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfoAnon
skol_info [TcId]
tyvars [TcId
this_dict] forall a b. (a -> b) -> a -> b
$
TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
no_prag_fn TcIdSigInfo
local_dm_sig
(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
lm_bind)
; let export :: ABExport
export = ABE { abe_poly :: TcId
abe_poly = TcId
global_dm_id
, abe_mono :: TcId
abe_mono = TcId
local_dm_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
IsDefaultMethod }
full_bind :: HsBindLR GhcTc GhcTc
full_bind = forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR forall a b. (a -> b) -> a -> b
$
AbsBinds { abs_tvs :: [TcId]
abs_tvs = [TcId]
tyvars
, abs_ev_vars :: [TcId]
abs_ev_vars = [TcId
this_dict]
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
ev_binds]
, abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Bag a
unitBag (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
full_bind)) }
| Bool
otherwise = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDefMeth" (forall a. Outputable a => a -> SDoc
ppr TcId
sel_id)
where
skol_info :: SkolemInfoAnon
skol_info = TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
ClassFlavour (forall a. NamedThing a => a -> Name
getName Class
clas)
sel_name :: Name
sel_name = TcId -> Name
idName TcId
sel_id
no_prag_fn :: TcPragEnv
no_prag_fn = TcPragEnv
emptyPragEnv
tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef :: Name
-> [LSig (GhcPass 'Renamed)] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef Name
_clas [LSig (GhcPass 'Renamed)]
sigs [TcMethInfo]
op_info
= case [LSig (GhcPass 'Renamed)] -> Maybe ClassMinimalDef
findMinimalDef [LSig (GhcPass 'Renamed)]
sigs of
Maybe ClassMinimalDef
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ClassMinimalDef
defMindef
Just ClassMinimalDef
mindef -> do
TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env forall a. Eq a => a -> a -> Bool
/= HscSource
HsigFile) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied (ClassMinimalDef
mindef forall a. Eq a => BooleanFormula a -> a -> Bool
`impliesAtom`) ClassMinimalDef
defMindef) forall a b. (a -> b) -> a -> b
$
(\ClassMinimalDef
bf -> TcRnMessage -> TcRn ()
addDiagnosticTc (ClassMinimalDef -> TcRnMessage
TcRnWarningMinimalDefIncomplete ClassMinimalDef
bf))
forall (m :: * -> *) a. Monad m => a -> m a
return ClassMinimalDef
mindef
where
defMindef :: ClassMinimalDef
defMindef :: ClassMinimalDef
defMindef = forall a. Eq a => [LBooleanFormula a] -> BooleanFormula a
mkAnd [ forall a an. a -> LocatedAn an a
noLocA (forall a. a -> BooleanFormula a
mkVar Name
name)
| (Name
name, Type
_, Maybe (DefMethSpec (SrcSpan, Type))
Nothing) <- [TcMethInfo]
op_info ]
instantiateMethod :: Class -> TcId -> [TcType] -> TcType
instantiateMethod :: Class -> TcId -> [Type] -> Type
instantiateMethod Class
clas TcId
sel_id [Type]
inst_tys
= forall a. HasCallStack => Bool -> a -> a
assert Bool
ok_first_pred Type
local_meth_ty
where
rho_ty :: Type
rho_ty = HasDebugCallStack => Type -> [Type] -> Type
piResultTys (TcId -> Type
idType TcId
sel_id) [Type]
inst_tys
(Type
first_pred, Type
local_meth_ty) = Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
rho_ty
forall a. Maybe a -> a -> a
`orElse` forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInstanceMethod" (forall a. Outputable a => a -> SDoc
ppr TcId
sel_id)
ok_first_pred :: Bool
ok_first_pred = case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
first_pred of
Just (Class
clas1, [Type]
_tys) -> Class
clas forall a. Eq a => a -> a -> Bool
== Class
clas1
Maybe (Class, [Type])
Nothing -> Bool
False
type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
mkHsSigFun :: [LSig GhcRn] -> HsSigFun
mkHsSigFun :: [LSig (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
sigs = forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
env
where
env :: NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
env = forall a.
(LSig (GhcPass 'Renamed)
-> Maybe ([GenLocated SrcSpanAnnN Name], a))
-> [LSig (GhcPass 'Renamed)] -> NameEnv a
mkHsSigEnv LSig (GhcPass 'Renamed)
-> Maybe
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
get_classop_sig [LSig (GhcPass 'Renamed)]
sigs
get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
get_classop_sig :: LSig (GhcPass 'Renamed)
-> Maybe
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
get_classop_sig (L SrcSpanAnnA
_ (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
_ [LIdP (GhcPass 'Renamed)]
ns LHsSigType (GhcPass 'Renamed)
hs_ty)) = forall a. a -> Maybe a
Just ([LIdP (GhcPass 'Renamed)]
ns, LHsSigType (GhcPass 'Renamed)
hs_ty)
get_classop_sig LSig (GhcPass 'Renamed)
_ = forall a. Maybe a
Nothing
findMethodBind :: Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind :: Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
(LHsBind (GhcPass 'Renamed), SrcSpan, [LSig (GhcPass 'Renamed)])
findMethodBind Name
sel_name LHsBinds (GhcPass 'Renamed)
binds TcPragEnv
prag_fn
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus forall a. Maybe a
Nothing (forall a b. (a -> b) -> Bag a -> Bag b
mapBag GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
f LHsBinds (GhcPass 'Renamed)
binds)
where
prags :: [LSig (GhcPass 'Renamed)]
prags = TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn Name
sel_name
f :: GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
f bind :: GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind@(L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
bndr_loc Name
op_name }))
| Name
op_name forall a. Eq a => a -> a -> Bool
== Name
sel_name
= forall a. a -> Maybe a
Just (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind, forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
bndr_loc, [LSig (GhcPass 'Renamed)]
prags)
f GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_other = forall a. Maybe a
Nothing
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef :: [LSig (GhcPass 'Renamed)] -> Maybe ClassMinimalDef
findMinimalDef = forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LSig (GhcPass 'Renamed) -> Maybe ClassMinimalDef
toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef :: LSig (GhcPass 'Renamed) -> Maybe ClassMinimalDef
toMinimalDef (L SrcSpanAnnA
_ (MinimalSig XMinimalSig (GhcPass 'Renamed)
_ (L SrcSpanAnnL
_ BooleanFormula (LIdP (GhcPass 'Renamed))
bf))) = forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc BooleanFormula (LIdP (GhcPass 'Renamed))
bf)
toMinimalDef LSig (GhcPass 'Renamed)
_ = forall a. Maybe a
Nothing
badDmPrag :: TcId -> Sig GhcRn -> TcM ()
badDmPrag :: TcId -> Sig (GhcPass 'Renamed) -> TcRn ()
badDmPrag TcId
sel_id Sig (GhcPass 'Renamed)
prag
= TcRnMessage -> TcRn ()
addErrTc (TcId -> Sig (GhcPass 'Renamed) -> TcRnMessage
TcRnDefaultMethodForPragmaLacksBinding TcId
sel_id Sig (GhcPass 'Renamed)
prag)
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType (GhcPass 'Renamed) -> SDoc
instDeclCtxt1 LHsSigType (GhcPass 'Renamed)
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType (GhcPass 'Renamed)
hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 Type
dfun_ty
= Class -> [Type] -> SDoc
instDeclCtxt3 Class
cls [Type]
tys
where
([TcId]
_,[Type]
_,Class
cls,[Type]
tys) = Type -> ([TcId], [Type], Class, [Type])
tcSplitDFunTy Type
dfun_ty
instDeclCtxt3 :: Class -> [Type] -> SDoc
instDeclCtxt3 :: Class -> [Type] -> SDoc
instDeclCtxt3 Class
cls [Type]
cls_tys
= SDoc -> SDoc
inst_decl_ctxt (forall a. Outputable a => a -> SDoc
ppr (Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_tys))
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the instance declaration for")
Int
2 (SDoc -> SDoc
quotes SDoc
doc)
tcATDefault :: SrcSpan
-> Subst
-> NameSet
-> ClassATItem
-> TcM [FamInst]
tcATDefault :: SrcSpan -> Subst -> NameSet -> ClassATItem -> TcM [FamInst]
tcATDefault SrcSpan
loc Subst
inst_subst NameSet
defined_ats (ATI TyCon
fam_tc Maybe (Type, ATValidityInfo)
defs)
| TyCon -> Name
tyConName TyCon
fam_tc Name -> NameSet -> Bool
`elemNameSet` NameSet
defined_ats
= forall (m :: * -> *) a. Monad m => a -> m a
return []
| Just (Type
rhs_ty, ATValidityInfo
_loc) <- Maybe (Type, ATValidityInfo)
defs
= do { let (Subst
subst', [Type]
pat_tys') = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Subst -> TcId -> (Subst, Type)
subst_tv Subst
inst_subst
(TyCon -> [TcId]
tyConTyVars TyCon
fam_tc)
rhs' :: Type
rhs' = Subst -> Type -> Type
substTyUnchecked Subst
subst' Type
rhs_ty
tcv' :: [TcId]
tcv' = [Type] -> [TcId]
tyCoVarsOfTypesList [Type]
pat_tys'
([TcId]
tv', [TcId]
cv') = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TcId -> Bool
isTyVar [TcId]
tcv'
tvs' :: [TcId]
tvs' = [TcId] -> [TcId]
scopedSort [TcId]
tv'
cvs' :: [TcId]
cvs' = [TcId] -> [TcId]
scopedSort [TcId]
cv'
; Name
rep_tc_name <- GenLocated SrcSpanAnnN Name -> [Type] -> TcM Name
newFamInstTyConName (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (TyCon -> Name
tyConName TyCon
fam_tc)) [Type]
pat_tys'
; let axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [TcId]
-> [TcId]
-> [TcId]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [TcId]
tvs' [] [TcId]
cvs'
TyCon
fam_tc [Type]
pat_tys' Type
rhs'
; String -> SDoc -> TcRn ()
traceTc String
"mk_deflt_at_instance" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty
, forall (br :: BranchFlag). CoAxiom br -> SDoc
pprCoAxiom CoAxiom Unbranched
axiom ])
; FamInst
fam_inst <- FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom
; forall (m :: * -> *) a. Monad m => a -> m a
return [FamInst
fam_inst] }
| Bool
otherwise
= do { Name -> TcRn ()
warnMissingAT (TyCon -> Name
tyConName TyCon
fam_tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return [] }
where
subst_tv :: Subst -> TcId -> (Subst, Type)
subst_tv Subst
subst TcId
tc_tv
| Just Type
ty <- forall a. VarEnv a -> TcId -> Maybe a
lookupVarEnv (Subst -> TvSubstEnv
getTvSubstEnv Subst
subst) TcId
tc_tv
= (Subst
subst, Type
ty)
| Bool
otherwise
= (Subst -> TcId -> Type -> Subst
extendTvSubst Subst
subst TcId
tc_tv Type
ty', Type
ty')
where
ty' :: Type
ty' = TcId -> Type
mkTyVarTy ((Type -> Type) -> TcId -> TcId
updateTyVarKind (Subst -> Type -> Type
substTyUnchecked Subst
subst) TcId
tc_tv)
warnMissingAT :: Name -> TcM ()
warnMissingAT :: Name -> TcRn ()
warnMissingAT Name
name
= do { Bool
warn <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingMethods
; String -> SDoc -> TcRn ()
traceTc String
"warn" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
warn)
; HscSource
hsc_src <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> HscSource
tcg_src forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let dia :: TcRnMessage
dia = Name -> TcRnMessage
TcRnNoExplicitAssocTypeOrDefaultDeclaration Name
name
; Bool -> TcRnMessage -> TcRn ()
diagnosticTc (Bool
warn Bool -> Bool -> Bool
&& HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile) TcRnMessage
dia
}