module TcClassDcl ( tcClassSigs, tcClassDecl2,
getGenericInstances,
MethodSpec, tcMethodBind, mkMethodBind,
- tcAddDeclCtxt, badMethodErr
+ tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
-import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
+import Inst ( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
import InstEnv ( mkLocalInstance )
import TcEnv ( tcLookupLocatedClass,
tcExtendTyVarEnv, tcExtendIdEnv,
simpleInstInfoTyCon, simpleInstInfoTy,
InstBindings(..), newDFunName
)
-import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..) )
+import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..),
+ TcSigFun, mkTcSigFun )
import TcHsType ( tcHsKindedType, tcHsSigType )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( checkSigTyVars, sigCtxt )
-- default methods. Better to make separate AbsBinds for each
let
(tyvars, _, _, op_items) = classBigSig clas
+ rigid_info = ClsSkol clas
+ origin = SigOrigin rigid_info
prag_fn = mkPragFun sigs
- tc_dm = tcDefMeth clas tyvars default_binds prag_fn
+ sig_fn = mkTcSigFun sigs
+ clas_tyvars = tcSkolSigTyVars rigid_info tyvars
+ tc_dm = tcDefMeth origin clas clas_tyvars
+ default_binds sig_fn prag_fn
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
returnM (listToBag defm_binds, concat dm_ids_s)
-tcDefMeth clas tyvars binds_in prag_fn sel_id
+tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
= do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
- ; let rigid_info = ClsSkol clas
- clas_tyvars = tcSkolSigTyVars rigid_info tyvars
- inst_tys = mkTyVarTys clas_tyvars
+ ; let inst_tys = mkTyVarTys tyvars
dm_ty = idType sel_id -- Same as dict selector!
- theta = [mkClassPred clas inst_tys]
+ cls_pred = mkClassPred clas inst_tys
local_dm_id = mkDefaultMethodId dm_name dm_ty
- origin = SigOrigin rigid_info
; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
- ; [this_dict] <- newDicts origin theta
- ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta
- [this_dict] prag_fn meth_info)
+ ; loc <- getInstLoc origin
+ ; this_dict <- newDictBndr loc cls_pred
+ ; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
+ sig_fn prag_fn meth_info)
; addErrCtxt (defltMethCtxt clas) $ do
-- Check the context
{ dict_binds <- tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
- clas_tyvars
+ tyvars
[this_dict]
insts_needed
-- Simplification can do unification
- ; checkSigTyVars clas_tyvars
+ ; checkSigTyVars tyvars
-- Inline pragmas
-- We'll have an inline pragma on the local binding, made by tcMethodBind
inline_prags = filter isInlineLSig (prag_fn sel_name)
; prags <- tcPrags dm_inst_id inline_prags
- ; let full_bind = AbsBinds clas_tyvars
+ ; let full_bind = AbsBinds tyvars
[instToId this_dict]
- [(clas_tyvars, local_dm_id, dm_inst_id, prags)]
+ [(tyvars, local_dm_id, dm_inst_id, prags)]
(dict_binds `unionBags` defm_bind)
; returnM (noLoc full_bind, [local_dm_id]) }}
-> TcThetaType -- Available theta; it's just used for the error message
-> [Inst] -- Available from context, used to simplify constraints
-- from the method body
- -> TcPragFun -- Pragmas (e.g. inline pragmas)
+ -> TcSigFun -- For scoped tyvars, indexed by sel_name
+ -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
-> MethodSpec -- Details of this method
-> TcM (LHsBinds Id)
-tcMethodBind inst_tyvars inst_theta avail_insts prag_fn
+tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
(sel_id, meth_id, meth_bind)
= recoverM (returnM emptyLHsBinds) $
-- If anything fails, recover returning no bindings.
-- Check the bindings; first adding inst_tyvars to the envt
-- so that we don't quantify over them in nested places
-
- let meth_sig = noLoc (TypeSig (noLoc (idName meth_id)) (noLoc bogus_ty))
- bogus_ty = HsTupleTy Boxed [] -- *Only* used to extract scoped type
- -- variables... and there aren't any
- lookup_sig name = ASSERT( name == idName meth_id )
- Just meth_sig
+ let sel_name = idName sel_id
+ meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name
+ -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
in
tcExtendTyVarEnv inst_tyvars (
tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
addErrCtxt (methodCtxt sel_id) $
getLIE $
- tcMonoBinds [meth_bind] lookup_sig Recursive
+ tcMonoBinds [meth_bind] meth_sig_fn Recursive
) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
-- Now do context reduction. We simplify wrt both the local tyvars
in
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDictsAtLoc (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
+ newDictBndrs (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
let
meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
- sel_name = idName sel_id
in
tcSimplifyCheck
(ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
-- f {| a+b |} ... = ...
-- f {| x+y |} ... = ...
-- Then at this point we'll have an InstInfo for each
+ --
+ -- The class should be unary, which is why simpleInstInfoTyCon should be ok
let
tc_inst_infos :: [(TyCon, InstInfo)]
tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
thing = case decl of
ClassDecl {} -> "class"
TySynonym {} -> "type synonym"
- TyData {tcdND = NewType} -> "newtype"
- TyData {tcdND = DataType} -> "data type"
+ TyFunction {} -> "type function signature"
+ TyData {tcdND = NewType} -> "newtype" ++ maybeSig
+ TyData {tcdND = DataType} -> "data type" ++ maybeSig
+
+ maybeSig | isKindSigDecl decl = " signature"
+ | otherwise = ""
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
+badATErr clas at
+ = hsep [ptext SLIT("Class"), quotes (ppr clas),
+ ptext SLIT("does not have an associated type"), quotes (ppr at)]
+
omittedMethodWarn sel_id
= ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
+omittedATWarn at
+ = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
+
badGenericInstance sel_id because
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
because]
projects / ghc-hetmet.git / blobdiff