X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=c28bce15cc561b645fc23a7936c8d9161c623391;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=e5cb1f3372044e599cbdc38040e9d525615fe1ba;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index e5cb1f3..c28bce1 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -6,59 +6,99 @@ \begin{code} #include "HsVersions.h" -module TcClassDcl ( - tcClassDecl1, tcClassDecls2 - ) where +module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where -import Ubiq +IMP_Ubiq() -import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), - Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), - HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, - Stmt, Qual, ArithSeqInfo, InPat, Fake ) +import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), + Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), + DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity, + HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, + Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake ) +import HsTypes ( getTyVarName ) import HsPragmas ( ClassPragmas(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), - RenamedClassOpSig(..), RenamedMonoBinds(..), - RenamedGenPragmas(..), RenamedContext(..) ) -import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..), - mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId ) - -import TcMonad -import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts ) -import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds) + RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds), + RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl) + ) +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr), + mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) + +import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod ) +import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo, + tcExtendGlobalTyVars ) import TcInstDcls ( processInstBinds ) -import TcKind ( unifyKind ) -import TcMonoType ( tcMonoType, tcContext ) -import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars ) -import TcKind ( TcKind ) - -import Bag ( foldBag ) -import Class ( GenClass, mkClass, mkClassOp, getClassBigSig, - getClassOps, getClassOpString, getClassOpLocalType ) -import CoreUtils ( escErrorMsg ) -import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, +import TcKind ( unifyKind, TcKind ) +import TcMonad +import TcMonoType ( tcHsType, tcContext ) +import TcSimplify ( tcSimplifyAndCheck ) +import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType ) + +import Bag ( foldBag, unionManyBags ) +import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig, + classOps, classOpString, classOpLocalType, + classOpTagByOccName, SYN_IE(ClassOp) + ) +import Id ( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding, idType ) -import IdInfo ( noIdInfo ) -import Name ( Name, getNameFullName, getTagFromClassOpName ) -import PrelVals ( pAT_ERROR_ID ) +import CoreUnfold ( getUnfoldingTemplate ) +import IdInfo +import Name ( Name, isLocallyDefined, moduleString, modAndOcc, nameString ) +import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty import PprType ( GenType, GenTyVar, GenClassOp ) -import SpecEnv ( SpecEnv(..) ) +import SpecEnv ( SpecEnv ) import SrcLoc ( mkGeneratedSrcLoc ) import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkForAllTy, mkSigmaTy, splitSigmaTy) import TysWiredIn ( stringTy ) -import TyVar ( GenTyVar ) +import TyVar ( unitTyVarSet, GenTyVar ) import Unique ( Unique ) import Util + -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo) - +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, + noIdInfo) \end{code} + + +Dictionary handling +~~~~~~~~~~~~~~~~~~~ +Every class implicitly declares a new data type, corresponding to dictionaries +of that class. So, for example: + + class (D a) => C a where + op1 :: a -> a + op2 :: forall b. Ord b => a -> b -> b + +would implicitly declare + + data CDict a = CDict (D a) + (a -> a) + (forall b. Ord b => a -> b -> b) + +(We could use a record decl, but that means changing more of the existing apparatus. +One step at at time!) + +For classes with just one superclass+method, we use a newtype decl instead: + + class C a where + op :: forallb. a -> b -> b + +generates + + newtype CDict a = CDict (forall b. a -> b -> b) + +Now DictTy in Type is just a form of type synomym: + DictTy c t = TyConTy CDict `AppTy` t + +Death to "ExpandingDicts". + + \begin{code} tcClassDecl1 rec_inst_mapper (ClassDecl context class_name @@ -67,8 +107,8 @@ tcClassDecl1 rec_inst_mapper tcAddErrCtxt (classDeclCtxt class_name) $ -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) -> - tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> + tcLookupClass class_name `thenTc` \ (class_kind, rec_class) -> + tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> let (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class in @@ -85,10 +125,9 @@ tcClassDecl1 rec_inst_mapper `thenTc` \ sig_stuff -> -- MAKE THE CLASS OBJECT ITSELF - tcGetUnique `thenNF_Tc` \ uniq -> let (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff - clas = mkClass uniq (getNameFullName class_name) rec_tyvar + clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar scs sc_sel_ids ops op_sel_ids defm_ids rec_class_inst_env in @@ -96,6 +135,32 @@ tcClassDecl1 rec_inst_mapper \end{code} + let + clas_ty = mkTyVarTy clas_tyvar + dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++ + [classOpLocalType op | op <- ops]) + new_or_data = case dict_component_tys of + [_] -> NewType + other -> DataType + + dict_con_id = mkDataCon class_name + [NotMarkedStrict] + [{- No labelled fields -}] + [clas_tyvar] + [{-No context-}] + dict_component_tys + tycon + + tycon = mkDataTyCon class_name + (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind) + [rec_tyvar] + [{- Empty context -}] + [dict_con_id] + [{- No derived classes -}] + new_or_data + in + + \begin{code} tcClassContext :: Class -> TyVar -> RenamedContext -- class context @@ -113,40 +178,22 @@ tcClassContext rec_class rec_tyvar context pragmas in -- Make super-class selector ids - mapTc (mk_super_id rec_class) - (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids -> + mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids -> -- Done returnTc (super_classes, sc_sel_ids) where - mk_super_id rec_class (super_class, maybe_pragma) - = fixTc ( \ rec_super_id -> - tcGetUnique `thenNF_Tc` \ uniq -> - - -- GET THE PRAGMA INFO FOR THE SUPERCLASS - (case maybe_pragma of - Nothing -> returnNF_Tc noIdInfo - Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag - ) `thenNF_Tc` \ id_info -> - let - ty = mkForAllTy rec_tyvar ( - mkFunTy (mkDictTy rec_class (mkTyVarTy rec_tyvar)) - (mkDictTy super_class (mkTyVarTy rec_tyvar)) - ) - in - -- BUILD THE SUPERCLASS ID - returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info) - ) - - maybe_pragmas :: [Maybe RenamedGenPragmas] - maybe_pragmas = case pragmas of - NoClassPragmas -> repeat Nothing - SuperDictPragmas prags -> ASSERT(length prags == length context) - map Just prags - -- If there are any pragmas there should - -- be one for each superclass + rec_tyvar_ty = mkTyVarTy rec_tyvar + mk_super_id rec_class super_class + = tcGetUnique `thenNF_Tc` \ uniq -> + let + ty = mkForAllTy rec_tyvar $ + mkFunTy (mkDictTy rec_class rec_tyvar_ty) + (mkDictTy super_class rec_tyvar_ty) + in + returnTc (mkSuperDictSelId uniq rec_class super_class ty) tcClassSig :: Class -- Knot tying only! @@ -158,43 +205,36 @@ tcClassSig :: Class -- Knot tying only! Id) -- default-method ids tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn - (ClassOpSig op_name - (HsForAllTy tyvar_names context monotype) - pragmas src_loc) + (ClassOpSig op_name dm_name + op_ty + src_loc) = tcAddSrcLoc src_loc $ fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas -- Check the type signature. NB that the envt *already has* -- bindings for the type variables; see comments in TcTyAndClassDcls. - tcContext context `thenTc` \ theta -> - tcMonoType monotype `thenTc` \ tau -> - mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (_,tyvars) -> + + -- NB: Renamer checks that the class type variable is mentioned in local_ty, + -- and that it is not constrained by theta + tcHsType op_ty `thenTc` \ local_ty -> let - full_tyvars = rec_clas_tyvar : tyvars - full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta - global_ty = mkSigmaTy full_tyvars full_theta tau - local_ty = mkSigmaTy tyvars theta tau - class_op = mkClassOp (getOccurrenceName op_name) - (getTagFromClassOpName op_name) + global_ty = mkSigmaTy [rec_clas_tyvar] + [(rec_clas, mkTyVarTy rec_clas_tyvar)] + local_ty + class_op_nm = getOccName op_name + class_op = mkClassOp class_op_nm + (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm) local_ty in - -- Munch the pragmas - tcClassOpPragmas - global_ty - rec_sel_id rec_defm_id - (rec_classop_spec_fn class_op) - pragmas `thenNF_Tc` \ (op_info, defm_info) -> - -- Build the selector id and default method id - tcGetUnique `thenNF_Tc` \ d_uniq -> let - op_uniq = getItsUnique op_name - sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info - defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info + sel_id = mkMethodSelId op_name rec_clas class_op global_ty + defm_id = mkDefaultMethodId dm_name rec_clas class_op False global_ty -- ToDo: improve the "False" in - returnTc (class_op, sel_id, defm_id) + tcAddImportedIdInfo defm_id `thenNF_Tc` \ final_defm_id -> + returnTc (class_op, sel_id, final_defm_id) ) \end{code} @@ -222,14 +262,13 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to each local class decl. \begin{code} -tcClassDecls2 :: Bag RenamedClassDecl +tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE s, TcHsBinds s) tcClassDecls2 decls - = foldBag combine - tcClassDecl2 - (returnNF_Tc (emptyLIE, EmptyBinds)) - decls + = foldr combine + (returnNF_Tc (emptyLIE, EmptyBinds)) + [tcClassDecl2 cls_decl | ClD cls_decl <- decls] where combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> tc2 `thenNF_Tc` \ (lie2, binds2) -> @@ -254,17 +293,20 @@ tcClassDecl2 (ClassDecl context class_name tcAddSrcLoc src_loc $ -- Get the relevant class - tcLookupClass class_name `thenNF_Tc` \ (_, clas) -> + tcLookupClass class_name `thenTc` \ (_, clas) -> let (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) - = getClassBigSig clas + = classBigSig clas + + -- The selector binds are already in the selector Id's unfoldings + sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $ + [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id)) + | sel_id <- sc_sel_ids ++ op_sel_ids, + isLocallyDefined sel_id + ] in + -- Generate bindings for the default methods tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) -> - - -- Generate bindings for the selector functions - buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids - `thenNF_Tc` \ sel_binds -> - -- Ditto for the methods buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds `thenTc` \ (const_insts, meth_binds) -> @@ -273,132 +315,6 @@ tcClassDecl2 (ClassDecl context class_name %************************************************************************ %* * -\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses} -%* * -%************************************************************************ - -\begin{code} -buildSelectors :: Class -- The class object - -> TyVar -- Class type variable - -> TcTyVar s -- Instantiated class type variable (TyVarTy) - -> [Class] -> [Id] -- Superclasses and selectors - -> [ClassOp] -> [Id] -- Class ops and selectors - -> NF_TcM s (TcHsBinds s) - -buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids - = - -- Make new Ids for the components of the dictionary - let - clas_tyvar_ty = mkTyVarTy clas_tc_tyvar - mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType - in - mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys -> - newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids -> - - newDicts ClassDeclOrigin - [ (super_clas, clas_tyvar_ty) - | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) -> - - newDicts ClassDeclOrigin - [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) -> - - -- Make suitable bindings for the selectors - let - mk_sel sel_id method_or_dict - = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict - in - listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> - listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> - - returnNF_Tc (SingleBind ( - NonRecBind ( - foldr AndMonoBinds - (foldr AndMonoBinds EmptyMonoBinds op_sel_binds) - sc_sel_binds - ))) -\end{code} - -%************************************************************************ -%* * -\subsection[ClassDcl-misc]{Miscellaneous} -%* * -%************************************************************************ - -Make a selector expression for @sel_id@ from a dictionary @clas_dict@ -consisting of @dicts@ and @methods@. - -We have to do a bit of jiggery pokery to get the type variables right. -Suppose we have the class decl: -\begin{verbatim} - class Foo a where - op1 :: Ord b => a -> b -> a - op2 :: ... -\end{verbatim} -Then the method selector for \tr{op1} is like this: -\begin{verbatim} - op1_sel = /\a b -> \dFoo dOrd -> case dFoo of - (op1_method,op2_method) -> op1_method b dOrd -\end{verbatim} -Note that the type variable for \tr{b} and the (Ord b) dictionary -are lifted to the top lambda, and -\tr{op1_method} is applied to them. This is preferable to the alternative: -\begin{verbatim} - op1_sel' = /\a -> \dFoo -> case dFoo of - (op1_method,op2_method) -> op1_method -\end{verbatim} -because \tr{op1_sel'} then has the rather strange type -\begin{verbatim} - op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a -\end{verbatim} -whereas \tr{op1_sel} (the one we use) has the decent type -\begin{verbatim} - op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a -\end{verbatim} - -NOTE that we return a TcMonoBinds (which is later zonked) even though -there's no real back-substitution to do. It's just simpler this way! - -NOTE ALSO that the selector has no free type variables, so we -don't bother to instantiate the class-op's local type; instead -we just use the variables inside it. - -\begin{code} -mkSelBind :: Id -- the selector id - -> TcTyVar s -> TcIdOcc s -- class tyvar and dict - -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict - -> TcIdOcc s -- the superclass/method being slected - -> NF_TcM s (TcMonoBinds s) - -mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op) - = let - (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op) - op_tys = mkTyVarTys op_tyvars - in - newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) -> - - -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts -> - -- case clas_dict of - -- -> method_or_dict op_tyvars op_dicts - - returnNF_Tc (VarMonoBind (RealId sel_id) ( - TyLam (clas_tyvar:op_tyvars) ( - DictLam (clas_dict:op_dicts) ( - HsCase - (HsVar clas_dict) - ([PatMatch (DictPat dicts methods) ( - GRHSMatch (GRHSsAndBindsOut - [OtherwiseGRHS - (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts) - mkGeneratedSrcLoc] - EmptyBinds - op_tau))]) - mkGeneratedSrcLoc - )))) -\end{code} - - -%************************************************************************ -%* * \subsection[Default methods]{Default methods} %* * %************************************************************************ @@ -419,11 +335,22 @@ 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: @@ -436,14 +363,15 @@ const.Foo.Int.op1 :: Int -> Bool const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b -const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int +const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int dfun.Foo.Int :: Foo Int dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2) \end{verbatim} Notice that, as with method selectors above, we assume that dictionary application is curried, so there's no need to mention the Ord dictionary -in const.Foo.Int.op2 +in const.Foo.Int.op2 (or the type variable). + \begin{verbatim} instance Foo a => Foo [a] where {} @@ -452,7 +380,7 @@ dfun.Foo.List = /\ a -> \ dfoo_a -> let rec op1 = defm.Foo.op1 [a] dfoo_list - op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord + op2 = defm.Foo.op2 [a] dfoo_list dfoo_list = (op1, op2) in dfoo_list @@ -468,52 +396,136 @@ buildDefaultMethodBinds buildDefaultMethodBinds clas clas_tyvar default_method_ids default_binds - = -- Deal with the method declarations themselves - mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids -> - processInstBinds - (makeClassDeclDefaultMethodRhs clas default_method_ids) - [] -- No tyvars in scope for "this inst decl" - emptyLIE -- No insts available - (map TcId tc_defm_ids) - default_binds `thenTc` \ (dicts_needed, default_binds') -> - - returnTc (dicts_needed, SingleBind (NonRecBind default_binds')) + = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) -> + let + avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available + clas_tyvar_set = unitTyVarSet clas_tyvar + in + tcExtendGlobalTyVars clas_tyvar_set ( + processInstBinds + clas + (makeClassDeclDefaultMethodRhs clas local_defm_ids) + avail_insts + local_defm_ids + default_binds + ) `thenTc` \ (insts_needed, default_binds') -> + + tcSimplifyAndCheck + clas_tyvar_set + avail_insts + insts_needed `thenTc` \ (const_lie, dict_binds) -> + + + let + defm_binds = AbsBinds + [clas_tyvar] + [this_dict_id] + (local_defm_ids `zip` map RealId default_method_ids) + dict_binds + (RecBind default_binds') + in + returnTc (const_lie, defm_binds) + where + inst_ty = mkTyVarTy clas_tyvar + mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty] + origin = ClassDeclOrigin \end{code} +==================== +buildDefaultMethodBinds + :: Class + -> TcTyVar s + -> [Id] + -> RenamedMonoBinds + -> TcM s (LIE s, TcHsBinds s) + +buildDefaultMethodBinds clas clas_tyvar + default_method_ids default_binds + = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + tcExtendGlobalTyVars clas_tyvar_set ( + tcDefaultMethodBinds default_binds + ) + +tcDefaultMethodBinds default_meth_ids default_binds + where + go (AndMonoBinds b1 b2) + = go b1 `thenTc` \ (new_b1, lie1) -> + go b2 `thenTc` \ (new_b2, lie2) -> + returnTc (new_b1 `ThenBinds` new_b2, lie1 `plusLIE` lie2) + + go EmptyMonoBinds = EmptyBinds + + go mbind = processInstBinds1 clas clas_dict meth_ids mbind `thenTc` \ (tags + +tcDefaultMethodBinds EmptyMonoBinds + + + + processInstBinds + clas + (makeClassDeclDefaultMethodRhs clas local_defm_ids) + avail_insts + local_defm_ids + default_binds + ) `thenTc` \ (insts_needed, default_binds') -> + + let + mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) -> + let + avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available + clas_tyvar_set = unitTyVarSet clas_tyvar + in + + tcSimplifyAndCheck + clas_tyvar_set + avail_insts + insts_needed `thenTc` \ (const_lie, dict_binds) -> + + + let + defm_binds = AbsBinds + [clas_tyvar] + [this_dict_id] + (local_defm_ids `zip` map RealId default_method_ids) + dict_binds + (RecBind default_binds') + in + returnTc (const_lie, defm_binds) + where + inst_ty = mkTyVarTy clas_tyvar + mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty] + origin = ClassDeclOrigin +================== + @makeClassDeclDefaultMethodRhs@ builds the default method for a class declaration when no explicit default method is given. \begin{code} makeClassDeclDefaultMethodRhs :: Class - -> [Id] + -> [TcIdOcc s] -> Int -> NF_TcM s (TcExpr s) makeClassDeclDefaultMethodRhs clas method_ids tag - = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty -> - let - (tyvars, theta, tau) = splitSigmaTy method_ty - in - newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) -> - - returnNF_Tc (mkHsTyLam tyvars ( - mkHsDictLam dict_ids ( - HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau]) - (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) + = -- Return the expression + -- error ty "No default method for ..." + -- The interesting thing is that method_ty is a for-all type; + -- this is fun, although unusual in a type application! + + returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id]) + (HsLitOut (HsString (_PK_ error_msg)) stringTy)) + where - (clas_mod, clas_name) = getOrigName clas + (clas_mod, clas_name) = modAndOcc clas method_id = method_ids !! (tag-1) - class_op = (getClassOps clas) !! (tag-1) - - error_msg = "%D" -- => No default method for \" - ++ unencoded_part_of_msg + class_op = (classOps clas) !! (tag-1) - unencoded_part_of_msg = escErrorMsg ( - _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." - ++ (ppShow 80 (ppr PprForUser class_op)) - ++ "\"" ) + error_msg = _UNPK_ (nameString (getName clas)) + ++ (ppShow 80 (ppr PprForUser class_op)) +-- ++ "\"" Don't know what this trailing quote is for! \end{code} @@ -521,5 +533,5 @@ Contexts ~~~~~~~~ \begin{code} classDeclCtxt class_name sty - = ppCat [ppStr "In the class declaration for", ppr sty class_name] + = ppCat [ppPStr SLIT("In the class declaration for"), ppr sty class_name] \end{code}