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
put_ bh a4
put_ bh a5
put_ bh a6
+ put_ bh a7
get bh = do
h <- getByte bh
case h of
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
splitTyConApp_maybe, splitAppTy_maybe,
getTyVar_maybe,
mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
+ TyThing(..),
substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
mkTyConApp, mkTyVarTy )
import Coercion ( mkNewTypeCoercion )
\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,
-- 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}
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?
}
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")
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)
)
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)
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 )
-- 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)
import FastString
import Maybes ( orElse )
+import Monad ( when )
import Outputable
import GLAEXTS
}
(mkClassDecl (ctxt, tc, tvs)
(unLoc $3) sigs binds ats) } }
--- Type declarations
+-- Type declarations (toplevel)
--
ty_decl :: { LTyClDecl RdrName }
-- ordinary type synonyms
(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
(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
(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
(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
(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
(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 }
-- 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
; 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) }
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
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
; 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
{ 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
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
FunDep, pprFundeps,
mkClass, classTyVars, classArity,
- classKey, className, classSelIds, classTyCon, classMethods,
+ classKey, className, classATs, classSelIds, classTyCon, classMethods,
classBigSig, classExtraBigSig, classTvsFds, classSCTheta
) where
\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
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,
classFunDeps = fds,
classSCTheta = super_classes,
classSCSels = superdict_sels,
+ classATs = ats,
classOpStuff = op_stuff,
classTyCon = tycon }
\end{code}
= (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}
projects / ghc-hetmet.git / commitdiff