{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.TyCl.Class
( tcClassSigs
, tcClassDecl2
, findMethodBind
, instantiateMethod
, tcClassMinimalDef
, HsSigFun
, mkHsSigFun
, badMethodErr
, instDeclCtxt1
, instDeclCtxt2
, instDeclCtxt3
, tcATDefault
)
where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Hs
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.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.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Data.Maybe
import GHC.Types.Basic
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.BooleanFormula
import GHC.Utils.Misc
import Control.Monad
import Data.List ( mapAccumL, partition )
illegalHsigDefaultMethod :: Name -> SDoc
illegalHsigDefaultMethod :: Name -> SDoc
illegalHsigDefaultMethod Name
n =
String -> SDoc
text String
"Illegal default method(s) in class definition of" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in hsig file"
tcClassSigs :: Name
-> [LSig GhcRn]
-> LHsBinds GhcRn
-> TcM [TcMethInfo]
tcClassSigs :: Name -> [LSig GhcRn] -> LHsBinds GhcRn -> TcM [TcMethInfo]
tcClassSigs Name
clas [LSig GhcRn]
sigs LHsBinds GhcRn
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
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> [Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM ([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
([LocatedN Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig) [Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))]
[Located ([LocatedN Name], LHsSigType GhcRn)]
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
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> TcM [TcMethInfo])
-> [Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))]
-> TcM [TcMethInfo]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> TcM [TcMethInfo])
-> Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> TcM [TcMethInfo]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM (NameEnv (SrcSpan, Type)
-> ([LocatedN Name], LHsSigType GhcRn) -> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env)) [Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))]
[Located ([LocatedN Name], LHsSigType GhcRn)]
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_ [ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
forall a. Outputable a => a -> Name -> SDoc
badMethodErr 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
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
def_methods)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (Name -> SDoc
illegalHsigDefaultMethod Name
clas)
else
[IOEnv (Env TcGblEnv TcLclEnv) Any] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
forall a. Outputable a => a -> Name -> SDoc
badGenericMethod Name
clas Name
n)
| (Name
n,(SrcSpan, Type)
_) <- [(Name, (SrcSpan, Type))]
gen_dm_prs, Bool -> Bool
not (Name
n Name -> [Name] -> 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 (m :: * -> *) a. Monad m => a -> m a
return [TcMethInfo]
op_info }
where
vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
vanilla_sigs = [SrcSpan
-> ([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LocatedN Name]
[LIdP GhcRn]
nm,GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig GhcRn
_ Bool
False [LIdP GhcRn]
nm LHsSigType GhcRn
ty) <- [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
sigs]
gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
gen_sigs = [SrcSpan
-> ([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> Located
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LocatedN Name]
[LIdP GhcRn]
nm,GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig GhcRn
_ Bool
True [LIdP GhcRn]
nm LHsSigType GhcRn
ty) <- [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
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 _ op}) <- Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
def_methods]
tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
tc_sig :: NameEnv (SrcSpan, Type)
-> ([LocatedN Name], LHsSigType GhcRn) -> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env ([LocatedN Name]
op_names, LHsSigType GhcRn
op_hs_ty)
= do { String -> SDoc -> TcRn ()
traceTc String
"ClsSig 1" ([LocatedN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocatedN Name]
op_names)
; Type
op_ty <- [LocatedN Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType [LocatedN Name]
op_names LHsSigType GhcRn
op_hs_ty
; String -> SDoc -> TcRn ()
traceTc String
"ClsSig 2" ([LocatedN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocatedN Name]
op_names SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
; [TcMethInfo] -> TcM [TcMethInfo]
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 <- [LocatedN 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 (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 :: ([LocatedN Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig ([LocatedN Name]
op_names, LHsSigType GhcRn
gen_hs_ty)
= do { Type
gen_op_ty <- [LocatedN Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType [LocatedN Name]
op_names LHsSigType GhcRn
gen_hs_ty
; [(Name, (SrcSpan, Type))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
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 <- [LocatedN Name]
op_names ] }
tcClassDecl2 :: LTyClDecl GhcRn
-> TcM (LHsBinds GhcTc)
tcClassDecl2 :: LTyClDecl GhcRn -> TcM (LHsBinds GhcTc)
tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds) (TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LocatedN Name -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedN Name
LIdP GhcRn
class_name) (TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a b. (a -> b) -> a -> b
$
do { Class
clas <- LocatedA Name -> TcM Class
tcLookupLocatedClass (LocatedN Name -> LocatedA Name
forall a. LocatedN a -> LocatedA a
n2l LocatedN Name
LIdP GhcRn
class_name)
; let ([TyVar]
tyvars, [Type]
_, [TyVar]
_, [ClassOpItem]
op_items) = Class -> ([TyVar], [Type], [TyVar], [ClassOpItem])
classBigSig Class
clas
prag_fn :: TcPragEnv
prag_fn = [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs LHsBinds GhcRn
default_binds
sig_fn :: HsSigFun
sig_fn = [LSig GhcRn] -> HsSigFun
mkHsSigFun [LSig GhcRn]
sigs
clas_tyvars :: [TyVar]
clas_tyvars = (TCvSubst, [TyVar]) -> [TyVar]
forall a b. (a, b) -> b
snd ([TyVar] -> (TCvSubst, [TyVar])
tcSuperSkolTyVars [TyVar]
tyvars)
pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas ([TyVar] -> [Type]
mkTyVarTys [TyVar]
clas_tyvars)
; TyVar
this_dict <- Type -> TcRnIf TcGblEnv TcLclEnv TyVar
forall gbl lcl. Type -> TcRnIf gbl lcl TyVar
newEvVar Type
pred
; let tc_item :: ClassOpItem -> TcM (LHsBinds GhcTc)
tc_item = Class
-> [TyVar]
-> TyVar
-> LHsBinds GhcRn
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth Class
clas [TyVar]
clas_tyvars TyVar
this_dict
LHsBinds GhcRn
default_binds HsSigFun
sig_fn TcPragEnv
prag_fn
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds <- [TyVar]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
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
-> TcRn (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)
mapM ClassOpItem
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
ClassOpItem -> TcM (LHsBinds GhcTc)
tc_item [ClassOpItem]
op_items
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
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 GhcRn
d = String
-> SDoc
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcClassDecl2" (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (TyClDecl GhcRn)
LTyClDecl GhcRn
d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
-> HsSigFun -> TcPragEnv -> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth :: Class
-> [TyVar]
-> TyVar
-> LHsBinds GhcRn
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth Class
_ [TyVar]
_ TyVar
_ LHsBinds GhcRn
_ HsSigFun
_ TcPragEnv
prag_fn (TyVar
sel_id, Maybe (Name, DefMethSpec Type)
Nothing)
= do {
(GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn ())
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Sig GhcRn -> TcRn ())
-> GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn ()
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (TyVar -> Sig GhcRn -> TcRn ()
badDmPrag TyVar
sel_id))
(TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn (TyVar -> Name
idName TyVar
sel_id))
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag }
tcDefMeth Class
clas [TyVar]
tyvars TyVar
this_dict LHsBinds GhcRn
binds_in HsSigFun
hs_sig_fn TcPragEnv
prag_fn
(TyVar
sel_id, Just (Name
dm_name, DefMethSpec Type
dm_spec))
| Just (L bind_loc dm_bind, SrcSpan
bndr_loc, [LSig GhcRn]
prags) <- Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind Name
sel_name LHsBinds GhcRn
binds_in TcPragEnv
prag_fn
= do {
TyVar
global_dm_id <- Name -> TcRnIf TcGblEnv TcLclEnv TyVar
tcLookupId Name
dm_name
; TyVar
global_dm_id <- TyVar -> [LSig GhcRn] -> TcRnIf TcGblEnv TcLclEnv TyVar
addInlinePrags TyVar
global_dm_id [LSig GhcRn]
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
$
TyVar -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TyVar
global_dm_id [LSig GhcRn]
prags
; DiagnosticReason -> Bool -> SDoc -> TcRn ()
diagnosticTc DiagnosticReason
WarningWithoutFlag
(Bool -> Bool
not ([LTcSpecPrag] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTcSpecPrag]
spec_prags))
(String -> SDoc
text String
"Ignoring SPECIALISE pragmas on default method"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
sel_name))
; let hs_ty :: GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty = HsSigFun
hs_sig_fn Name
sel_name
Maybe (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
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 -> TyVar -> [Type] -> Type
instantiateMethod Class
clas TyVar
global_dm_id ([TyVar] -> [Type]
mkTyVarTys [TyVar]
tyvars)
lm_bind :: HsBindLR GhcRn GhcRn
lm_bind = HsBindLR GhcRn GhcRn
dm_bind { fun_id :: LIdP GhcRn
fun_id = SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
bind_loc) Name
local_dm_name }
warn_redundant :: Bool
warn_redundant = case DefMethSpec Type
dm_spec of
GenericDM {} -> Bool
True
DefMethSpec Type
VanillaDM -> Bool
False
ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
warn_redundant
; let local_dm_id :: TyVar
local_dm_id = HasDebugCallStack => Name -> Type -> Type -> TyVar
Name -> Type -> Type -> TyVar
mkLocalId Name
local_dm_name Type
Many Type
local_dm_ty
local_dm_sig :: TcIdSigInfo
local_dm_sig = CompleteSig :: TyVar -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
CompleteSig { sig_bndr :: TyVar
sig_bndr = TyVar
local_dm_id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty }
; (TcEvBinds
ev_binds, (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [TyVar]
_))
<- SkolemInfo
-> [TyVar]
-> [TyVar]
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TyVar])
-> TcM
(TcEvBinds,
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TyVar]))
forall result.
SkolemInfo
-> [TyVar] -> [TyVar] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfo
skol_info [TyVar]
tyvars [TyVar
this_dict] (TcM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TyVar])
-> TcM
(TcEvBinds,
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TyVar])))
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TyVar])
-> TcM
(TcEvBinds,
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TyVar]))
forall a b. (a -> b) -> a -> b
$
TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TyVar])
tcPolyCheck NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
TcPragEnv
no_prag_fn TcIdSigInfo
local_dm_sig
(SrcSpanAnnA
-> HsBindLR GhcRn GhcRn
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcRn GhcRn
lm_bind)
; let export :: ABExport GhcTc
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_poly :: IdP GhcTc
abe_poly = TyVar
IdP GhcTc
global_dm_id
, abe_mono :: IdP GhcTc
abe_mono = TyVar
IdP GhcTc
local_dm_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
IsDefaultMethod }
full_bind :: HsBindLR GhcTc GhcTc
full_bind = AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TyVar]
-> [TyVar]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds GhcTc GhcTc
abs_ext = NoExtField
XAbsBinds GhcTc GhcTc
noExtField
, abs_tvs :: [TyVar]
abs_tvs = [TyVar]
tyvars
, abs_ev_vars :: [TyVar]
abs_ev_vars = [TyVar
this_dict]
, abs_exports :: [ABExport GhcTc]
abs_exports = [ABExport GhcTc
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
ev_binds]
, abs_binds :: LHsBinds GhcTc
abs_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
LHsBinds GhcTc
tc_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
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
-> TcRn (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDefMeth" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
ClassFlavour (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
clas)
sel_name :: Name
sel_name = TyVar -> Name
idName TyVar
sel_id
no_prag_fn :: TcPragEnv
no_prag_fn = TcPragEnv
emptyPragEnv
tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef Name
_clas [LSig GhcRn]
sigs [TcMethInfo]
op_info
= case [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef [LSig GhcRn]
sigs of
Maybe ClassMinimalDef
Nothing -> ClassMinimalDef -> TcM ClassMinimalDef
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 -> DiagnosticReason -> SDoc -> TcRn ()
addDiagnosticTc DiagnosticReason
WarningWithoutFlag (ClassMinimalDef -> SDoc
warningMinimalDefIncomplete ClassMinimalDef
bf))
ClassMinimalDef -> TcM ClassMinimalDef
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 -> TyVar -> [Type] -> Type
instantiateMethod Class
clas TyVar
sel_id [Type]
inst_tys
= ASSERT( ok_first_pred ) local_meth_ty
where
rho_ty :: Type
rho_ty = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyVar -> Type
idType TyVar
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" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
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 GhcRn] -> HsSigFun
mkHsSigFun [LSig GhcRn]
sigs = NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> Name -> Maybe (GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
env
where
env :: NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
env = (LSig GhcRn
-> Maybe
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn)))
-> [LSig GhcRn]
-> NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall a.
(LSig GhcRn -> Maybe ([LocatedN Name], a))
-> [LSig GhcRn] -> NameEnv a
mkHsSigEnv LSig GhcRn
-> Maybe
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
get_classop_sig [LSig GhcRn]
sigs
get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = ([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> Maybe
([LocatedN Name], GenLocated SrcSpanAnnA (HsSigType GhcRn))
forall a. a -> Maybe a
Just ([LocatedN Name]
[LIdP GhcRn]
ns, GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
hs_ty)
get_classop_sig LSig GhcRn
_ = Maybe ([LocatedN Name], LHsSigType GhcRn)
forall a. Maybe a
Nothing
findMethodBind :: Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind :: Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind Name
sel_name LHsBinds GhcRn
binds TcPragEnv
prag_fn
= (Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)]))
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Bag
(Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)]))
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
forall a. Maybe a
Nothing ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)]))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag
(Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)]))
forall a b. (a -> b) -> Bag a -> Bag b
mapBag GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
f Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
binds)
where
prags :: [LSig GhcRn]
prags = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
sel_name
f :: GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
f bind :: GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind@(L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L bndr_loc op_name }))
| Name
op_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sel_name
= (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind, SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
bndr_loc, [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
prags)
f GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
_other = Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
[GenLocated SrcSpanAnnA (Sig GhcRn)])
forall a. Maybe a
Nothing
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = [Maybe ClassMinimalDef] -> Maybe ClassMinimalDef
forall a. [Maybe a] -> Maybe a
firstJusts ([Maybe ClassMinimalDef] -> Maybe ClassMinimalDef)
-> ([GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [Maybe ClassMinimalDef])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Maybe ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Sig GhcRn) -> Maybe ClassMinimalDef)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> [Maybe ClassMinimalDef]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Sig GhcRn) -> Maybe ClassMinimalDef
LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = ClassMinimalDef -> Maybe ClassMinimalDef
forall a. a -> Maybe a
Just ((LocatedN Name -> Name)
-> BooleanFormula (LocatedN Name) -> ClassMinimalDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc BooleanFormula (LocatedN Name)
BooleanFormula (LIdP GhcRn)
bf)
toMinimalDef LSig GhcRn
_ = Maybe ClassMinimalDef
forall a. Maybe a
Nothing
badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr :: a -> Name -> SDoc
badMethodErr a
clas Name
op
= [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Class", SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
clas),
String -> SDoc
text String
"does not have a method", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
op)]
badGenericMethod :: Outputable a => a -> Name -> SDoc
badGenericMethod :: a -> Name -> SDoc
badGenericMethod a
clas Name
op
= [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Class", SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
clas),
String -> SDoc
text String
"has a generic-default signature without a binding", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
op)]
badDmPrag :: TcId -> Sig GhcRn -> TcM ()
badDmPrag :: TyVar -> Sig GhcRn -> TcRn ()
badDmPrag TyVar
sel_id Sig GhcRn
prag
= SDoc -> TcRn ()
addErrTc (String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Sig GhcRn -> SDoc
forall name. Sig name -> SDoc
hsSigDoc Sig GhcRn
prag SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"for default method")
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"lacks an accompanying binding")
warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete ClassMinimalDef
mindef
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The MINIMAL pragma does not require:"
, Int -> SDoc -> SDoc
nest Int
2 (ClassMinimalDef -> SDoc
forall a. Outputable a => BooleanFormula a -> SDoc
pprBooleanFormulaNice ClassMinimalDef
mindef)
, String -> SDoc
text String
"but there is no default implementation." ]
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 Type
dfun_ty
= Class -> [Type] -> SDoc
instDeclCtxt3 Class
cls [Type]
tys
where
([TyVar]
_,[Type]
_,Class
cls,[Type]
tys) = Type -> ([TyVar], [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
text String
"In the instance declaration for")
Int
2 (SDoc -> SDoc
quotes SDoc
doc)
tcATDefault :: SrcSpan
-> TCvSubst
-> NameSet
-> ClassATItem
-> TcM [FamInst]
tcATDefault :: SrcSpan -> TCvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
tcATDefault SrcSpan
loc TCvSubst
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 (m :: * -> *) a. Monad m => a -> m a
return []
| Just (Type
rhs_ty, ATValidityInfo
_loc) <- Maybe (Type, ATValidityInfo)
defs
= do { let (TCvSubst
subst', [Type]
pat_tys') = (TCvSubst -> TyVar -> (TCvSubst, Type))
-> TCvSubst -> [TyVar] -> (TCvSubst, [Type])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TCvSubst -> TyVar -> (TCvSubst, Type)
subst_tv TCvSubst
inst_subst
(TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc)
rhs' :: Type
rhs' = TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst' Type
rhs_ty
tcv' :: [TyVar]
tcv' = [Type] -> [TyVar]
tyCoVarsOfTypesList [Type]
pat_tys'
([TyVar]
tv', [TyVar]
cv') = (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyVar -> Bool
isTyVar [TyVar]
tcv'
tvs' :: [TyVar]
tvs' = [TyVar] -> [TyVar]
scopedSort [TyVar]
tv'
cvs' :: [TyVar]
cvs' = [TyVar] -> [TyVar]
scopedSort [TyVar]
cv'
; Name
rep_tc_name <- LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (SrcSpanAnnN -> Name -> LocatedN 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
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [TyVar]
tvs' [] [TyVar]
cvs'
TyCon
fam_tc [Type]
pat_tys' Type
rhs'
; String -> SDoc -> TcRn ()
traceTc String
"mk_deflt_at_instance" ([SDoc] -> SDoc
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 (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 (m :: * -> *) a. Monad m => a -> m a
return [] }
where
subst_tv :: TCvSubst -> TyVar -> (TCvSubst, Type)
subst_tv TCvSubst
subst TyVar
tc_tv
| Just Type
ty <- VarEnv Type -> TyVar -> Maybe Type
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv (TCvSubst -> VarEnv Type
getTvSubstEnv TCvSubst
subst) TyVar
tc_tv
= (TCvSubst
subst, Type
ty)
| Bool
otherwise
= (TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubst TCvSubst
subst TyVar
tc_tv Type
ty', Type
ty')
where
ty' :: Type
ty' = TyVar -> Type
mkTyVarTy ((Type -> Type) -> TyVar -> TyVar
updateTyVarKind (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst) TyVar
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
<+> 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 (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
; DiagnosticReason -> Bool -> SDoc -> TcRn ()
diagnosticTc (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingMethods) (Bool
warn Bool -> Bool -> Bool
&& HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile)
(String -> SDoc
text String
"No explicit" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"associated type"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"or default declaration for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)) }