Commit bb106f28 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Extend Class.Class to include the TyCons of ATs

Mon Sep 18 18:58:51 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Extend Class.Class to include the TyCons of ATs
  Wed Aug 16 16:15:31 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Extend Class.Class to include the TyCons of ATs
parent 229aaa59
......@@ -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
......
......@@ -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}
......
......@@ -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)
)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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) }
......
......@@ -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
......
......@@ -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}
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment