- This patch removes "newtype family" declarations.
- "newtype instance" declarations can now be instances of data families
- This also fixes bug #1331
** This patch changes the interface format. All libraries and all of **
** Stage 2 & 3 need to be re-compiled from scratch. **
data FamilyFlavour
= TypeFamily -- "type family ..."
data FamilyFlavour
= TypeFamily -- "type family ..."
- | DataFamily NewOrData -- "newtype family ..." or "data family ..."
+ | DataFamily -- "data family ..."
\end{code}
Simple classifiers
\end{code}
Simple classifiers
= pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
where
pp_flavour = case flavour of
= pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
where
pp_flavour = case flavour of
- TypeFamily -> ptext SLIT("type family")
- DataFamily NewType -> ptext SLIT("newtype family")
- DataFamily DataType -> ptext SLIT("data family")
+ TypeFamily -> ptext SLIT("type family")
+ DataFamily -> ptext SLIT("data family")
pp_kind = case mb_kind of
Nothing -> empty
pp_kind = case mb_kind of
Nothing -> empty
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
put_ bh IfOpenDataTyCon = putByte bh 1
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
put_ bh IfOpenDataTyCon = putByte bh 1
- put_ bh IfOpenNewTyCon = putByte bh 2
- put_ bh (IfDataTyCon cs) = do { putByte bh 3
+ put_ bh (IfDataTyCon cs) = do { putByte bh 2
- put_ bh (IfNewTyCon c) = do { putByte bh 4
+ put_ bh (IfNewTyCon c) = do { putByte bh 3
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
1 -> return IfOpenDataTyCon
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
1 -> return IfOpenDataTyCon
- 2 -> return IfOpenNewTyCon
- 3 -> do cs <- get bh
return (IfDataTyCon cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
return (IfDataTyCon cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
- mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
+ mkAbstractTyConRhs, mkOpenDataTyConRhs,
mkNewTyConRhs, mkDataTyConRhs
) where
mkNewTyConRhs, mkDataTyConRhs
) where
mkAbstractTyConRhs = AbstractTyCon
mkOpenDataTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
mkOpenDataTyConRhs :: AlgTyConRhs
-mkOpenDataTyConRhs = OpenTyCon Nothing False
-
-mkOpenNewTyConRhs :: AlgTyConRhs
-mkOpenNewTyConRhs = OpenTyCon Nothing True
+mkOpenDataTyConRhs = OpenTyCon Nothing
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
data IfaceConDecls
= IfAbstractTyCon -- No info
| IfOpenDataTyCon -- Open data family
data IfaceConDecls
= IfAbstractTyCon -- No info
| IfOpenDataTyCon -- Open data family
- | IfOpenNewTyCon -- Open newtype family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
visibleIfConDecls IfOpenDataTyCon = []
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
visibleIfConDecls IfOpenDataTyCon = []
-visibleIfConDecls IfOpenNewTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
IfOpenDataTyCon -> ptext SLIT("data family")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
IfOpenDataTyCon -> ptext SLIT("data family")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
- IfOpenNewTyCon -> ptext SLIT("newtype family")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifATs = ats, ifSigs = sigs,
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifATs = ats, ifSigs = sigs,
pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
-pp_condecls tc IfOpenNewTyCon = empty
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls tc IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls tc IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
-eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env c1 c2
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env c1 c2
IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls OpenTyCon { otIsNewtype = False } = IfOpenDataTyCon
- ifaceConDecls OpenTyCon { otIsNewtype = True } = IfOpenNewTyCon
+ ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
IfOpenDataTyCon -> return mkOpenDataTyConRhs
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
IfOpenDataTyCon -> return mkOpenDataTyConRhs
- IfOpenNewTyCon -> return mkOpenNewTyConRhs
IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
-- data/newtype family
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
-- data/newtype family
- | data_or_newtype 'family' tycl_hdr opt_kind_sig
+ | 'data' 'family' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $4)
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $4)
- (TyFamily (DataFamily (unLoc $1)) tc tvs
- (unLoc $4)) } }
+ (TyFamily DataFamily tc tvs (unLoc $4)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
} }
-- data/newtype family declaration
} }
-- data/newtype family declaration
- | data_or_newtype tycl_hdr opt_kind_sig
+ | 'data' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $3)
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $3)
- (TyFamily (DataFamily (unLoc $1)) tc tvs
- (unLoc $3))
+ (TyFamily DataFamily tc tvs (unLoc $3))
} }
-- Associate type instances
} }
-- Associate type instances
- isDataFlavour (DataFamily _) = True
- isDataFlavour _ = False
+ isDataFlavour DataFamily = True
+ isDataFlavour _ = False
family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
needOneIdx = text "Type family declarations requires at least one type index"
family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
needOneIdx = text "Type family declarations requires at least one type index"
; gla_exts <- doptM Opt_GlasgowExts
; overlap_flag <- getOverlapFlag
; gla_exts <- doptM Opt_GlasgowExts
; overlap_flag <- getOverlapFlag
- ; if isDataTyCon tycon then
+
+ -- Be careful to test rep_tc here: in the case of families, we want
+ -- to check the instance tycon, not the family tycon
+ ; if isDataTyCon rep_tc then
mkDataTypeEqn orig gla_exts full_tvs cls cls_tys
tycon full_tc_args rep_tc rep_tc_args
else
mkDataTypeEqn orig gla_exts full_tvs cls cls_tys
tycon full_tc_args rep_tc rep_tc_args
else
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- check that the family declaration is for the right kind
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- check that the family declaration is for the right kind
- unless (new_or_data == NewType && isNewTyCon family ||
- new_or_data == DataType && isDataTyCon family) $
+ unless (isAlgTyCon family) $
addErr (wrongKindOfFamily family)
; -- (1) kind check the data declaration as usual
addErr (wrongKindOfFamily family)
; -- (1) kind check the data declaration as usual
-- "newtype family" or "data family" declaration
tcTyClDecl1 _calc_isrec
-- "newtype family" or "data family" declaration
tcTyClDecl1 _calc_isrec
- (TyFamily {tcdFlavour = DataFamily new_or_data,
+ (TyFamily {tcdFlavour = DataFamily,
tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
- { traceTc (text "data/newtype family: " <+> ppr tc_name)
+ { traceTc (text "data family: " <+> ppr tc_name)
; extra_tvs <- tcDataKindSig mb_kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
; extra_tvs <- tcDataKindSig mb_kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
- (case new_or_data of
- DataType -> mkOpenDataTyConRhs
- NewType -> mkOpenNewTyConRhs)
- Recursive False True Nothing
+ mkOpenDataTyConRhs Recursive False True Nothing
; return [ATyCon tycon]
}
; return [ATyCon tycon]
}
ptext SLIT("Wrong category of family instance; declaration was for a") <+>
kindOfFamily
where
ptext SLIT("Wrong category of family instance; declaration was for a") <+>
kindOfFamily
where
- kindOfFamily | isSynTyCon family = ptext SLIT("type synonym")
- | isDataTyCon family = ptext SLIT("data type")
- | isNewTyCon family = ptext SLIT("newtype")
+ kindOfFamily | isSynTyCon family = ptext SLIT("type synonym")
+ | isAlgTyCon family = ptext SLIT("data type")
| otherwise = pprPanic "wrongKindOfFamily" (ppr family)
emptyConDeclsErr tycon
| otherwise = pprPanic "wrongKindOfFamily" (ppr family)
emptyConDeclsErr tycon
- otArgPoss :: Maybe [Int],
+ otArgPoss :: Maybe [Int]
-- Nothing <=> top-level indexed type family
-- Just ns <=> associated (not toplevel) family
-- In the latter case, for each tyvar in the AT decl, 'ns' gives the
-- position of that tyvar in the class argument list (starting from 0).
-- NB: Length is less than tyConArity iff higher kind signature.
-- Nothing <=> top-level indexed type family
-- Just ns <=> associated (not toplevel) family
-- In the latter case, for each tyvar in the AT decl, 'ns' gives the
-- position of that tyvar in the class argument list (starting from 0).
-- NB: Length is less than tyConArity iff higher kind signature.
- otIsNewtype :: Bool
- -- is a newtype (rather than data type)?
-
isNewTyCon :: TyCon -> Bool
isNewTyCon (AlgTyCon {algTcRhs = rhs}) =
case rhs of
isNewTyCon :: TyCon -> Bool
isNewTyCon (AlgTyCon {algTcRhs = rhs}) =
case rhs of
- OpenTyCon {} -> otIsNewtype rhs
NewTyCon {} -> True
_ -> False
isNewTyCon other = False
NewTyCon {} -> True
_ -> False
isNewTyCon other = False