X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=f0eb0befa12e79dd54090f3038daec867cb3e47b;hb=d4e0a55c3761544989209a2180d6d0489470db3d;hp=721ea2a28de18292d8703ce6baa8a9d139386f1c;hpb=ab8279d659dd0fccd8738735c11f8a0767505570;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 721ea2a..f0eb0be 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,7 +4,7 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, +module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, tcMethodBind, checkFromThisClass ) where @@ -12,9 +12,10 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSs(..), - HsExpr(..), HsLit(..), HsType(..), pprClassAssertion, - unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName, - isClassDecl, isClassOpSig, collectMonoBinders + HsExpr(..), HsLit(..), HsType(..), HsPred(..), + pprHsClassAssertion, unguardedRHS, + andMonoBinds, andMonoBindList, getTyVarName, + isClassDecl, isClassOpSig, isPragSig, collectMonoBinders ) import HsPragmas ( ClassPragmas(..) ) import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) ) @@ -22,43 +23,44 @@ import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas, RenamedClassOpSig, RenamedMonoBinds, RenamedContext, RenamedHsDecl, RenamedSig ) -import TcHsSyn ( TcMonoBinds ) +import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) -import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod ) +import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) +import TcTyDecls ( mkNewTyConRep ) import TcUnify ( unifyKinds ) import TcMonad -import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope, +import TcMonoType ( kcHsType, tcHsTopType, tcExtendTopTyVarScope, tcContext, checkSigTyVars, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar ) +import TcInstUtil ( classDataCon ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import FieldLabel ( firstFieldLabelTag ) import Bag ( unionManyBags, bagToList ) -import Class ( mkClass, classBigSig, Class ) +import Class ( mkClass, classBigSig, classSelIds, Class, ClassOpItem ) import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) -import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId ) -import DataCon ( mkDataCon, notMarkedStrict ) -import Id ( Id, - getIdUnfolding, idType, idName - ) -import CoreUnfold ( getUnfoldingTemplate ) +import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) +import DataCon ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict ) +import Id ( Id, setInlinePragma, idUnfolding, idType, idName ) +import CoreUnfold ( unfoldingTemplate ) import IdInfo import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) import NameSet ( emptyNameSet ) import Outputable -import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, - mkSigmaTy, mkForAllTys, Type, ThetaType, +import Type ( Type, ThetaType, ClassContext, + mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, + mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds, boxedTypeKind, mkArrowKind ) import Var ( tyVarKind, TyVar ) -import VarSet ( mkVarSet ) -import TyCon ( mkAlgTyCon ) +import VarSet ( mkVarSet, emptyVarSet ) +import TyCon ( AlgTyConFlavour(..), mkClassTyCon ) import Unique ( Unique, Uniquable(..) ) import Util import Maybes ( seqMaybe ) @@ -108,8 +110,8 @@ Death to "ExpandingDicts". \begin{code} kcClassDecl (ClassDecl context class_name - tyvar_names class_sigs def_methods pragmas - tycon_name datacon_name sc_sel_names src_loc) + tyvar_names fundeps class_sigs def_methods pragmas + _ _ _ _ src_loc) = -- CHECK ARITY 1 FOR HASKELL 1.4 checkTc (opt_GlasgowExts || length tyvar_names == 1) (classArityErr class_name) `thenTc_` @@ -127,7 +129,7 @@ kcClassDecl (ClassDecl context class_name where the_class_sigs = filter isClassOpSig class_sigs - kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty) + kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty) \end{code} @@ -140,8 +142,8 @@ kcClassDecl (ClassDecl context class_name \begin{code} tcClassDecl1 rec_env rec_inst_mapper rec_vrcs (ClassDecl context class_name - tyvar_names class_sigs def_methods pragmas - tycon_name datacon_name sc_sel_names src_loc) + tyvar_names fundeps class_sigs def_methods pragmas + tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) = -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) -> tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ -> @@ -153,6 +155,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) -> -- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_` + -- CHECK THE FUNCTIONAL DEPENDENCIES, + tcFundeps fundeps `thenTc` \ fds -> + -- CHECK THE CLASS SIGNATURES, mapTc (tcClassSig rec_env rec_class tyvars) (filter isClassOpSig class_sigs) @@ -160,17 +165,17 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs -- MAKE THE CLASS OBJECT ITSELF let - (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff + (op_tys, op_items) = unzip sig_stuff rec_class_inst_env = rec_inst_mapper rec_class - clas = mkClass class_name tyvars - sc_theta sc_sel_ids op_sel_ids defm_ids + clas = mkClass class_name tyvars fds + sc_theta sc_sel_ids op_items tycon rec_class_inst_env dict_component_tys = sc_tys ++ op_tys new_or_data = case dict_component_tys of - [_] -> NewType - other -> DataType + [_] -> NewTyCon (mkNewTyConRep tycon) + other -> DataTyCon dict_con = mkDataCon datacon_name [notMarkedStrict | _ <- dict_component_tys] @@ -179,33 +184,44 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs [{-No context-}] [{-No existential tyvars-}] [{-Or context-}] dict_component_tys - tycon dict_con_id - dict_con_id = mkDataConId dict_con + tycon dict_con_id dict_wrap_id + + dict_con_id = mkDataConId datacon_wkr_name dict_con + dict_wrap_id = mkDataConWrapId dict_con argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $ ppr tycon_name) tycon_name - tycon = mkAlgTyCon tycon_name - class_kind - tyvars - [] -- No context - argvrcs - [dict_con] -- Constructors - [] -- No derivings - (Just clas) -- Yes! It's a dictionary - new_or_data - NonRecursive + tycon = mkClassTyCon tycon_name + class_kind + tyvars + argvrcs + dict_con -- Constructors + clas -- Yes! It's a dictionary + new_or_data in returnTc clas \end{code} +\begin{code} +tcFundeps = mapTc tc_fundep +tc_fundep (us, vs) = + mapTc tc_fd_tyvar us `thenTc` \ us' -> + mapTc tc_fd_tyvar vs `thenTc` \ vs' -> + returnTc (us', vs') +tc_fd_tyvar v = + tcLookupTy v `thenTc` \(_, _, thing) -> + case thing of + ATyVar tv -> returnTc tv + -- ZZ else should fail more gracefully +\end{code} \begin{code} tcClassContext :: Name -> Class -> [TyVar] -> RenamedContext -- class context -> [Name] -- Names for superclass selectors - -> TcM s (ThetaType, -- the superclass context + -> TcM s (ClassContext, -- the superclass context [Type], -- types of the superclass dictionaries [Id]) -- superclass selector Ids @@ -224,11 +240,12 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names tcContext context `thenTc` \ sc_theta -> let - sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta] + sc_theta' = classesOfPreds sc_theta + sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta'] sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys in -- Done - returnTc (sc_theta, sc_tys, sc_sel_ids) + returnTc (sc_theta', sc_tys, sc_sel_ids) where rec_tyvar_tys = mkTyVarTys rec_tyvars @@ -239,8 +256,8 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names ty = mkForAllTys rec_tyvars $ mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty - check_constraint (c, tys) = checkTc (all is_tyvar tys) - (superClassErr class_name (c, tys)) + check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys) + (superClassErr class_name (c, tys)) is_tyvar (MonoTyVar _) = True is_tyvar other = False @@ -251,13 +268,12 @@ tcClassSig :: ValueEnv -- Knot tying only! -> [TyVar] -- The class type variable, used for error check only -> RenamedClassOpSig -> TcM s (Type, -- Type of the method - Id, -- selector id - Maybe Id) -- default-method ids + ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding + tcClassSig rec_env rec_clas rec_clas_tyvars - (ClassOpSig op_name maybe_dm_name - op_ty - src_loc) + (ClassOpSig op_name dm_name explicit_dm + op_ty src_loc) = tcAddSrcLoc src_loc $ -- Check the type signature. NB that the envt *already has* @@ -269,20 +285,16 @@ tcClassSig rec_env rec_clas rec_clas_tyvars tcHsTopType op_ty `thenTc` \ local_ty -> let global_ty = mkSigmaTy rec_clas_tyvars - [(rec_clas, mkTyVarTys rec_clas_tyvars)] + [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)] local_ty -- Build the selector id and default method id sel_id = mkDictSelId op_name rec_clas global_ty - maybe_dm_id = case maybe_dm_name of - Nothing -> Nothing - Just dm_name -> let - dm_id = mkDefaultMethodId dm_name rec_clas global_ty - in - Just (tcAddImportedIdInfo rec_env dm_id) + dm_id = mkDefaultMethodId dm_name rec_clas global_ty + final_dm_id = tcAddImportedIdInfo rec_env dm_id in -- traceTc (text "tcClassSig done" <+> ppr op_name) `thenTc_` - returnTc (local_ty, sel_id, maybe_dm_id) + returnTc (local_ty, (sel_id, final_dm_id, explicit_dm)) \end{code} @@ -330,7 +342,7 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> NF_TcM s (LIE, TcMonoBinds) tcClassDecl2 (ClassDecl context class_name - tyvar_names class_sigs default_binds pragmas _ _ _ src_loc) + tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc) | not (isLocallyDefined class_name) = returnNF_Tc (emptyLIE, EmptyMonoBinds) @@ -338,22 +350,27 @@ tcClassDecl2 (ClassDecl context class_name | otherwise -- It is locally defined = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc src_loc $ - - -- Get the relevant class tcLookupClass class_name `thenNF_Tc` \ clas -> - let - (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas + tcDefaultMethodBinds clas default_binds class_sigs +\end{code} +\begin{code} +mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds) +mkImplicitClassBinds classes + = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s) -- The selector binds are already in the selector Id's unfoldings - sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id)) - | sel_id <- sc_sel_ids ++ op_sel_ids - ] - in - -- Generate bindings for the default methods - tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) -> + where + (cls_ids_s, binds_s) = unzip (map mk_implicit classes) + + mk_implicit clas = (all_cls_ids, binds) + where + dict_con = classDataCon clas + all_cls_ids = dataConId dict_con : cls_ids + cls_ids = dataConWrapId dict_con : classSelIds clas - returnTc (const_insts, - meth_binds `AndMonoBinds` andMonoBindList sel_binds) + -- The wrapper and selectors get bindings, the worker does not + binds | isLocallyDefined clas = idsToMonoBinds cls_ids + | otherwise = EmptyMonoBinds \end{code} %************************************************************************ @@ -378,23 +395,11 @@ we get the default methods: defm.Foo.op1 :: forall a. Foo a => a -> Bool defm.Foo.op1 = /\a -> \dfoo -> \x -> True -====================== OLD ================== -\begin{verbatim} -defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b -defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z -> - if (op1 a dfoo x) && (< b dord y z) then y else z -\end{verbatim} -Notice that, like all ids, the foralls of defm.Foo.op2 are at the top. -====================== END OF OLD =================== - -NEW: -\begin{verbatim} defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z -> if (op1 a dfoo x) && (< b dord y z) then y else z \end{verbatim} - When we come across an instance decl, we may need to use the default methods: \begin{verbatim} @@ -433,70 +438,81 @@ dfun.Foo.List tcDefaultMethodBinds :: Class -> RenamedMonoBinds + -> [RenamedSig] -> TcM s (LIE, TcMonoBinds) -tcDefaultMethodBinds clas default_binds - = -- Construct suitable signatures - tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> +tcDefaultMethodBinds clas default_binds sigs + = -- Check that the default bindings come from this class + checkFromThisClass clas op_items default_binds `thenNF_Tc_` - -- Check that the default bindings come from this class - checkFromThisClass clas op_sel_ids default_binds `thenNF_Tc_` - - -- Typecheck the default bindings - let - theta = [(clas,inst_tys)] - tc_dm sel_id_w_dm@(_, Just dm_id) - = tcMethodBind clas origin clas_tyvars inst_tys theta - default_binds [{-no prags-}] False - sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) -> - returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id)) - in - tcExtendTyVarEnvForMeths tyvars clas_tyvars ( - mapAndUnzip3Tc tc_dm sel_ids_w_dms - ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) -> - - - -- Check the context - newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) -> - let - avail_insts = this_dict - in - tcAddErrCtxt (defltMethCtxt clas) $ - - -- tcMethodBind has checked that the class_tyvars havn't - -- been unified with each other or another type, but we must - -- still zonk them before passing them to tcSimplifyAndCheck - mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' -> - - tcSimplifyAndCheck - (ptext SLIT("class") <+> ppr clas) - (mkVarSet clas_tyvars') - avail_insts - (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) -> - - let - full_binds = AbsBinds - clas_tyvars' - [this_dict_id] - abs_bind_stuff - emptyNameSet -- No inlines (yet) - (dict_binds `andMonoBinds` andMonoBindList defm_binds) - in - returnTc (const_lie, full_binds) + -- Do each default method separately + -- For Hugs compatibility we make a default-method for every + -- class op, regardless of whether or not the programmer supplied an + -- explicit default decl for the class. GHC will actually never + -- call the default method for such operations, because it'll whip up + -- a more-informative default method at each instance decl. + mapAndUnzipTc tc_dm op_items `thenTc` \ (defm_binds, const_lies) -> + returnTc (plusLIEs const_lies, andMonoBindList defm_binds) where - (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas + prags = filter isPragSig sigs - sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids] - -- Just the ones for which there is an explicit - -- user default declaration + (tyvars, _, _, op_items) = classBigSig clas origin = ClassDeclOrigin + + -- We make a separate binding for each default method. + -- At one time I used a single AbsBinds for all of them, thus + -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } + -- But that desugars into + -- ds = \d -> (..., ..., ...) + -- dm1 = \d -> case ds d of (a,b,c) -> a + -- And since ds is big, it doesn't get inlined, so we don't get good + -- default methods. Better to make separate AbsBinds for each + + tc_dm op_item@(_, dm_id, _) + = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> + let + theta = [(mkClassPred clas inst_tys)] + in + newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + let + avail_insts = this_dict + in + tcExtendTyVarEnvForMeths tyvars clas_tyvars ( + tcMethodBind clas origin clas_tyvars inst_tys theta + default_binds prags False + op_item + ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) -> + + tcAddErrCtxt (defltMethCtxt clas) $ + + -- tcMethodBind has checked that the class_tyvars havn't + -- been unified with each other or another type, but we must + -- still zonk them before passing them to tcSimplifyAndCheck + mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' -> + + -- Check the context + tcSimplifyAndCheck + (ptext SLIT("class") <+> ppr clas) + (mkVarSet clas_tyvars') + avail_insts + insts_needed `thenTc` \ (const_lie, dict_binds) -> + + let + full_bind = AbsBinds + clas_tyvars' + [this_dict_id] + [(clas_tyvars', dm_id, local_dm_id)] + emptyNameSet -- No inlines (yet) + (dict_binds `andMonoBinds` defm_bind) + in + returnTc (full_bind, const_lie) \end{code} \begin{code} -checkFromThisClass :: Class -> [Id] -> RenamedMonoBinds -> NF_TcM s () -checkFromThisClass clas op_sel_ids mono_binds +checkFromThisClass :: Class -> [ClassOpItem] -> RenamedMonoBinds -> NF_TcM s () +checkFromThisClass clas op_items mono_binds = mapNF_Tc check_from_this_class bndrs `thenNF_Tc_` returnNF_Tc () where @@ -504,7 +520,7 @@ checkFromThisClass clas op_sel_ids mono_binds | nameOccName bndr `elem` sel_names = returnNF_Tc () | otherwise = tcAddSrcLoc loc $ addErrTc (badMethodErr bndr clas) - sel_names = map getOccName op_sel_ids + sel_names = [getOccName sel_id | (sel_id,_,_) <- op_items] bndrs = bagToList (collectMonoBinders mono_binds) \end{code} @@ -528,15 +544,13 @@ tcMethodBind -- the caller; here, it's just used for the error message -> RenamedMonoBinds -- Method binding (pick the right one from in here) -> [RenamedSig] -- Pramgas (just for this one) - -> Bool -- True <=> supply default decl if no explicit decl - -- This is true for instance decls, - -- false for class decls - -> (Id, Maybe Id) -- The method selector and default-method Id + -> Bool -- True <=> This method is from an instance declaration + -> ClassOpItem -- The method selector and default-method Id -> TcM s (TcMonoBinds, LIE, (LIE, TcId)) tcMethodBind clas origin inst_tyvars inst_tys inst_theta - meth_binds prags supply_default_bind - (sel_id, maybe_dm_id) + meth_binds prags is_inst_decl + (sel_id, dm_id, explicit_dm) = tcGetSrcLoc `thenNF_Tc` \ loc -> newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) -> @@ -547,7 +561,6 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta maybe_user_bind = find_bind meth_name meth_binds no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False} - no_user_default = case maybe_dm_id of {Nothing -> True; other -> False} meth_bind = case maybe_user_bind of Just bind -> bind @@ -557,10 +570,7 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta in -- Warn if no method binding, only if -fwarn-missing-methods - if no_user_bind && not supply_default_bind then - pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys) - else - warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default) + warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm) (omittedMethodWarn sel_id clas) `thenNF_Tc_` -- Check the bindings; first add inst_tyvars to the envt @@ -586,15 +596,14 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta -- Now check that the instance type variables -- (or, in the case of a class decl, the class tyvars) -- have not been unified with anything in the environment - tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id))) $ - checkSigTyVars inst_tyvars `thenTc_` + tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $ + checkSigTyVars inst_tyvars emptyVarSet `thenTc_` returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, insts `plusLIE` prag_lie', meth) where - sig_msg ty = sep [ptext SLIT("When checking the expected type for"), - nest 4 (ppr sel_name <+> dcolon <+> ppr ty)] + sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name sel_name = idName sel_id @@ -614,10 +623,10 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta find_prags meth_name [] = [] find_prags meth_name (SpecSig name ty loc : prags) | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags - find_prags meth_name (InlineSig name loc : prags) - | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags - find_prags meth_name (NoInlineSig name loc : prags) - | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags + find_prags meth_name (InlineSig name phase loc : prags) + | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags + find_prags meth_name (NoInlineSig name phase loc : prags) + | name == sel_name = NoInlineSig meth_name phase loc : find_prags meth_name prags find_prags meth_name (prag:prags) = find_prags meth_name prags mk_default_bind local_meth_name loc @@ -626,9 +635,8 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta loc default_expr loc - = case maybe_dm_id of - Just dm_id -> HsVar (getName dm_id) -- There's a default method - Nothing -> error_expr loc -- No default method + | explicit_dm = HsVar (getName dm_id) -- There's a default method + | otherwise = error_expr loc -- No default method error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) (HsLit (HsString (_PK_ (error_msg loc)))) @@ -643,7 +651,7 @@ classArityErr class_name = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name) superClassErr class_name sc - = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc) + = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc) <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) defltMethCtxt class_name