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

Remove the distinction between data and newtype families

- 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.                   **
parent 4d7f33a5
......@@ -440,7 +440,7 @@ data NewOrData
data FamilyFlavour
= TypeFamily -- "type family ..."
| DataFamily NewOrData -- "newtype family ..." or "data family ..."
| DataFamily -- "data family ..."
\end{code}
Simple classifiers
......@@ -536,9 +536,8 @@ instance OutputableBndr name
= 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
......
......@@ -1152,18 +1152,16 @@ instance Binary OverlapFlag where
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 cs }
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
2 -> return IfOpenNewTyCon
3 -> do cs <- get bh
2 -> do cs <- get bh
return (IfDataTyCon cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
......
......@@ -7,7 +7,7 @@
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
mkAbstractTyConRhs, mkOpenDataTyConRhs,
mkNewTyConRhs, mkDataTyConRhs
) where
......@@ -115,10 +115,7 @@ mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
mkOpenDataTyConRhs :: AlgTyConRhs
mkOpenDataTyConRhs = OpenTyCon Nothing False
mkOpenNewTyConRhs :: AlgTyConRhs
mkOpenNewTyConRhs = OpenTyCon Nothing True
mkOpenDataTyConRhs = OpenTyCon Nothing
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
......
......@@ -108,14 +108,12 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
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 = []
visibleIfConDecls IfOpenNewTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
......@@ -414,7 +412,6 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
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,
......@@ -440,7 +437,6 @@ pprIfaceDeclHead context thing tyvars
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(" |"))
......@@ -766,7 +762,6 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
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
......
......@@ -1100,8 +1100,7 @@ tyThingToIfaceDecl (ATyCon tycon)
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
......
......@@ -447,7 +447,6 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= 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
......
......@@ -618,7 +618,7 @@ ty_decl :: { LTyClDecl RdrName }
(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
......@@ -626,8 +626,7 @@ ty_decl :: { LTyClDecl RdrName }
"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
......@@ -682,7 +681,7 @@ at_decl_cls :: { LTyClDecl RdrName }
} }
-- 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
......@@ -690,8 +689,7 @@ at_decl_cls :: { LTyClDecl RdrName }
"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
......
......@@ -797,8 +797,8 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
emptyFVs)
} }
where
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"
......
......@@ -399,7 +399,10 @@ mkEqnHelp orig tvs cls cls_tys tc_app
; 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
......
......@@ -280,8 +280,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
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
......@@ -630,10 +629,10 @@ 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
{ 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
......@@ -643,10 +642,7 @@ tcTyClDecl1 _calc_isrec
; 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]
}
......@@ -1194,9 +1190,8 @@ wrongKindOfFamily family =
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
......
......@@ -213,16 +213,13 @@ data AlgTyConRhs
| OpenTyCon {
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.
otIsNewtype :: Bool
-- is a newtype (rather than data type)?
}
| DataTyCon {
......@@ -633,7 +630,6 @@ isDataTyCon other = False
isNewTyCon :: TyCon -> Bool
isNewTyCon (AlgTyCon {algTcRhs = rhs}) =
case rhs of
OpenTyCon {} -> otIsNewtype rhs
NewTyCon {} -> True
_ -> False
isNewTyCon other = False
......
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