X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcClassDcl.lhs;h=9d0fb13c54b82e05318fb1a0e76d991dc17a58ce;hp=14682a295dfce033d00222e85b745e880a692a1b;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 14682a2..9d0fb13 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -7,7 +7,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, getGenericInstances, MethodSpec, tcMethodBind, mkMethodBind, - tcAddDeclCtxt, badMethodErr + tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn ) where #include "HsVersions.h" @@ -16,7 +16,7 @@ import HsSyn 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, @@ -24,7 +24,8 @@ import TcEnv ( tcLookupLocatedClass, 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 ) @@ -245,8 +246,13 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- 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 @@ -259,32 +265,30 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, 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 @@ -295,9 +299,9 @@ tcDefMeth clas tyvars binds_in prag_fn sel_id 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]) }} @@ -332,11 +336,12 @@ tcMethodBind -> 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. @@ -346,19 +351,16 @@ tcMethodBind inst_tyvars inst_theta avail_insts prag_fn -- 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 @@ -374,12 +376,11 @@ tcMethodBind inst_tyvars inst_theta avail_insts prag_fn 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)) @@ -631,6 +632,8 @@ get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) -- 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] @@ -738,8 +741,12 @@ tcAddDeclCtxt decl thing_inside 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))] @@ -754,9 +761,16 @@ badMethodErr clas op = 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]