From 6777144f7522d8db5935737e12fa451ca3211e6d Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 11 May 2007 11:30:57 +0000 Subject: [PATCH] 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. ** --- compiler/hsSyn/HsDecls.lhs | 7 +++---- compiler/iface/BinIface.hs | 8 +++----- compiler/iface/BuildTyCl.lhs | 7 ++----- compiler/iface/IfaceSyn.lhs | 5 ----- compiler/iface/MkIface.lhs | 3 +-- compiler/iface/TcIface.lhs | 1 - compiler/parser/Parser.y.pp | 10 ++++------ compiler/rename/RnSource.lhs | 4 ++-- compiler/typecheck/TcDeriv.lhs | 5 ++++- compiler/typecheck/TcTyClsDecls.lhs | 17 ++++++----------- compiler/types/TyCon.lhs | 6 +----- 11 files changed, 26 insertions(+), 47 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index bd2593f..37ab35a 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 49235d9..bea0de1 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -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) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 707de1c..333d808 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ad4c913..5a18da3 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 811af49..cca8ab5 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 0ee3e00..0dbf6eb 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 9ad9518..cc348bd 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index b7b4f0b..6d90eaa 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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" diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 98d7fcf..1a9a881 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 34022db..50e0f4c 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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 diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 90ac71c..85881b6 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -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 -- 1.7.10.4