From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:34:46 +0000 (+0000) Subject: Extend Class.Class to include the TyCons of ATs X-Git-Tag: After_FC_branch_merge~34 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=bb106f283663e9c16a4c72ec9ca57109ae57a0ed Extend Class.Class to include the TyCons of ATs Mon Sep 18 18:58:51 EDT 2006 Manuel M T Chakravarty * Extend Class.Class to include the TyCons of ATs Wed Aug 16 16:15:31 EDT 2006 Manuel M T Chakravarty * Extend Class.Class to include the TyCons of ATs --- diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index a11b351..9ae85a2 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -919,7 +919,7 @@ instance Binary IfaceDecl where put_ bh ar put_ bh as put_ bh at - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do putByte bh 4 put_ bh a1 put_ bh a2 @@ -927,6 +927,7 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 put_ bh a6 + put_ bh a7 get bh = do h <- getByte bh case h of @@ -957,7 +958,8 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceClass a1 a2 a3 a4 a5 a6) + a7 <- get bh + return (IfaceClass a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceInst where put_ bh (IfaceInst cls tys dfun flag orph) = do diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index c669daf..bf71ca8 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -37,6 +37,7 @@ import Type ( mkArrowKinds, liftedTypeKind, typeKind, splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe, mkPredTys, mkTyVarTys, ThetaType, Type, Kind, + TyThing(..), substTyWith, zipTopTvSubst, substTheta, mkForAllTys, mkTyConApp, mkTyVarTy ) import Coercion ( mkNewTypeCoercion ) @@ -231,11 +232,12 @@ mkTyConSelIds tycon rhs \begin{code} buildClass :: Name -> [TyVar] -> ThetaType -> [FunDep TyVar] -- Functional dependencies + -> [TyThing] -- Associated types -> [(Name, DefMeth, Type)] -- Method info -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass class_name tvs sc_theta fds sig_stuff tc_isrec +buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec = do { tycon_name <- newImplicitBinder class_name mkClassTyConOcc ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc -- The class name is the 'parent' for this datacon, not its tycon, @@ -285,10 +287,12 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec -- Because C has only one operation, it is represented by -- a newtype, and it should be a *recursive* newtype. -- [If we don't make it a recursive newtype, we'll expand the - -- newtype like a synonym, but that will lead to an infinite type] + -- newtype like a synonym, but that will lead to an infinite + -- type] + ; atTyCons = [tycon | ATyCon tycon <- ats] } - ; return (mkClass class_name tvs fds - sc_theta sc_sel_ids op_items + ; return (mkClass class_name tvs fds + sc_theta sc_sel_ids atTyCons op_items tycon) })} \end{code} diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 0d649fb..07f4a18 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -93,6 +93,7 @@ data IfaceDecl ifName :: OccName, -- Name of the class ifTyVars :: [IfaceTvBndr], -- Type variables ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceDecl], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? } @@ -260,10 +261,12 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, IfOpenNewTyCon -> ptext SLIT("newtype family") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifSigs = sigs, ifRec = isrec}) + ifFDs = fds, ifATs = ats, ifSigs = sigs, + ifRec = isrec}) = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprRec isrec, - sep (map ppr sigs)]) + sep (map ppr ats), + sep (map ppr sigs)]) pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec pprGen True = ptext SLIT("Generics: yes") @@ -546,6 +549,7 @@ eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& + eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&& eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2) ) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7901f7c..d4548db 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -997,10 +997,12 @@ tyThingToIfaceDecl ext (AClass clas) ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, ifFDs = map toIfaceFD clas_fds, + ifATs = map (tyThingToIfaceDecl ext . ATyCon) clas_ats, ifSigs = map toIfaceClassOp op_stuff, ifRec = boolToRecFlag (isRecursiveTyCon tycon) } where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas tycon = classTyCon clas toIfaceClassOp (sel_id, def_meth) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 2c8780c..29e440e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -82,7 +82,7 @@ import CoreSyn ( CoreBind ) import Id ( Id ) import Type ( TyThing(..) ) -import Class ( Class, classSelIds, classTyCon ) +import Class ( Class, classSelIds, classTyCon, classATs ) import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon, newTyConCo ) import DataCon ( dataConImplicitIds ) import PrelNames ( gHC_PRIM ) @@ -633,7 +633,8 @@ implicitTyThings (ATyCon tc) = implicitNewCoTyCon tc ++ -- For classes, add the class TyCon too (and its extras) -- and the class selector Ids implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ - extras_plus (ATyCon (classTyCon cl)) + extras_plus (ATyCon (classTyCon cl)) ++ + map ATyCon (classATs cl) -- For data cons add the worker and wrapper (if any) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 8d55414..3fb6cb1 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -39,6 +39,7 @@ import OrdList import FastString import Maybes ( orElse ) +import Monad ( when ) import Outputable import GLAEXTS } @@ -483,7 +484,7 @@ cl_decl :: { LTyClDecl RdrName } (mkClassDecl (ctxt, tc, tvs) (unLoc $3) sigs binds ats) } } --- Type declarations +-- Type declarations (toplevel) -- ty_decl :: { LTyClDecl RdrName } -- ordinary type synonyms @@ -520,7 +521,7 @@ ty_decl :: { LTyClDecl RdrName } (TySynonym tc tvs (Just typats) $5)) } } - -- ordinary data type or newtype declaration + -- ordinary data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms -- no type pattern @@ -531,7 +532,7 @@ ty_decl :: { LTyClDecl RdrName } (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) Nothing (reverse (unLoc $3)) (unLoc $4)) } } - -- ordinary GADT declaration + -- ordinary GADT declaration | data_or_newtype tycl_hdr opt_kind_sig 'where' gadt_constrlist deriving @@ -542,7 +543,7 @@ ty_decl :: { LTyClDecl RdrName } (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) $3 (reverse (unLoc $5)) (unLoc $6)) } } - -- data/newtype family + -- data/newtype family | data_or_newtype 'family' tycl_hdr '::' kind {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3} ; checkTyVars tparms -- no type pattern @@ -551,7 +552,7 @@ ty_decl :: { LTyClDecl RdrName } (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) (Just (unLoc $5)) [] Nothing) } } - -- data/newtype instance declaration + -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3} -- can have type pats @@ -562,7 +563,7 @@ ty_decl :: { LTyClDecl RdrName } (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) Nothing (reverse (unLoc $4)) (unLoc $5)) } } - -- GADT instance declaration + -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig 'where' gadt_constrlist deriving @@ -573,6 +574,62 @@ ty_decl :: { LTyClDecl RdrName } (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) $4 (reverse (unLoc $6)) (unLoc $7)) } } +-- Associate type declarations +-- +at_decl :: { LTyClDecl RdrName } + -- type family declarations + : 'type' opt_iso type '::' kind + -- Note the use of type for the head; this allows + -- infix type constructors to be declared + -- + {% do { (tc, tvs, _) <- checkSynHdr $3 False + ; return (L (comb3 $1 $3 $5) + (TyFunction tc tvs $2 (unLoc $5))) + } } + + -- type instance declarations + | 'type' opt_iso type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + -- + {% do { when $2 $ + parseError (comb2 $1 $>) "Misplaced iso keyword" + ; (tc, tvs, typats) <- checkSynHdr $3 True + ; return (L (comb2 $1 $5) + (TySynonym tc tvs (Just typats) $5)) + } } + + -- data/newtype family + | data_or_newtype tycl_hdr '::' kind + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; checkTyVars tparms -- no type pattern + ; return $ + L (comb3 $1 $2 $4) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) + (Just (unLoc $4)) [] Nothing) } } + + -- data/newtype instance declaration + | data_or_newtype tycl_hdr constrs deriving + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + -- can have type pats + ; return $ + L (comb4 $1 $2 $3 $4) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) + Nothing (reverse (unLoc $3)) (unLoc $4)) } } + + -- GADT instance declaration + | data_or_newtype tycl_hdr opt_kind_sig + 'where' gadt_constrlist + deriving + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + -- can have type pats + ; return $ + L (comb4 $1 $2 $5 $6) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) + $3 (reverse (unLoc $5)) (unLoc $6)) } } + opt_iso :: { Bool } : { False } | 'iso' { True } @@ -605,7 +662,7 @@ tycl_hdr :: { Located (LHsContext RdrName, -- Type declaration or value declaration -- tydecl :: { Located (OrdList (LHsDecl RdrName)) } -tydecl : ty_decl { LL (unitOL (L1 (TyClD (unLoc $1)))) } +tydecl : at_decl { LL (unitOL (L1 (TyClD (unLoc $1)))) } | decl { $1 } tydecls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index a823884..1d17c4d 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -631,7 +631,7 @@ reifyClass cls ; ops <- mapM reify_op op_stuff ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } where - (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls + (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds reify_op (op, _) = do { ty <- reifyType (idType op) ; return (TH.SigD (reifyName op) ty) } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index d69e632..9137ece 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -256,11 +256,11 @@ tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the right hand side of the type equation + do { -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind - -- type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (2) type check type equation + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars ; t_typats <- mappM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs @@ -272,17 +272,16 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the data declaration as usual + do { -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs - ; k_typats <- mappM tcHsKindedType k_typats ; let k_ctxt = tcdCtxt decl k_cons = tcdCons decl -- result kind must be '*' (otherwise, we have too few patterns) ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name - -- type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (2) type check indexed data type declaration + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars ; unbox_strict <- doptM Opt_UnboxStrictFields -- Check that we don't use GADT syntax for indexed types @@ -292,6 +291,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, ; checkTc (new_or_data == DataType || isSingleton cons) $ newtypeConError tc_name (length cons) + ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data @@ -691,7 +691,6 @@ tcTyClDecl1 calc_isrec { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps ; ats' <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - -- ^^^^ !!!TODO: what to do with this? Need to generate FC tyfun decls. ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -700,7 +699,7 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' + buildClass class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) ; return (AClass clas) } where diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index fb6b901..abf7e4b 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -11,7 +11,7 @@ module Class ( FunDep, pprFundeps, mkClass, classTyVars, classArity, - classKey, className, classSelIds, classTyCon, classMethods, + classKey, className, classATs, classSelIds, classTyCon, classMethods, classBigSig, classExtraBigSig, classTvsFds, classSCTheta ) where @@ -38,24 +38,27 @@ A @Class@ corresponds to a Greek kappa in the static semantics: \begin{code} data Class = Class { - classKey :: Unique, -- Key for fast comparison + classKey :: Unique, -- Key for fast comparison className :: Name, - classTyVars :: [TyVar], -- The class type variables - classFunDeps :: [FunDep TyVar], -- The functional dependencies + classTyVars :: [TyVar], -- The class type variables + classFunDeps :: [FunDep TyVar], -- The functional dependencies - classSCTheta :: [PredType], -- Immediate superclasses, and the - classSCSels :: [Id], -- corresponding selector functions to - -- extract them from a dictionary of this - -- class + classSCTheta :: [PredType], -- Immediate superclasses, and the + classSCSels :: [Id], -- corresponding selector functions + -- to extract them from a dictionary + -- of this class - classOpStuff :: [ClassOpItem], -- Ordered by tag + classATs :: [TyCon], -- Associated type families - classTyCon :: TyCon -- The data type constructor for dictionaries - } -- of this class + classOpStuff :: [ClassOpItem], -- Ordered by tag -type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ... - -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] + classTyCon :: TyCon -- The data type constructor for + -- dictionaries of this class + } + +type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where... + -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] type ClassOpItem = (Id, DefMeth) -- Selector function; contains unfolding @@ -73,11 +76,12 @@ The @mkClass@ function fills in the indirect superclasses. mkClass :: Name -> [TyVar] -> [([TyVar], [TyVar])] -> [PredType] -> [Id] + -> [TyCon] -> [ClassOpItem] -> TyCon -> Class -mkClass name tyvars fds super_classes superdict_sels +mkClass name tyvars fds super_classes superdict_sels ats op_stuff tycon = Class { classKey = getUnique name, className = name, @@ -85,6 +89,7 @@ mkClass name tyvars fds super_classes superdict_sels classFunDeps = fds, classSCTheta = super_classes, classSCSels = superdict_sels, + classATs = ats, classOpStuff = op_stuff, classTyCon = tycon } \end{code} @@ -118,8 +123,8 @@ classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, = (tyvars, sc_theta, sc_sels, op_stuff) classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, classSCTheta = sc_theta, classSCSels = sc_sels, - classOpStuff = op_stuff}) - = (tyvars, fundeps, sc_theta, sc_sels, op_stuff) + classATs = ats, classOpStuff = op_stuff}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) \end{code}