X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=a4c43af3dff53a0007051bd2e59bd8bd137fb711;hb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;hp=805fe986c8bb6494fe10de427f7bb04b4406657b;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 805fe98..a4c43af 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -19,35 +19,37 @@ import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), import HsPragmas ( ClassPragmas(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RenamedClassOpSig(..), RenamedMonoBinds(..), - RenamedGenPragmas(..), RenamedContext(..) ) + RenamedGenPragmas(..), RenamedContext(..), + RnName{-instance Uniquable-} + ) import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..), mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId ) -import TcMonad -import GenSpecEtc ( specTy ) +import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts ) import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds) import TcInstDcls ( processInstBinds ) import TcKind ( unifyKind ) import TcMonoType ( tcMonoType, tcContext ) -import TcType ( TcTyVar(..), tcInstType, tcInstTyVar ) +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 Class ( GenClass, mkClass, mkClassOp, classBigSig, + classOps, classOpString, classOpLocalType, + classOpTagByString + ) import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, idType ) import IdInfo ( noIdInfo ) -import Name ( Name, getNameFullName, getTagFromClassOpName ) -import PrelVals ( pAT_ERROR_ID ) +import Name ( isLocallyDefined, moduleNamePair, getLocalName ) +import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty import PprType ( GenType, GenTyVar, GenClassOp ) import SpecEnv ( SpecEnv(..) ) import SrcLoc ( mkGeneratedSrcLoc ) -import Type ( mkFunTy, mkTyVarTy, mkDictTy, +import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkForAllTy, mkSigmaTy, splitSigmaTy) import TysWiredIn ( stringTy ) import TyVar ( GenTyVar ) @@ -86,10 +88,11 @@ tcClassDecl1 rec_inst_mapper `thenTc` \ sig_stuff -> -- MAKE THE CLASS OBJECT ITSELF - tcGetUnique `thenNF_Tc` \ uniq -> +-- BOGUS: +-- 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 @@ -175,8 +178,9 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn 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) + class_op_nm = getLocalName op_name + class_op = mkClassOp class_op_nm + (classOpTagByString rec_clas{-yeeps!-} class_op_nm) local_ty in @@ -190,7 +194,7 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn -- Build the selector id and default method id tcGetUnique `thenNF_Tc` \ d_uniq -> let - op_uniq = getItsUnique op_name + op_uniq = uniqueOf 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 -- ToDo: improve the "False" @@ -246,6 +250,11 @@ tcClassDecl2 :: RenamedClassDecl -- The class declaration tcClassDecl2 (ClassDecl context class_name tyvar_name class_sigs default_binds pragmas src_loc) + + | not (isLocallyDefined class_name) + = returnNF_Tc (emptyLIE, EmptyBinds) + + | otherwise -- It is locally defined = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $ tcAddSrcLoc src_loc $ @@ -253,16 +262,16 @@ tcClassDecl2 (ClassDecl context class_name tcLookupClass class_name `thenNF_Tc` \ (_, clas) -> let (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) - = getClassBigSig clas + = classBigSig clas in - tcInstTyVar tyvar `thenNF_Tc` \ clas_tyvar -> + tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) -> -- Generate bindings for the selector functions - buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids - `thenNF_Tc` \ sel_binds -> + 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) -> + `thenTc` \ (const_insts, meth_binds) -> returnTc (const_insts, sel_binds `ThenBinds` meth_binds) \end{code} @@ -275,34 +284,36 @@ tcClassDecl2 (ClassDecl context class_name \begin{code} buildSelectors :: Class -- The class object - -> TcTyVar s -- Class type variable + -> 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 scs sc_sel_ids ops op_sel_ids +buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids = -- Make new Ids for the components of the dictionary - mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys -> - - newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids -> + let + clas_tyvar_ty = mkTyVarTy clas_tc_tyvar + mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType + in + mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys -> + newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids -> newDicts ClassDeclOrigin - [ (super_clas, mkTyVarTy clas_tyvar) + [ (super_clas, clas_tyvar_ty) | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) -> newDicts ClassDeclOrigin - [ (clas, mkTyVarTy clas_tyvar) ] `thenNF_Tc` \ (_,[clas_dict]) -> + [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) -> -- Make suitable bindings for the selectors let - tc_method_ids = map TcId method_ids - mk_sel sel_id method_or_dict - = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids 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 tc_method_ids) `thenNF_Tc` \ op_sel_binds -> - listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> + 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 ( @@ -366,7 +377,7 @@ mkSelBind :: Id -- the selector id 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 = map mkTyVarTy op_tyvars + op_tys = mkTyVarTys op_tyvars in newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) -> @@ -446,7 +457,7 @@ dfun.Foo.List = /\ a -> \ dfoo_a -> let rec op1 = defm.Foo.op1 [a] dfoo_list - op2 = /\b -> defm.Foo.op2 [a] b dfoo_list + op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord dfoo_list = (op1, op2) in dfoo_list @@ -465,6 +476,7 @@ buildDefaultMethodBinds clas clas_tyvar = -- Deal with the method declarations themselves mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids -> processInstBinds + clas (makeClassDeclDefaultMethodRhs clas default_method_ids) [] -- No tyvars in scope for "this inst decl" emptyLIE -- No insts available @@ -485,25 +497,25 @@ makeClassDeclDefaultMethodRhs -> NF_TcM s (TcExpr s) makeClassDeclDefaultMethodRhs clas method_ids tag - = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) -> + = 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]) + HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) where - (clas_mod, clas_name) = getOrigName clas + (clas_mod, clas_name) = moduleNamePair 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_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." + ++ (ppShow 80 (ppr PprForUser class_op)) + ++ "\"" \end{code}