module GHC.Tc.TyCl.Class
( tcClassSigs
, tcClassDecl2
, findMethodBind
, instantiateMethod
, tcClassMinimalDef
, HsSigFun
, mkHsSigFun
, badMethodErr
, 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 )
illegalHsigDefaultMethod :: Name -> TcRnMessage
illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $
text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"
tcClassSigs :: Name
-> [LSig GhcRn]
-> LHsBinds GhcRn
-> TcM [TcMethInfo]
tcClassSigs clas sigs def_methods
= do { traceTc "tcClassSigs 1" (ppr clas)
; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs
; let gen_dm_env :: NameEnv (SrcSpan, Type)
gen_dm_env = mkNameEnv gen_dm_prs
; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
; sequence_ [ failWithTc (badMethodErr clas n)
| n <- dm_bind_names, not (n `elemNameSet` op_names) ]
; tcg_env <- getGblEnv
; if tcg_src tcg_env == HsigFile
then
when (not (null def_methods)) $
failWithTc (illegalHsigDefaultMethod clas)
else
sequence_ [ failWithTc (badGenericMethod clas n)
| (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
; traceTc "tcClassSigs 2" (ppr clas)
; return op_info }
where
vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)]
gen_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs]
dm_bind_names :: [Name]
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
tc_sig gen_dm_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
; op_ty <- tcClassSigType op_names op_hs_ty
; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty)
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
| nm `elem` dm_bind_names = Just VanillaDM
| otherwise = Nothing
tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
; return [ (op_name, (locA loc, gen_op_ty))
| L loc op_name <- op_names ] }
tcClassDecl2 :: LTyClDecl GhcRn
-> TcM (LHsBinds GhcTc)
tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
setSrcSpan (getLocA class_name) $
do { clas <- tcLookupLocatedClass (n2l class_name)
; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name))
; tc_lvl <- getTcLevel
; let (tyvars, _, _, op_items) = classBigSig clas
prag_fn = mkPragEnv sigs default_binds
sig_fn = mkHsSigFun sigs
(_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
; let tc_item = tcDefMeth clas clas_tyvars this_dict
default_binds sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_item op_items
; return (unionManyBags dm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
-> HsSigFun -> TcPragEnv -> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
= do {
mapM_ (addLocMA (badDmPrag sel_id))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
(sel_id, Just (dm_name, dm_spec))
| Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
= do {
global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags
; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
; spec_prags <- discardConstraints $
tcSpecPrags global_dm_id prags
; let dia = TcRnUnknownMessage $
mkPlainDiagnostic WarningWithoutFlag noHints $
(text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name))
; diagnosticTc (not (null spec_prags)) dia
; let hs_ty = hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }
warn_redundant = case dm_spec of
GenericDM {} -> lhsSigTypeContextSpan hs_ty
VanillaDM -> NoRRC
ctxt = FunSigCtxt sel_name warn_redundant
; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty
local_dm_sig = CompleteSig { sig_bndr = local_dm_id
, sig_ctxt = ctxt
, sig_loc = getLocA hs_ty }
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars [this_dict] $
tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind)
; let export = ABE { abe_poly = global_dm_id
, abe_mono = local_dm_id
, abe_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
full_bind = XHsBindsLR $
AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
, abs_exports = [export]
, abs_ev_binds = [ev_binds]
, abs_binds = tc_bind
, abs_sig = True }
; return (unitBag (L bind_loc full_bind)) }
| otherwise = pprPanic "tcDefMeth" (ppr sel_id)
where
skol_info = TyConSkol ClassFlavour (getName clas)
sel_name = idName sel_id
no_prag_fn = emptyPragEnv
tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef _clas sigs op_info
= case findMinimalDef sigs of
Nothing -> return defMindef
Just mindef -> do
tcg_env <- getGblEnv
when (tcg_src tcg_env /= HsigFile) $
whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
(\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf))
return mindef
where
defMindef :: ClassMinimalDef
defMindef = mkAnd [ noLocA (mkVar name)
| (name, _, Nothing) <- op_info ]
instantiateMethod :: Class -> TcId -> [TcType] -> TcType
instantiateMethod clas sel_id inst_tys
= assert ok_first_pred local_meth_ty
where
rho_ty = piResultTys (idType sel_id) inst_tys
(first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
`orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
ok_first_pred = case getClassPredTys_maybe first_pred of
Just (clas1, _tys) -> clas == clas1
Nothing -> False
type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
mkHsSigFun :: [LSig GhcRn] -> HsSigFun
mkHsSigFun sigs = lookupNameEnv env
where
env = mkHsSigEnv get_classop_sig sigs
get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
get_classop_sig _ = Nothing
findMethodBind :: Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
findMethodBind sel_name binds prag_fn
= foldl' mplus Nothing (mapBag f binds)
where
prags = lookupPragEnv prag_fn sel_name
f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
| op_name == sel_name
= Just (bind, locA bndr_loc, prags)
f _other = Nothing
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
toMinimalDef _ = Nothing
badMethodErr :: Outputable a => a -> Name -> TcRnMessage
badMethodErr clas op
= TcRnUnknownMessage $ mkPlainError noHints $
hsep [text "Class", quotes (ppr clas),
text "does not have a method", quotes (ppr op)]
badGenericMethod :: Outputable a => a -> Name -> TcRnMessage
badGenericMethod clas op
= TcRnUnknownMessage $ mkPlainError noHints $
hsep [text "Class", quotes (ppr clas),
text "has a generic-default signature without a binding", quotes (ppr op)]
badDmPrag :: TcId -> Sig GhcRn -> TcM ()
badDmPrag sel_id prag
= addErrTc (TcRnUnknownMessage $ mkPlainError noHints $
text "The" <+> hsSigDoc prag <+> text "for default method"
<+> quotes (ppr sel_id)
<+> text "lacks an accompanying binding")
warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage
warningMinimalDefIncomplete mindef
= TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $
vcat [ text "The MINIMAL pragma does not require:"
, nest 2 (pprBooleanFormulaNice mindef)
, text "but there is no default implementation." ]
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 hs_inst_ty
= inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
= instDeclCtxt3 cls tys
where
(_,_,cls,tys) = tcSplitDFunTy dfun_ty
instDeclCtxt3 :: Class -> [Type] -> SDoc
instDeclCtxt3 cls cls_tys
= inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = hang (text "In the instance declaration for")
2 (quotes doc)
tcATDefault :: SrcSpan
-> TCvSubst
-> NameSet
-> ClassATItem
-> TcM [FamInst]
tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
| tyConName fam_tc `elemNameSet` defined_ats
= return []
| Just (rhs_ty, _loc) <- defs
= do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc)
rhs' = substTyUnchecked subst' rhs_ty
tcv' = tyCoVarsOfTypesList pat_tys'
(tv', cv') = partition isTyVar tcv'
tvs' = scopedSort tv'
cvs' = scopedSort cv'
; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys'
; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
fam_tc pat_tys' rhs'
; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
, pprCoAxiom axiom ])
; fam_inst <- newFamInst SynFamilyInst axiom
; return [fam_inst] }
| otherwise
= do { warnMissingAT (tyConName fam_tc)
; return [] }
substATBndrs :: TCvSubst -> [TyVar] -> (TCvSubst, [Type])
substATBndrs = mapAccumL substATBndr
where
substATBndr :: TCvSubst -> TyVar -> (TCvSubst, Type)
substATBndr subst tc_tv
| Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
= (subst, ty)
| otherwise
= (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv')
where
tc_tv' = updateTyVarKind (substTy subst) tc_tv
warnMissingAT :: Name -> TcM ()
warnMissingAT name
= do { warn <- woptM Opt_WarnMissingMethods
; traceTc "warn" (ppr name <+> ppr warn)
; hsc_src <- fmap tcg_src getGblEnv
; let dia = TcRnUnknownMessage $
mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $
(text "No explicit" <+> text "associated type"
<+> text "or default declaration for"
<+> quotes (ppr name))
; diagnosticTc (warn && hsc_src == HsSrcFile) dia
}