X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=00c1087e27f47f37aba2be2c651390322f32fd21;hb=d0f325ce37d6ee322168e44392f10e0ed52f8294;hp=39ac7de4372ab1f9190c40f8144959cf34588efe;hpb=e1fc52f6868619bbeafaced910c50a304db5e0f9;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 39ac7de..00c1087e 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -15,15 +15,16 @@ import HsPragmas ( ClassPragmas(..) ) import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RenamedClassOpSig(..), RenamedMonoBinds, - RenamedContext(..), RenamedHsDecl + RenamedContext(..), RenamedHsDecl, RenamedSig ) import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod ) import TcEnv ( TcIdOcc(..), tcAddImportedIdInfo, tcLookupClass, tcLookupTyVar, - tcExtendGlobalTyVars ) -import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, TcSigInfo(..) ) + tcExtendGlobalTyVars, tcExtendLocalValEnv + ) +import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..) ) import TcKind ( unifyKinds, TcKind ) import TcMonad import TcMonoType ( tcHsType, tcContext ) @@ -31,15 +32,15 @@ import TcSimplify ( tcSimplifyAndCheck ) import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars, zonkSigTyVar, tcInstSigTcType ) -import PragmaInfo ( PragmaInfo(..) ) - +import FieldLabel ( firstFieldLabelTag ) import Bag ( unionManyBags ) import Class ( mkClass, classBigSig, Class ) import CmdLineOpts ( opt_GlasgowExts ) +import MkId ( mkDataCon, mkSuperDictSelId, + mkMethodSelId, mkDefaultMethodId + ) import Id ( Id, StrictnessMark(..), - mkSuperDictSelId, mkMethodSelId, - mkDefaultMethodId, getIdUnfolding, mkDataCon, - idType + getIdUnfolding, idType, idName ) import CoreUnfold ( getUnfoldingTemplate ) import IdInfo @@ -59,7 +60,7 @@ import Maybes ( assocMaybe, maybeToBool ) -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `setSpecInfo` spec, +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo, noIdInfo) \end{code} @@ -188,7 +189,7 @@ tcClassContext rec_class rec_tyvars context pragmas -- D_sc1, D_sc2 -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - mapTc mk_super_id (sc_theta `zip` [1..]) `thenTc` \ sc_sel_ids -> + mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids -> -- Done returnTc (sc_theta, sc_tys, sc_sel_ids) @@ -403,28 +404,27 @@ tcDefaultMethodBinds clas default_binds -- Typecheck the default bindings let - tc_dm meth_bind - | not (maybeToBool maybe_stuff) - = -- Binding for something that isn't in the class signature - failWithTc (badMethodErr bndr_name clas) - - | otherwise - = -- Normal case - tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind + tc_dm meth_bind + = case [pair | pair@(sel_id,_) <- sel_ids_w_dms, + idName sel_id == bndr_name] of + + [] -> -- Binding for something that isn't in the class signature + failWithTc (badMethodErr bndr_name clas) + + ((sel_id, Just dm_id):_) -> + -- We're looking at a default-method binding, so the dm_id + -- is sure to be there! Hence the inner "Just". + -- Normal case + + tcMethodBind clas origin inst_tys clas_tyvars + sel_id meth_bind [{- No prags -}] `thenTc` \ (bind, insts, (_, local_dm_id)) -> - returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id)) + returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id)) where bndr_name = case meth_bind of FunMonoBind name _ _ _ -> name PatMonoBind (VarPatIn name) _ _ -> name - maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name) - assoc_list = [ (getOccName sel_id, pair) - | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids - ] - Just (sel_id, Just dm_id) = maybe_stuff - -- We're looking at a default-method binding, so the dm_id - -- is sure to be there! Hence the inner "Just". in mapAndUnzip3Tc tc_dm (flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) -> @@ -453,6 +453,7 @@ tcDefaultMethodBinds clas default_binds where (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas + sel_ids_w_dms = op_sel_ids `zip` defm_ids origin = ClassDeclOrigin flatten EmptyMonoBinds rest = rest @@ -475,20 +476,31 @@ tcMethodBind -- want to check that they don't bound -> Id -- The method selector -> RenamedMonoBinds -- Method binding (just one) + -> [RenamedSig] -- Pramgas (just for this one) -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) -tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind +tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags = tcAddSrcLoc src_loc $ - newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) -> - tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> + newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) -> + tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> let (theta', tau') = splitRhoTy rho_ty' - sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc + sig_info = TySigInfo meth_name meth_id tyvars' theta' tau' src_loc + meth_name = idName meth_id + meth_bind' = case meth_bind of + FunMonoBind _ fix matches loc -> FunMonoBind meth_name fix matches loc + PatMonoBind (VarPatIn _) rhs loc -> PatMonoBind (VarPatIn meth_name) rhs loc + -- The renamer just puts the selector ID as the binder in the method binding + -- but we must use the method name; so we substitute it here. Crude but simple. in + tcExtendLocalValEnv [meth_name] [meth_id] ( + tcPragmaSigs prags + ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) -> + tcExtendGlobalTyVars inst_tyvars ( tcAddErrCtxt (methodCtxt sel_id) $ - tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info] - NonRecursive (\_ -> NoPragmaInfo) + tcBindWithSigs NotTopLevel [meth_name] meth_bind' [sig_info] + NonRecursive prag_info_fn ) `thenTc` \ (binds, insts, _) -> -- Now check that the instance type variables @@ -496,14 +508,16 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind -- have not been unified with anything in the environment tcAddErrCtxt (monoCtxt sel_id) ( tcAddErrCtxt (sigCtxt sel_id) $ - checkSigTyVars inst_tyvars (idType local_meth_id) + checkSigTyVars inst_tyvars (idType meth_id) ) `thenTc_` - returnTc (binds, insts, meth) + returnTc (binds `AndMonoBinds` prag_binds, + insts `plusLIE` prag_lie, + meth) where - (bndr_name, src_loc) = case meth_bind of - FunMonoBind name _ _ loc -> (name, loc) - PatMonoBind (VarPatIn name) _ loc -> (name, loc) + src_loc = case meth_bind of + FunMonoBind name _ _ loc -> loc + PatMonoBind (VarPatIn name) _ loc -> loc \end{code} Contexts and errors