module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
tcClassMinimalDef,
HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
) where
#include "HsVersions.h"
import HsSyn
import TcEnv
import TcPat( addInlinePrags )
import TcEvidence( HsWrapper, idHsWrapper )
import TcBinds
import TcUnify
import TcHsType
import TcMType
import Type ( getClassPredTys_maybe )
import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
import Class
import Id
import Name
import NameEnv
import NameSet
import Var
import Outputable
import SrcLoc
import Maybes
import BasicTypes
import Bag
import FastString
import BooleanFormula
import Util
import Control.Monad
tcClassSigs :: Name
-> [LSig Name]
-> LHsBinds Name
-> TcM ([TcMethInfo],
NameEnv Type)
tcClassSigs clas sigs def_methods
= do { traceTc "tcClassSigs 1" (ppr clas)
; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
; let gen_dm_env = mkNameEnv gen_dm_prs
; op_info <- concat <$> mapM (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) ]
; sequence_ [ failWithTc (badGenericMethod clas n)
| (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
; traceTc "tcClassSigs 2" (ppr clas)
; return (op_info, gen_dm_env) }
where
vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty _) <- sigs]
gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
dm_bind_names :: [Name]
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
tc_sig genop_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
; op_ty <- tcClassSigType op_hs_ty
; traceTc "ClsSig 2" (ppr op_names)
; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
where
f nm | nm `elemNameEnv` genop_env = GenericDM
| nm `elem` dm_bind_names = VanillaDM
| otherwise = NoDM
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType gen_hs_ty
; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
tcClassDecl2 :: LTyClDecl Name
-> TcM (LHsBinds Id)
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
setSrcSpan loc $
do { clas <- tcLookupLocatedClass class_name
; let
(tyvars, _, _, op_items) = classBigSig clas
prag_fn = mkPragFun sigs default_binds
sig_fn = mkHsSigFun sigs
clas_tyvars = snd (tcSuperSkolTyVars tyvars)
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
this_dict default_binds
sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_dm op_items
; return (unionManyBags dm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> HsSigFun -> PragFun -> ClassOpItem
-> TcM (LHsBinds TcId)
tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
; return emptyBag }
DefMeth dm_name -> tc_dm dm_name
GenDefMeth dm_name -> tc_dm dm_name
where
sel_name = idName sel_id
prags = prag_fn sel_name
(dm_bind,bndr_loc) = findMethodBind sel_name binds_in
`orElse` pprPanic "tcDefMeth" (ppr sel_id)
tc_dm dm_name
= do { dm_id <- tcLookupId dm_name
; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
; dm_id_w_inline <- addInlinePrags dm_id prags
; spec_prags <- tcSpecPrags dm_id prags
; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
hs_ty = lookupHsSig hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
; warnTc (not (null spec_prags))
(ptext (sLit "Ignoring SPECIALISE pragmas on default method")
<+> quotes (ppr sel_name))
; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
dm_id_w_inline local_dm_sig idHsWrapper
IsDefaultMethod dm_bind
; return (unitBag tc_bind) }
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-> Id -> TcSigInfo
-> HsWrapper
-> TcSpecPrags -> LHsBind Name
-> TcM (LHsBind Id)
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
meth_id local_meth_sig wrapper
specs (L loc bind)
= do { let local_meth_id = case local_meth_sig of
TcSigInfo{ sig_id = meth_id } -> meth_id
_ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
; (ev_binds, (tc_bind, _, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
; let export = ABE { abe_wrap = wrapper, abe_poly = meth_id
, abe_mono = local_meth_id, abe_prags = specs }
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = ev_binds
, abs_binds = tc_bind }
; return (L loc full_bind) }
where
no_prag_fn _ = []
tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef _clas sigs op_info
= case findMinimalDef sigs of
Nothing -> return defMindef
Just mindef -> do
whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
(\bf -> addWarnTc (warningMinimalDefIncomplete bf))
return mindef
where
defMindef :: ClassMinimalDef
defMindef = mkAnd [ mkVar name
| (name, NoDM, _) <- op_info
, not (startsWithUnderscore (getOccName name)) ]
instantiateMethod :: Class -> Id -> [TcType] -> TcType
instantiateMethod clas sel_id inst_tys
= ASSERT( ok_first_pred ) local_meth_ty
where
(sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
rho_ty = ASSERT( length sel_tyvars == length inst_tys )
substTyWith sel_tyvars inst_tys sel_rho
(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 = NameEnv (LHsType Name)
emptyHsSigs :: HsSigFun
emptyHsSigs = emptyNameEnv
mkHsSigFun :: [LSig Name] -> HsSigFun
mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
| L _ (TypeSig ns hs_ty _) <- sigs
, L _ n <- ns ]
lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
lookupHsSig = lookupNameEnv
findMethodBind :: Name
-> LHsBinds Name
-> Maybe (LHsBind Name, SrcSpan)
findMethodBind sel_name binds
= foldlBag mplus Nothing (mapBag f binds)
where
f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
| op_name == sel_name
= Just (bind, bndr_loc)
f _other = Nothing
findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf)
toMinimalDef _ = Nothing
tcMkDeclCtxt :: TyClDecl Name -> SDoc
tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
= addErrCtxt (tcMkDeclCtxt decl) thing_inside
badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr clas op
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have a method"), quotes (ppr op)]
badGenericMethod :: Outputable a => a -> Name -> SDoc
badGenericMethod clas op
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
badDmPrag :: Id -> Sig Name -> TcM ()
badDmPrag sel_id prag
= addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
<+> quotes (ppr sel_id)
<+> ptext (sLit "lacks an accompanying binding"))
warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete mindef
= vcat [ ptext (sLit "The MINIMAL pragma does not require:")
, nest 2 (pprBooleanFormulaNice mindef)
, ptext (sLit "but there is no default implementation.") ]