summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>2006-09-20 18:34:46 +0000
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>2006-09-20 18:34:46 +0000
commitbb106f283663e9c16a4c72ec9ca57109ae57a0ed (patch)
tree29ef06c7dabb92382ef8e84f79c61c991759fdbf /compiler
parent229aaa59fd13e69778cb1ec809d065fa25b40a43 (diff)
downloadhaskell-bb106f283663e9c16a4c72ec9ca57109ae57a0ed.tar.gz
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
Diffstat (limited to 'compiler')
-rw-r--r--compiler/iface/BinIface.hs6
-rw-r--r--compiler/iface/BuildTyCl.lhs12
-rw-r--r--compiler/iface/IfaceSyn.lhs8
-rw-r--r--compiler/iface/MkIface.lhs4
-rw-r--r--compiler/main/HscTypes.lhs5
-rw-r--r--compiler/parser/Parser.y.pp71
-rw-r--r--compiler/typecheck/TcSplice.lhs2
-rw-r--r--compiler/typecheck/TcTyClsDecls.lhs17
-rw-r--r--compiler/types/Class.lhs37
9 files changed, 118 insertions, 44 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index a11b351570..9ae85a2ef8 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 c669daf67c..bf71ca843c 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 0d649fb613..07f4a185b3 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 7901f7c514..d4548db55a 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 2c8780ca3d..29e440e45b 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 8d55414c6e..3fb6cb1ece 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 a823884b96..1d17c4dd85 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 d69e632f2c..9137ecee58 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 fb6b901cf3..abf7e4b7ad 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}
View Lorry Controller Status