{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.TyCl.Class
( tcClassSigs
, tcClassDecl2
, findMethodBind
, instantiateMethod
, tcClassMinimalDef
, HsSigFun
, mkHsSigFun
, instDeclCtxt1
, instDeclCtxt2
, instDeclCtxt3
, tcATDefault
, substATBndrs
)
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 ( extendTvSubstWithClone, 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 ( lookupVarEnv )
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" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas)
; [(Name, (SrcSpan, Type))]
gen_dm_prs <- (Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> [Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig) [Located
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
[Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
gen_sigs
; let gen_dm_env :: NameEnv (SrcSpan, Type)
gen_dm_env :: NameEnv (SrcSpan, Type)
gen_dm_env = [(Name, (SrcSpan, Type))] -> NameEnv (SrcSpan, Type)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, (SrcSpan, Type))]
gen_dm_prs
; [TcMethInfo]
op_info <- (Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> TcM [TcMethInfo])
-> [Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
-> TcM [TcMethInfo]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> TcM [TcMethInfo])
-> Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> TcM [TcMethInfo]
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))]
[Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (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 ]
; [IOEnv (Env TcGblEnv TcLclEnv) Any] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any
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 <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; if TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
then
case Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
def_methods of
[] -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 -> TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (Name -> NonEmpty (LHsBind (GhcPass 'Renamed)) -> TcRnMessage
TcRnIllegalHsigDefaultMethods Name
clas (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
meth GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
-> NonEmpty
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
forall a. a -> [a] -> NonEmpty a
NE.:| [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
meths))
else
[IOEnv (Env TcGblEnv TcLclEnv) Any] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any
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 Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dm_bind_names) ]
; String -> SDoc -> TcRn ()
traceTc String
"tcClassSigs 2" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas)
; [TcMethInfo] -> TcM [TcMethInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 = [SrcSpan
-> ([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LIdP (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnN Name]
nm,LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
False [LIdP (GhcPass 'Renamed)]
nm LHsSigType (GhcPass 'Renamed)
ty) <- [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs]
gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
gen_sigs :: [Located
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
gen_sigs = [SrcSpan
-> ([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Located
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LIdP (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnN Name]
nm,LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
True [LIdP (GhcPass 'Renamed)]
nm LHsSigType (GhcPass 'Renamed)
ty) <- [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (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}) <- Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (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" ([GenLocated SrcSpanAnnN Name] -> SDoc
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" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
op_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
; [TcMethInfo] -> TcM [TcMethInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 <- NameEnv (SrcSpan, Type) -> Name -> Maybe (SrcSpan, Type)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (SrcSpan, Type)
gen_dm_env Name
nm = DefMethSpec (SrcSpan, Type) -> Maybe (DefMethSpec (SrcSpan, Type))
forall a. a -> Maybe a
Just ((SrcSpan, Type) -> DefMethSpec (SrcSpan, Type)
forall ty. ty -> DefMethSpec ty
GenericDM (SrcSpan, Type)
lty)
| Name
nm Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
dm_bind_names = DefMethSpec (SrcSpan, Type) -> Maybe (DefMethSpec (SrcSpan, Type))
forall a. a -> Maybe a
Just DefMethSpec (SrcSpan, Type)
forall ty. DefMethSpec ty
VanillaDM
| Bool
otherwise = Maybe (DefMethSpec (SrcSpan, Type))
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
; [(Name, (SrcSpan, Type))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Name
op_name, (SrcSpanAnnN -> SrcSpan
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}))
= TcM (LHsBinds GhcTc)
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnN Name -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
class_name) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$
do { Class
clas <- LocatedA Name -> TcM Class
tcLookupLocatedClass (GenLocated SrcSpanAnnN Name -> LocatedA Name
forall a. LocatedN a -> LocatedA a
n2l LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
class_name)
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
ClassFlavour (GenLocated SrcSpanAnnN Name -> Name
forall a. NamedThing a => a -> Name
getName LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
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 <- Type -> TcRnIf TcGblEnv TcLclEnv TcId
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 <- [TcId]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall r. [TcId] -> TcM r -> TcM r
tcExtendTyVarEnv [TcId]
clas_tyvars (TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))])
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> a -> b
$
(ClassOpItem
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [ClassOpItem]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
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) -> [a] -> m [b]
mapM ClassOpItem -> TcM (LHsBinds GhcTc)
ClassOpItem
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
tc_item [ClassOpItem]
op_items
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds) }
tcClassDecl2 LTyClDecl (GhcPass 'Renamed)
d = String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcClassDecl2" (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LTyClDecl (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (TyClDecl (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 {
(GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)) -> TcRn ())
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Sig (GhcPass 'Renamed) -> TcRn ())
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)) -> TcRn ()
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))
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
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 -> TcRnIf TcGblEnv TcLclEnv TcId
tcLookupId Name
dm_name
; TcId
global_dm_id <- TcId -> [LSig (GhcPass 'Renamed)] -> TcRnIf TcGblEnv TcLclEnv TcId
addInlinePrags TcId
global_dm_id [LSig (GhcPass 'Renamed)]
prags
; Name
local_dm_name <- OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
sel_name) SrcSpan
bndr_loc
; [LTcSpecPrag]
spec_prags <- TcM [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a. TcM a -> TcM a
discardConstraints (TcM [LTcSpecPrag] -> TcM [LTcSpecPrag])
-> TcM [LTcSpecPrag] -> TcM [LTcSpecPrag]
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 ([LTcSpecPrag] -> Bool
forall a. [a] -> Bool
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
Maybe (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
forall a. Maybe a -> a -> a
`orElse` String
-> SDoc -> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_dm" (Name -> SDoc
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 = L (la2na bind_loc) local_dm_name }
warn_redundant :: ReportRedundantConstraints
warn_redundant = case DefMethSpec Type
dm_spec of
GenericDM {} -> LHsSigType (GhcPass 'Renamed) -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType (GhcPass 'Renamed)
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 = (() :: Constraint) => Name -> Type -> Type -> TcId
Name -> Type -> Type -> TcId
mkLocalId Name
local_dm_name Type
ManyTy 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 = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
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]
_))
<- SkolemInfoAnon
-> [TcId]
-> [TcId]
-> TcM (LHsBinds GhcTc, [TcId])
-> TcM (TcEvBinds, (LHsBinds GhcTc, [TcId]))
forall result.
SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfoAnon
skol_info [TcId]
tyvars [TcId
this_dict] (TcM (LHsBinds GhcTc, [TcId])
-> TcM (TcEvBinds, (LHsBinds GhcTc, [TcId])))
-> TcM (LHsBinds GhcTc, [TcId])
-> TcM (TcEvBinds, (LHsBinds GhcTc, [TcId]))
forall a b. (a -> b) -> a -> b
$
TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
no_prag_fn TcIdSigInfo
local_dm_sig
(SrcSpanAnnA
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
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 = XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
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 = LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
full_bind)) }
| Bool
otherwise = String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDefMeth" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
sel_id)
where
skol_info :: SkolemInfoAnon
skol_info = TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
ClassFlavour (Class -> Name
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 -> ClassMinimalDef -> TcM ClassMinimalDef
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassMinimalDef
defMindef
Just ClassMinimalDef
mindef -> do
TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
/= HscSource
HsigFile) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Maybe ClassMinimalDef -> (ClassMinimalDef -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust ((Name -> Bool) -> ClassMinimalDef -> Maybe ClassMinimalDef
forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied (ClassMinimalDef
mindef ClassMinimalDef -> Name -> Bool
forall a. Eq a => BooleanFormula a -> a -> Bool
`impliesAtom`) ClassMinimalDef
defMindef) ((ClassMinimalDef -> TcRn ()) -> TcRn ())
-> (ClassMinimalDef -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(\ClassMinimalDef
bf -> TcRnMessage -> TcRn ()
addDiagnosticTc (ClassMinimalDef -> TcRnMessage
TcRnWarningMinimalDefIncomplete ClassMinimalDef
bf))
ClassMinimalDef -> TcM ClassMinimalDef
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassMinimalDef
mindef
where
defMindef :: ClassMinimalDef
defMindef :: ClassMinimalDef
defMindef = [LBooleanFormula Name] -> ClassMinimalDef
forall a. Eq a => [LBooleanFormula a] -> BooleanFormula a
mkAnd [ ClassMinimalDef -> LBooleanFormula Name
forall a an. a -> LocatedAn an a
noLocA (Name -> ClassMinimalDef
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
= Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert Bool
ok_first_pred Type
local_meth_ty
where
rho_ty :: Type
rho_ty = (() :: Constraint) => Type -> [Type] -> Type
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
Maybe (Type, Type) -> (Type, Type) -> (Type, Type)
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInstanceMethod" (TcId -> SDoc
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 Class -> Class -> Bool
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 = NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Name
-> Maybe (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
env
where
env :: NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
env = (LSig (GhcPass 'Renamed)
-> Maybe
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
-> [LSig (GhcPass 'Renamed)]
-> NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
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))
LSig (GhcPass 'Renamed)
-> Maybe
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (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)) = ([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Maybe
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall a. a -> Maybe a
Just ([LIdP (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnN Name]
ns, LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty)
get_classop_sig LSig (GhcPass 'Renamed)
_ = Maybe
([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
Maybe
([GenLocated SrcSpanAnnN Name],
GenLocated SrcSpanAnnA (HsSigType (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
= (Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Bag
(Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall b a. (b -> a -> b) -> b -> Bag a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. Maybe a
Nothing ((GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> Bag
(Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
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)
Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sel_name
= (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. a -> Maybe a
Just (GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind, SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
bndr_loc, [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
prags)
f GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_other = Maybe
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. Maybe a
Nothing
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef :: [LSig (GhcPass 'Renamed)] -> Maybe ClassMinimalDef
findMinimalDef = [Maybe ClassMinimalDef] -> Maybe ClassMinimalDef
forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts ([Maybe ClassMinimalDef] -> Maybe ClassMinimalDef)
-> ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> [Maybe ClassMinimalDef])
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> Maybe ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
-> Maybe ClassMinimalDef)
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> [Maybe ClassMinimalDef]
forall a b. (a -> b) -> [a] -> [b]
map LSig (GhcPass 'Renamed) -> Maybe ClassMinimalDef
GenLocated SrcSpanAnnA (Sig (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))) = ClassMinimalDef -> Maybe ClassMinimalDef
forall a. a -> Maybe a
Just ((GenLocated SrcSpanAnnN Name -> Name)
-> BooleanFormula (GenLocated SrcSpanAnnN Name) -> ClassMinimalDef
forall a b. (a -> b) -> BooleanFormula a -> BooleanFormula b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc BooleanFormula (LIdP (GhcPass 'Renamed))
BooleanFormula (GenLocated SrcSpanAnnN Name)
bf)
toMinimalDef LSig (GhcPass 'Renamed)
_ = Maybe ClassMinimalDef
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 (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
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 (Type -> SDoc
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
forall doc. IsLine doc => String -> doc
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
= [FamInst] -> TcM [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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') = Subst -> [TcId] -> (Subst, [Type])
substATBndrs 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') = (TcId -> Bool) -> [TcId] -> ([TcId], [TcId])
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 (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
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
forall doc. IsDoc doc => [doc] -> doc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty
, CoAxiom Unbranched -> SDoc
forall (br :: BranchFlag). CoAxiom br -> SDoc
pprCoAxiom CoAxiom Unbranched
axiom ])
; FamInst
fam_inst <- FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom
; [FamInst] -> TcM [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [FamInst
fam_inst] }
| Bool
otherwise
= do { Name -> TcRn ()
warnMissingAT (TyCon -> Name
tyConName TyCon
fam_tc)
; [FamInst] -> TcM [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])
substATBndrs :: Subst -> [TcId] -> (Subst, [Type])
substATBndrs = (Subst -> TcId -> (Subst, Type))
-> Subst -> [TcId] -> (Subst, [Type])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Subst -> TcId -> (Subst, Type)
substATBndr
where
substATBndr :: Subst -> TyVar -> (Subst, Type)
substATBndr :: Subst -> TcId -> (Subst, Type)
substATBndr Subst
subst TcId
tc_tv
| Just Type
ty <- VarEnv Type -> TcId -> Maybe Type
forall a. VarEnv a -> TcId -> Maybe a
lookupVarEnv (Subst -> VarEnv Type
getTvSubstEnv Subst
subst) TcId
tc_tv
= (Subst
subst, Type
ty)
| Bool
otherwise
= (Subst -> TcId -> TcId -> Subst
extendTvSubstWithClone Subst
subst TcId
tc_tv TcId
tc_tv', TcId -> Type
mkTyVarTy TcId
tc_tv')
where
tc_tv' :: TcId
tc_tv' = (Type -> Type) -> TcId -> TcId
updateTyVarKind ((() :: Constraint) => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) TcId
tc_tv
warnMissingAT :: Name -> TcM ()
warnMissingAT :: Name -> TcRn ()
warnMissingAT Name
name
= do { Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingMethods
; String -> SDoc -> TcRn ()
traceTc String
"warn" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
warn)
; HscSource
hsc_src <- (TcGblEnv -> HscSource)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) HscSource
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 TcGblEnv -> HscSource
tcg_src TcRnIf TcGblEnv TcLclEnv TcGblEnv
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 HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile) TcRnMessage
dia
}