Commit 09ff0e0d authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor and improve the promotion inference

It should be the case that either an entire mutually recursive
group of data type declarations can be promoted, or none of them.
It's really odd to promote some data constructors of a type but
not others. Eg
  data T a = T1 a | T2 Int
Here T1 is sort-of-promotable but T2 isn't (becuase Int isn't
promotable).

This patch makes it all-or-nothing. At the same time I've made
the TyCon point to its promoted cousin (via the tcPromoted field
of an AlgTyCon), as well as vice versa (via the ty_con field of
PromotedTyCon).

The inference for the group is done in TcTyDecls, the same place
that infers which data types are recursive, another global question.
parent 35f1fc95
......@@ -19,6 +19,7 @@ module DataCon (
-- ** Type construction
mkDataCon, fIRST_TAG,
buildAlgTyCon,
-- ** Type deconstruction
dataConRepType, dataConSig, dataConFullSig,
......@@ -45,8 +46,7 @@ module DataCon (
splitProductType_maybe, splitProductType,
-- ** Promotion related functions
isPromotableTyCon, promoteTyCon,
promoteDataCon, promoteDataCon_maybe
promoteKind, promoteDataCon, promoteDataCon_maybe
) where
#include "HsVersions.h"
......@@ -55,6 +55,7 @@ import {-# SOURCE #-} MkId( DataConBoxer )
import Type
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import ForeignCall( CType )
import Coercion
import Kind
import Unify
......@@ -73,6 +74,7 @@ import VarEnv
import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Maybe
import Data.Char
import Data.Word
\end{code}
......@@ -639,7 +641,6 @@ mkDataCon name declared_infix
dcRepArity = length rep_arg_tys,
dcPromoted = mb_promoted }
--
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
......@@ -651,11 +652,9 @@ mkDataCon name declared_infix
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon
| all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
-- No kind polymorphism, and all of kind *
, null eq_spec -- No constraints
, null theta
, all isPromotableType orig_arg_tys
| isJust (promotableTyCon_maybe rep_tycon)
-- The TyCon is promotable only if all its datacons
-- are, so the promoteType for prom_kind should succeed
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
| otherwise
= Nothing
......@@ -993,6 +992,41 @@ dataConCannotMatch tys con
_ -> []
\end{code}
%************************************************************************
%* *
Building an algebraic data type
%* *
%************************************************************************
\begin{code}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> this TyCon is promotable
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
mb_promoted_tc
| is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
| otherwise = Nothing
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
......@@ -1051,7 +1085,6 @@ splitProductType str ty
These two 'promoted..' functions are here because
* They belong together
* 'promoteTyCon' is used by promoteType
* 'prmoteDataCon' depends on DataCon stuff
\begin{code}
......@@ -1061,10 +1094,6 @@ promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
promoteTyCon :: TyCon -> TyCon
promoteTyCon tc
= mkPromotedTyCon tc (promoteKind (tyConKind tc))
\end{code}
Note [Promoting a Type to a Kind]
......@@ -1085,24 +1114,6 @@ The transformation from type to kind is done by promoteType
* -> ... -> * -> *
\begin{code}
isPromotableType :: Type -> Bool
isPromotableType (TyConApp tc tys)
| Just n <- isPromotableTyCon tc = tys `lengthIs` n && all isPromotableType tys
isPromotableType (FunTy arg res) = isPromotableType arg && isPromotableType res
isPromotableType (TyVarTy {}) = True
isPromotableType _ = False
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int
isPromotableTyCon tc
| isDataTyCon tc || isNewTyCon tc
-- Only *data* and *newtype* types can be promoted,
-- not synonyms, not type/data families
, all isLiftedTypeKind (res:args) = Just $ length args
| otherwise = Nothing
where
(args, res) = splitKindFunTys (tyConKind tc)
-- | Promotes a type to a kind.
-- Assumes the argument satisfies 'isPromotableType'
promoteType :: Type -> Kind
......@@ -1113,7 +1124,8 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) = mkTyConApp (promoteTyCon tc) (map go tys)
go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
= mkTyConApp prom_tc (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv
......
......@@ -1326,7 +1326,7 @@ instance Binary IfaceDecl where
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
......@@ -1336,6 +1336,7 @@ instance Binary IfaceDecl where
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh a9
put_ bh (IfaceSyn a1 a2 a3 a4) = do
putByte bh 3
......@@ -1378,8 +1379,9 @@ instance Binary IfaceDecl where
a6 <- get bh
a7 <- get bh
a8 <- get bh
a9 <- get bh
occ <- return $! mkOccNameFS tcName a1
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9)
3 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
......
......@@ -29,7 +29,6 @@ import DataCon
import Var
import VarSet
import BasicTypes
import ForeignCall
import Name
import MkId
import Class
......@@ -56,21 +55,6 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent
= return (mkSynTyCon tc_name kind tvs rhs parent)
where kind = mkPiKinds tvs rhs_kind
------------------------------------------------------
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs cType stupid_theta rhs is_rec gadt_syn parent
= mkAlgTyCon tc_name kind ktvs cType stupid_theta rhs parent is_rec gadt_syn
where
kind = mkPiKinds ktvs liftedTypeKind
------------------------------------------------------
distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
......
......@@ -82,6 +82,7 @@ data IfaceDecl
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data/data family info
ifRec :: RecFlag, -- Recursive or not?
ifPromotable :: Bool, -- Promotable to kind level?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
ifAxiom :: Maybe IfExtName -- The axiom, for a newtype,
......@@ -511,11 +512,16 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
ifRec = isrec, ifAxiom = mbAxiom})
ifRec = isrec, ifPromotable = is_prom,
ifAxiom = mbAxiom})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [pprCType cType, pprRec isrec, pp_condecls tycon condecls,
pprAxiom mbAxiom])
4 (vcat [ pprCType cType
, pprRec isrec <> comma <+> pp_prom
, pp_condecls tycon condecls
, pprAxiom mbAxiom])
where
pp_prom | is_prom = ptext (sLit "Promotable")
| otherwise = ptext (sLit "Not promotable")
pp_nd = case condecls of
IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
IfDataFamTyCon -> ptext (sLit "data family")
......
......@@ -1479,6 +1479,7 @@ tyConToIfaceDecl env tycon
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifPromotable = isJust (promotableTyCon_maybe tycon),
ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
| isForeignTyCon tycon
......
......@@ -437,7 +437,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
ifRec = is_rec, ifPromotable = is_prom,
ifAxiom = mb_axiom_name })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
......@@ -446,7 +446,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
; parent' <- tc_parent tyvars mb_axiom_name
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; return (buildAlgTyCon tc_name tyvars cType stupid_theta
cons is_rec gadt_syn parent') }
cons is_rec is_prom gadt_syn parent') }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
......@@ -1397,8 +1397,10 @@ tcIfaceKindCon (IfaceTc name)
; case thing of -- A "type constructor" here is a promoted type constructor
-- c.f. Trac #5881
ATyCon tc
| isSuperKind (tyConKind tc) -> return tc -- Mainly just '*' or 'AnyK'
| otherwise -> return (promoteTyCon tc)
| isSuperKind (tyConKind tc)
-> return tc -- Mainly just '*' or 'AnyK'
| Just prom_tc <- promotableTyCon_maybe tc
-> return prom_tc
_ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
......
......@@ -240,23 +240,22 @@ eqTyCon_RDR = nameRdrName eqTyConName
\begin{code}
pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcNonRecDataTyCon = pcTyCon False NonRecursive
pcRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcRecDataTyCon = pcTyCon False Recursive
-- Not an enumeration, not promotable
pcNonRecDataTyCon = pcTyCon False NonRecursive False
pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec name cType tyvars cons
pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec is_prom name cType tyvars cons
= tycon
where
tycon = mkAlgTyCon name
(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
tycon = buildAlgTyCon name
tyvars
cType
[] -- No stupid theta
(DataTyCon cons is_enum)
NoParentTyCon
is_rec
is_prom
False -- Not in GADT syntax
NoParentTyCon
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon = pcDataConWithFixity False
......@@ -368,7 +367,12 @@ factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [
mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
mk_tuple sort arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc
prom_tc = case sort of
BoxedTuple -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
UnboxedTuple -> Nothing
ConstraintTuple -> Nothing
modu = mkTupleModule sort arity
tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
......@@ -434,6 +438,7 @@ eqTyCon = mkAlgTyCon eqTyConName
NoParentTyCon
NonRecursive
False
Nothing -- No parent for constraint-kinded types
where
kv = kKiVar
k = mkTyVarTy kv
......@@ -579,7 +584,7 @@ boolTy :: Type
boolTy = mkTyConTy boolTyCon
boolTyCon :: TyCon
boolTyCon = pcTyCon True NonRecursive boolTyConName
boolTyCon = pcTyCon True NonRecursive True boolTyConName
(Just (CType Nothing (fsLit "HsBool")))
[] [falseDataCon, trueDataCon]
......@@ -592,7 +597,7 @@ falseDataConId = dataConWorkId falseDataCon
trueDataConId = dataConWorkId trueDataCon
orderingTyCon :: TyCon
orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing
orderingTyCon = pcTyCon True NonRecursive True orderingTyConName Nothing
[] [ltDataCon, eqDataCon, gtDataCon]
ltDataCon, eqDataCon, gtDataCon :: DataCon
......@@ -626,7 +631,8 @@ mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon :: TyCon
listTyCon = pcRecDataTyCon listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
listTyCon = pcTyCon False Recursive True
listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
mkPromotedListTy :: Type -> Type
mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
......
......@@ -106,7 +106,10 @@ genGenericMetaTyCons tc mod =
mkTyCon name = ASSERT( isExternalName name )
buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs
NonRecursive False NoParentTyCon
NonRecursive
False -- Not promotable
False -- Not GADT syntax
NoParentTyCon
let metaDTyCon = mkTyCon d_name
metaCTyCons = map mkTyCon c_names
......
......@@ -626,8 +626,9 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon
-> do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds $ promotionErr name NoDataKinds
; inst_tycon (mkTyConApp tc) (tyConKind tc) }
| otherwise -> failWithTc (quotes (ppr dc) <+> ptext (sLit "of type")
<+> quotes (ppr (dataConUserType dc)) <+> ptext (sLit "is not promotable"))
| otherwise -> failWithTc (ptext (sLit "Data constructor") <+> quotes (ppr dc)
<+> ptext (sLit "comes from an un-promotable type")
<+> quotes (ppr (dataConTyCon dc)))
APromotionErr err -> promotionErr name err
......@@ -1485,9 +1486,9 @@ tc_kind_var_app name arg_kis
AGlobal (ATyCon tc)
-> do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds $ addErr (dataKindsErr name)
; case isPromotableTyCon tc of
Just n | n == length arg_kis ->
return (mkTyConApp (promoteTyCon tc) arg_kis)
; case promotableTyCon_maybe tc of
Just prom_tc | arg_kis `lengthIs` tyConArity prom_tc
-> return (mkTyConApp prom_tc arg_kis)
Just _ -> tycon_err tc "is not fully applied"
Nothing -> tycon_err tc "is not promotable" }
......
......@@ -715,7 +715,9 @@ tcDataFamInstDecl mb_clsinfo fam_tc
fam_inst = mkDataFamInst axiom_name tvs'' fam_tc pats'' rep_tc
parent = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats''
rep_tc = buildAlgTyCon rep_tc_name tvs'' cType stupid_theta tc_rhs
Recursive h98_syntax parent
Recursive
False -- No promotable to the kind level
h98_syntax parent
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
......
......@@ -564,32 +564,32 @@ TyCons or Classes of this recursive group. Earlier, finished groups,
live in the global env only.
\begin{code}
tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
tcTyClDecl calc_isrec (L loc decl)
tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM [TyThing]
tcTyClDecl rec_info (L loc decl)
= setSrcSpan loc $ tcAddDeclCtxt decl $
traceTc "tcTyAndCl-x" (ppr decl) >>
tcTyClDecl1 NoParentTyCon calc_isrec decl
tcTyClDecl1 NoParentTyCon rec_info decl
-- "type family" declarations
tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _calc_isrec (FamDecl { tcdFam = fd })
tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
= tcFamDecl1 parent fd
-- "type" synonym declaration
tcTyClDecl1 _parent _calc_isrec
tcTyClDecl1 _parent _rec_info
(SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind ->
tcTySynRhs tc_name tvs' kind rhs
-- "data/newtype" declaration
tcTyClDecl1 _parent calc_isrec
tcTyClDecl1 _parent rec_info
(DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn })
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind ->
tcDataDefn calc_isrec tc_name tvs' kind defn
tcDataDefn rec_info tc_name tvs' kind defn
tcTyClDecl1 _parent calc_isrec
tcTyClDecl1 _parent rec_info
(ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
, tcdCtxt = ctxt, tcdMeths = meths
, tcdFDs = fundeps, tcdSigs = sigs
......@@ -616,7 +616,7 @@ tcTyClDecl1 _parent calc_isrec
-- hold of the name of the class TyCon, which we
-- need to look up its recursiveness
tycon_name = tyConName (classTyCon clas)
tc_isrec = calc_isrec tycon_name
tc_isrec = rti_is_rec rec_info tycon_name
; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
......@@ -675,7 +675,10 @@ tcFamDecl1 parent
; extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
tycon = buildAlgTyCon tc_name final_tvs Nothing []
DataFamilyTyCon Recursive True parent
DataFamilyTyCon Recursive
False -- Not promotable to the kind level
True -- GADT syntax
parent
; return [ATyCon tycon] }
tcTySynRhs :: Name
......@@ -690,17 +693,16 @@ tcTySynRhs tc_name tvs kind hs_ty
kind NoParentTyCon
; return [ATyCon tycon] }
tcDataDefn :: (Name -> RecFlag) -> Name
tcDataDefn :: RecTyInfo -> Name
-> [TyVar] -> Kind
-> HsDataDefn Name -> TcM [TyThing]
-- NB: not used for newtype/data instances (whether associated or not)
tcDataDefn calc_isrec tc_name tvs kind
tcDataDefn rec_info tc_name tvs kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_kindSig = mb_ksig
, dd_cons = cons })
= do { extra_tvs <- tcDataKindSig kind
; let is_rec = calc_isrec tc_name
final_tvs = tvs ++ extra_tvs
; let final_tvs = tvs ++ extra_tvs
; stupid_theta <- tcHsContext ctxt
; kind_signatures <- xoptM Opt_KindSignatures
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
......@@ -726,7 +728,9 @@ tcDataDefn calc_isrec tc_name tvs kind
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
is_rec (not h98_syntax) NoParentTyCon) }
(rti_is_rec rec_info tc_name)
(rti_promotable rec_info)
(not h98_syntax) NoParentTyCon) }
; return [ATyCon tycon] }
\end{code}
......
......@@ -17,7 +17,7 @@ files for imported data types.
-- for details
module TcTyDecls(
calcRecFlags,
calcRecFlags, RecTyInfo(..),
calcSynCycles, calcClassCycles
) where
......@@ -27,9 +27,11 @@ import TypeRep
import HsSyn
import Class
import Type
import Kind
import HscTypes
import TyCon
import DataCon
import Var
import Name
import NameEnv
import NameSet
......@@ -38,8 +40,8 @@ import Digraph
import BasicTypes
import SrcLoc
import UniqSet
import Maybes( mapCatMaybes )
import Util ( isSingleton )
import Maybes( mapCatMaybes, isJust )
import Util ( lengthIs, isSingleton )
import Data.List
\end{code}
......@@ -348,12 +350,24 @@ recursiveness, because we need only look at the type decls in the module being
compiled, plus the outer structure of directly-mentioned types.
\begin{code}
calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)
data RecTyInfo = RTI { rti_promotable :: Bool
, rti_is_rec :: Name -> RecFlag }
calcRecFlags :: ModDetails -> [TyThing] -> RecTyInfo
-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
-- Any type constructors in boot_names are automatically considered loop breakers
calcRecFlags boot_details tyclss
= is_rec
= RTI { rti_promotable = is_promotable
, rti_is_rec = is_rec }
where
rec_tycon_names = mkNameSet (map tyConName all_tycons)
all_tycons = mapCatMaybes getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
----------------- Recursion calculation ----------------
is_rec n | n `elemNameSet` rec_names = Recursive
| otherwise = NonRecursive
......@@ -362,12 +376,6 @@ calcRecFlags boot_details tyclss
nt_loop_breakers `unionNameSets`
prod_loop_breakers
all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
, not (tyConName tc `elemNameSet` boot_name_set) ]
-- Remove the boot_name_set because they are going
-- to be loop breakers regardless.
-------------------------------------------------
-- NOTE
......@@ -379,8 +387,13 @@ calcRecFlags boot_details tyclss
-- loop. We could program round this, but it'd make the code
-- rather less nice, so I'm not going to do that yet.
single_con_tycons = filter (isSingleton . tyConDataCons) all_tycons
single_con_tycons = [ tc | tc <- all_tycons
, not (tyConName tc `elemNameSet` boot_name_set)
-- Remove the boot_name_set because they are
-- going to be loop breakers regardless.
, isSingleton (tyConDataCons tc) ]
-- Both newtypes and data types, with exactly one data constructor
(new_tycons, prod_tycons) = partition isNewTyCon single_con_tycons
-- NB: we do *not* call isProductTyCon because that checks
-- for vanilla-ness of data constructors; and that depends
......@@ -443,6 +456,80 @@ findLoopBreakers deps
name <- tyConName tc : go edges']
\end{code}
%************************************************************************
%* *
Promotion calculation
%* *
%************************************************************************
See Note [Checking whether a group is promotable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only want to promote a TyCon if all its data constructors
are promotable; it'd be very odd to promote some but not others.
But the data constructors may mention this or other TyCons.
So we treat the recursive uses as all OK (ie promotable) and
do one pass to check that each TyCon is promotable.
Currently type synonyms are not promotable, though that
could change.
\begin{code}
isPromotableTyCon :: NameSet -> TyCon -> Bool
isPromotableTyCon rec_tycons tc
= isAlgTyCon tc -- Only algebraic; not even synonyms
-- (we could reconsider the latter)
&& ok_kind (tyConKind tc)
&& case algTyConRhs tc of
DataTyCon { data_cons = cs } -> all ok_con cs
NewTyCon { data_con = c } -> ok_con c
AbstractTyCon {} -> False
DataFamilyTyCon {} -> False
where
ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
where -- Checks for * -> ... -> * -> *
(args, res) = splitKindFunTys kind
-- See Note [Promoted data constructors] in TyCon
ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
&& null eq_spec -- No constraints
&& null theta
&& all (isPromotableType rec_tycons) orig_arg_tys
where
(_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
isPromotableType :: NameSet -> Type -> Bool
-- Must line up with DataCon.promoteType
-- But the function lives here because we must treat the
-- *recursive* tycons as promotable
isPromotableType rec_tcs ty
= case splitForAllTys ty of
(_, rho) -> go rho
where
go (TyConApp tc tys)
| tys `lengthIs` tyConArity tc