Commit f6ab0f2d authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor TyCon to eliminate TupleTyCon

This makes TupleTyCon into an ordinary AlgTyCon, distinguished
by its AlgTyConRhs, rather than a separate constructor of TyCon.

It is preparatory work for making constraint tuples into classes,
for which the ConstraintTuple tuples will have a TyConParent
of a ClassTyCon.  Tuples didn't have this possiblity before.

The patch affects other modules because I eliminated the
unsatisfactory partial functions tupleTyConBoxity and tupleTyConSort.
And tupleTyConArity which is just tyConArity.
parent bbfa0caa
......@@ -137,8 +137,9 @@ ppr_expr add_par expr@(App {})
Var f -> case isDataConWorkId_maybe f of
-- Notice that we print the *worker*
-- for tuples in paren'd format.
Just dc | saturated && isTupleTyCon tc
-> tupleParens (tupleTyConSort tc) pp_tup_args
Just dc | saturated
, Just sort <- tyConTuple_maybe tc
-> tupleParens sort pp_tup_args
where
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
......@@ -228,8 +229,8 @@ pprCoreAlt (con, args, rhs)
ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat (DataAlt dc) args
| isTupleTyCon tc
= tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args)))
| Just sort <- tyConTuple_maybe tc
= tupleParens sort (hsep (punctuate comma (map ppr_bndr args)))
where
ppr_bndr = pprBndr CaseBind
tc = dataConTyCon dc
......
......@@ -595,7 +595,8 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats})
(ps, constraints)
| isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) [])
| Just sort <- tyConTuple_maybe tc
= (noLoc (TuplePat pats_con (tupleSortBoxity sort) [])
: rest_pats, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)
: rest_pats, constraints)
......
......@@ -320,11 +320,14 @@ putName _dict BinSymbolTable{
| otherwise
= case wiredInNameTyThing_maybe name of
Just (ATyCon tc)
| isTupleTyCon tc -> putTupleName_ bh tc 0
| Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 0
Just (AConLike (RealDataCon dc))
| let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1
| let tc = dataConTyCon dc
, Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 1
Just (AnId x)
| Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2
| Just dc <- isDataConWorkId_maybe x
, let tc = dataConTyCon dc
, Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 2
_ -> do
symtab_map <- readIORef symtab_map_ref
case lookupUFM symtab_map name of
......@@ -337,16 +340,16 @@ putName _dict BinSymbolTable{
$! addToUFM symtab_map name (off,name)
put_ bh (fromIntegral off :: Word32)
putTupleName_ :: BinHandle -> TyCon -> Word32 -> IO ()
putTupleName_ bh tc thing_tag
putTupleName_ :: BinHandle -> TyCon -> TupleSort -> Word32 -> IO ()
putTupleName_ bh tc tup_sort thing_tag
= -- ASSERT(arity < 2^(30 :: Int))
put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity)
where
arity = fromIntegral (tupleTyConArity tc)
sort_tag = case tupleTyConSort tc of
BoxedTuple -> 0
UnboxedTuple -> 1
ConstraintTuple -> 2
arity = fromIntegral (tyConArity tc)
sort_tag = case tup_sort of
BoxedTuple -> 0
UnboxedTuple -> 1
ConstraintTuple -> 2
-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
......
......@@ -548,11 +548,11 @@ ppr_iface_tc_app pp ctxt_prec tc tys
| Just dc <- isPromotedDataCon_maybe tc
, let dc_tc = dataConTyCon dc
, isTupleTyCon dc_tc
, Just tup_sort <- tyConTuple_maybe dc_tc
, let arity = tyConArity dc_tc
ty_args = drop arity tys
, ty_args `lengthIs` arity
-> Just (tupleTyConSort tc, ty_args)
-> Just (tup_sort, ty_args)
_ -> Nothing
......
......@@ -1689,11 +1689,14 @@ tyConToIfaceDecl env tycon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon
ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
-- in TcRnDriver for GHCi, when browsing a module, in which case the
-- AbstractTyCon case is perfectly sensible.
-- The AbstractTyCon case happens when a TyCon has been trimmed
-- during tidying.
-- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
-- for GHCi, when browsing a module, in which case the
-- AbstractTyCon and TupleTyCon cases are perfectly sensible.
-- (Tuple declarations are not serialised into interface files.)
ifaceConDecl data_con
= IfCon { ifConOcc = getOccName (dataConName data_con),
......@@ -2029,8 +2032,9 @@ toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
= case isDataConWorkId_maybe v of
-- We convert the *worker* for tuples into IfaceTuples
Just dc | isTupleTyCon tc && saturated
-> IfaceTuple (tupleTyConSort tc) tup_args
Just dc | saturated
, Just tup_sort <- tyConTuple_maybe tc
-> IfaceTuple tup_sort tup_args
where
val_args = dropWhile isTypeArg as
saturated = val_args `lengthIs` idArity v
......
......@@ -399,9 +399,9 @@ mkTupleOcc ns sort ar = mkOccName ns str
tupleTyCon :: TupleSort -> Arity -> TyCon
tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially
tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i)
tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i)
tupleTyCon ConstraintTuple i = fst (factTupleArr ! i)
tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i)
tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i)
tupleTyCon ConstraintTuple i = fst (factTupleArr ! i)
promotedTupleTyCon :: TupleSort -> Arity -> TyCon
promotedTupleTyCon sort i = promoteTyCon (tupleTyCon sort i)
......@@ -416,9 +416,9 @@ tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i)
tupleCon ConstraintTuple i = snd (factTupleArr ! i)
boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon)
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]]
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]]
mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
mk_tuple sort arity = (tycon, tuple_con)
......
......@@ -1644,11 +1644,12 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
| not (or xcs) = (caseTrivial, False) -- Variable does not occur
-- At this point we know that xrs, xcs is not empty,
-- and at least one xr is True
| isTupleTyCon con = (caseTuple (tupleTyConSort con) xrs, True)
| Just sort <- tyConTuple_maybe con
= (caseTuple sort xrs, True)
| or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
| otherwise = case splitAppTy_maybe ty of -- T (..no var..) ty
Nothing -> (caseWrongArg, True) -- Non-decomposable (eg type function)
Just (fun_ty, _) -> (caseTyApp fun_ty (last xrs), True)
| Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
= (caseTyApp fun_ty (last xrs), True)
| otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
where
(xrs,xcs) = unzip (map (go co) args)
go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
......
......@@ -486,14 +486,17 @@ could change.
isPromotableTyCon :: NameSet -> TyCon -> Bool
isPromotableTyCon rec_tycons tc
= isAlgTyCon tc -- Only algebraic; not even synonyms
-- (we could reconsider the latter)
-- (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
DataTyCon { data_cons = cs } -> all ok_con cs
NewTyCon { data_con = c } -> ok_con c
AbstractTyCon {} -> False
DataFamilyTyCon {} -> False
TupleTyCon { tup_sort = sort } -> case sort of
BoxedTuple -> True
UnboxedTuple -> False
ConstraintTuple -> False
where
ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
where -- Checks for * -> ... -> * -> *
......
......@@ -73,7 +73,6 @@ module TyCon(
algTyConRhs,
newTyConRhs, newTyConEtadArity, newTyConEtadRhs,
unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,
tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
-- ** Manipulating TyCons
expandSynTyCon_maybe,
......@@ -407,36 +406,6 @@ data TyCon
tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any
}
-- | Represents the infinite family of tuple type constructors,
-- @()@, @(a,b)@, @(# a, b #)@ etc.
| TupleTyCon {
tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant:
-- identical to Unique of Name stored in
-- tyConName field.
tyConName :: Name, -- ^ Name of the constructor
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
tyConArity :: Arity, -- ^ Number of arguments this TyCon must
-- receive to be considered saturated
-- (including implicit kind variables)
tyConTupleSort :: TupleSort,-- ^ Is this a boxed, unboxed or constraint
-- tuple?
tyConTyVars :: [TyVar], -- ^ List of type and kind variables in this
-- TyCon. Includes implicit kind variables.
-- Invariant:
-- length tyConTyVars = tyConArity
dataCon :: DataCon, -- ^ Corresponding tuple data constructor
tcPromoted :: Maybe TyCon
-- ^ Nothing for unboxed tuples
}
-- | Represents type synonyms
| SynonymTyCon {
tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant:
......@@ -595,6 +564,12 @@ data AlgTyConRhs
-- See Note [Enumeration types]
}
| TupleTyCon { -- A boxed, unboxed, or constraint tuple
data_con :: DataCon, -- NB: it can be an *unboxed* tuple
tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint
-- tuple?
}
-- | Information about those 'TyCon's derived from a @newtype@ declaration
| NewTyCon {
data_con :: DataCon, -- ^ The unique constructor for the @newtype@.
......@@ -640,6 +615,7 @@ visibleDataCons (AbstractTyCon {}) = []
visibleDataCons DataFamilyTyCon {} = []
visibleDataCons (DataTyCon{ data_cons = cs }) = cs
visibleDataCons (NewTyCon{ data_con = c }) = [c]
visibleDataCons (TupleTyCon{ data_con = c }) = [c]
-- ^ Both type classes as well as family instances imply implicit
-- type constructors. These implicit type constructors refer to their parent
......@@ -1068,15 +1044,20 @@ mkTupleTyCon :: Name
-> Maybe TyCon -- ^ Promoted version
-> TyCon
mkTupleTyCon name kind arity tyvars con sort prom_tc
= TupleTyCon {
tyConUnique = nameUnique name,
tyConName = name,
tyConKind = kind,
tyConArity = arity,
tyConTupleSort = sort,
tyConTyVars = tyvars,
dataCon = con,
tcPromoted = prom_tc
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConKind = kind,
tyConArity = arity,
tyConTyVars = tyvars,
tcRoles = replicate arity Representational,
tyConCType = Nothing,
algTcStupidTheta = [],
algTcRhs = TupleTyCon { data_con = con, tup_sort = sort },
algTcParent = NoParentTyCon,
algTcRec = NonRecursive,
algTcGadtSyntax = False,
tcPromoted = prom_tc
}
-- | Create an unlifted primitive 'TyCon', such as @Int#@
......@@ -1188,14 +1169,17 @@ isPrimTyCon _ = False
-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can
-- only be true for primitive and unboxed-tuple 'TyCon's
isUnLiftedTyCon :: TyCon -> Bool
isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted
isUnLiftedTyCon tc = isUnboxedTupleTyCon tc
isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted})
= is_unlifted
isUnLiftedTyCon (AlgTyCon { algTcRhs = rhs } )
| TupleTyCon { tup_sort = sort } <- rhs
= not (isBoxed (tupleSortBoxity sort))
isUnLiftedTyCon _ = False
-- | Returns @True@ if the supplied 'TyCon' resulted from either a
-- @data@ or @newtype@ declaration
isAlgTyCon :: TyCon -> Bool
isAlgTyCon (AlgTyCon {}) = True
isAlgTyCon (TupleTyCon {}) = True
isAlgTyCon _ = False
isDataTyCon :: TyCon -> Bool
......@@ -1211,11 +1195,13 @@ isDataTyCon :: TyCon -> Bool
-- get an info table. The family declaration 'TyCon' does not
isDataTyCon (AlgTyCon {algTcRhs = rhs})
= case rhs of
TupleTyCon { tup_sort = sort }
-> isBoxed (tupleSortBoxity sort)
DataTyCon {} -> True
NewTyCon {} -> False
DataFamilyTyCon {} -> False
AbstractTyCon {} -> False -- We don't know, so return False
isDataTyCon tc = isBoxedTupleTyCon tc
isDataTyCon _ = False
-- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to
-- themselves, even via coercions (except for unsafeCoerce).
......@@ -1228,12 +1214,12 @@ isDataTyCon tc = isBoxedTupleTyCon tc
isDistinctTyCon :: TyCon -> Bool
isDistinctTyCon (AlgTyCon {algTcRhs = rhs}) = isDistinctAlgRhs rhs
isDistinctTyCon (FunTyCon {}) = True
isDistinctTyCon (TupleTyCon {}) = True
isDistinctTyCon (PrimTyCon {}) = True
isDistinctTyCon (PromotedDataCon {}) = True
isDistinctTyCon _ = False
isDistinctAlgRhs :: AlgTyConRhs -> Bool
isDistinctAlgRhs (TupleTyCon {}) = True
isDistinctAlgRhs (DataTyCon {}) = True
isDistinctAlgRhs (DataFamilyTyCon {}) = True
isDistinctAlgRhs (AbstractTyCon distinct) = distinct
......@@ -1264,25 +1250,27 @@ isProductTyCon :: TyCon -> Bool
-- True of datatypes or newtypes that have
-- one, non-existential, data constructor
-- See Note [Product types]
isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
DataTyCon{ data_cons = [data_con] }
-> null (dataConExTyVars data_con)
NewTyCon {} -> True
_ -> False
isProductTyCon (TupleTyCon {}) = True
isProductTyCon _ = False
isProductTyCon tc@(AlgTyCon {})
= case algTcRhs tc of
TupleTyCon {} -> True
DataTyCon{ data_cons = [data_con] }
-> null (dataConExTyVars data_con)
NewTyCon {} -> True
_ -> False
isProductTyCon _ = False
isDataProductTyCon_maybe :: TyCon -> Maybe DataCon
-- True of datatypes (not newtypes) with
-- one, vanilla, data constructor
-- See Note [Product types]
isDataProductTyCon_maybe (AlgTyCon { algTcRhs = DataTyCon { data_cons = cons } })
| [con] <- cons -- Singleton
, null (dataConExTyVars con) -- non-existential
= Just con
isDataProductTyCon_maybe (TupleTyCon { dataCon = con })
= Just con
isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })
= case rhs of
DataTyCon { data_cons = [con] }
| null (dataConExTyVars con) -- non-existential
-> Just con
TupleTyCon { data_con = con }
-> Just con
_ -> Nothing
isDataProductTyCon_maybe _ = Nothing
{- Note [Product types]
......@@ -1344,9 +1332,12 @@ isGadtSyntaxTyCon _ = False
-- | Is this an algebraic 'TyCon' which is just an enumeration of values?
isEnumerationTyCon :: TyCon -> Bool
-- See Note [Enumeration types] in TyCon
isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res
isEnumerationTyCon (TupleTyCon {tyConArity = arity}) = arity == 0
isEnumerationTyCon _ = False
isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs })
= case rhs of
DataTyCon { is_enum = res } -> res
TupleTyCon {} -> arity == 0
_ -> False
isEnumerationTyCon _ = False
-- | Is this a 'TyCon', synonym or otherwise, that defines a family?
isFamilyTyCon :: TyCon -> Bool
......@@ -1406,34 +1397,27 @@ isTupleTyCon :: TyCon -> Bool
-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they
-- get spat into the interface file as tuple tycons, so I don't think
-- it matters.
isTupleTyCon (TupleTyCon {}) = True
isTupleTyCon _ = False
isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True
isTupleTyCon _ = False
tyConTuple_maybe :: TyCon -> Maybe TupleSort
tyConTuple_maybe (AlgTyCon { algTcRhs = rhs })
| TupleTyCon { tup_sort = sort} <- rhs = Just sort
tyConTuple_maybe _ = Nothing
-- | Is this the 'TyCon' for an unboxed tuple?
isUnboxedTupleTyCon :: TyCon -> Bool
isUnboxedTupleTyCon (TupleTyCon {tyConTupleSort = sort}) =
not (isBoxed (tupleSortBoxity sort))
isUnboxedTupleTyCon _ = False
isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs })
| TupleTyCon { tup_sort = sort } <- rhs
= not (isBoxed (tupleSortBoxity sort))
isUnboxedTupleTyCon _ = False
-- | Is this the 'TyCon' for a boxed tuple?
isBoxedTupleTyCon :: TyCon -> Bool
isBoxedTupleTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort)
isBoxedTupleTyCon _ = False
-- | Extract the boxity of the given 'TyCon', if it is a 'TupleTyCon'.
-- Panics otherwise
tupleTyConBoxity :: TyCon -> Boxity
tupleTyConBoxity tc = tupleSortBoxity (tyConTupleSort tc)
-- | Extract the 'TupleSort' of the given 'TyCon', if it is a 'TupleTyCon'.
-- Panics otherwise
tupleTyConSort :: TyCon -> TupleSort
tupleTyConSort tc = tyConTupleSort tc
-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'.
-- Panics otherwise
tupleTyConArity :: TyCon -> Arity
tupleTyConArity tc = tyConArity tc
isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs })
| TupleTyCon { tup_sort = sort } <- rhs
= isBoxed (tupleSortBoxity sort)
isBoxedTupleTyCon _ = False
-- | Is this a recursive 'TyCon'?
isRecursiveTyCon :: TyCon -> Bool
......@@ -1442,7 +1426,6 @@ isRecursiveTyCon _ = False
promotableTyCon_maybe :: TyCon -> Maybe TyCon
promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom
promotableTyCon_maybe (TupleTyCon { tcPromoted = prom }) = prom
promotableTyCon_maybe _ = Nothing
promoteTyCon :: TyCon -> TyCon
......@@ -1483,10 +1466,10 @@ isPromotedDataCon_maybe _ = Nothing
-- (similar to a @dfun@ does that for a class instance).
isImplicitTyCon :: TyCon -> Bool
isImplicitTyCon (FunTyCon {}) = True
isImplicitTyCon (TupleTyCon {}) = True
isImplicitTyCon (PrimTyCon {}) = True
isImplicitTyCon (PromotedDataCon {}) = True
isImplicitTyCon (PromotedTyCon {}) = True
isImplicitTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True
isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True
isImplicitTyCon (AlgTyCon {}) = False
isImplicitTyCon (FamilyTyCon { famTcParent = AssocFamilyTyCon {} }) = True
......@@ -1537,31 +1520,54 @@ tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []
-- is the sort that can have any constructors (note: this does not include
-- abstract algebraic types)
tyConDataCons_maybe :: TyCon -> Maybe [DataCon]
tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }})
= Just cons
tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }})
= Just [con]
tyConDataCons_maybe (TupleTyCon {dataCon = con})
= Just [con]
tyConDataCons_maybe _
= Nothing
tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs})
= case rhs of
DataTyCon { data_cons = cons } -> Just cons
NewTyCon { data_con = con } -> Just [con]
TupleTyCon { data_con = con } -> Just [con]
_ -> Nothing
tyConDataCons_maybe _ = Nothing
-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@
-- type with one alternative, a tuple type or a @newtype@ then that constructor
-- is returned. If the 'TyCon' has more than one constructor, or represents a
-- primitive or function type constructor then @Nothing@ is returned. In any
-- other case, the function panics
tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon
tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })
= case rhs of
DataTyCon { data_cons = [c] } -> Just c
TupleTyCon { data_con = c } -> Just c
NewTyCon { data_con = c } -> Just c
_ -> Nothing
tyConSingleDataCon_maybe _ = Nothing
tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon
-- Returns (Just con) for single-constructor
-- *algebraic* data types *not* newtypes
tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })
= case rhs of
DataTyCon { data_cons = [c] } -> Just c
TupleTyCon { data_con = c } -> Just c
_ -> Nothing
tyConSingleAlgDataCon_maybe _ = Nothing
-- | Determine the number of value constructors a 'TyCon' has. Panics if the
-- 'TyCon' is not algebraic or a tuple
tyConFamilySize :: TyCon -> Int
tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) =
length cons
tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1
tyConFamilySize (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = 0
tyConFamilySize (TupleTyCon {}) = 1
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })
= case rhs of
DataTyCon { data_cons = cons } -> length cons
NewTyCon {} -> 1
TupleTyCon {} -> 1
DataFamilyTyCon {} -> 0
_ -> pprPanic "tyConFamilySize 1" (ppr tc)
tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)
-- | Extract an 'AlgTyConRhs' with information about data constructors from an
-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'
algTyConRhs :: TyCon -> AlgTyConRhs
algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs
algTyConRhs (TupleTyCon {dataCon = con, tyConArity = arity})
= DataTyCon { data_cons = [con], is_enum = arity == 0 }
algTyConRhs other = pprPanic "algTyConRhs" (ppr other)
-- | Get the list of roles for the type parameters of a TyCon
......@@ -1571,7 +1577,6 @@ tyConRoles tc
= case tc of
{ FunTyCon {} -> const_role Representational
; AlgTyCon { tcRoles = roles } -> roles
; TupleTyCon {} -> const_role Representational
; SynonymTyCon { tcRoles = roles } -> roles
; FamilyTyCon {} -> const_role Nominal
; PrimTyCon { tcRoles = roles } -> roles
......@@ -1624,7 +1629,6 @@ tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep
-- @data Eq a => T a ...@
tyConStupidTheta :: TyCon -> [PredType]
tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid
tyConStupidTheta (TupleTyCon {}) = []
tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)
-- | Extract the 'TyVar's bound by a vanilla type synonym
......@@ -1646,31 +1650,6 @@ famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav
famTyConFlav_maybe _ = Nothing
-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@
-- type with one alternative, a tuple type or a @newtype@ then that constructor
-- is returned. If the 'TyCon' has more than one constructor, or represents a
-- primitive or function type constructor then @Nothing@ is returned. In any
-- other case, the function panics
tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon
tyConSingleDataCon_maybe (TupleTyCon {dataCon = c})
= Just c
tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }})
= Just c
tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }})
= Just c
tyConSingleDataCon_maybe _
= Nothing
tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon
-- Returns (Just con) for single-constructor *algebraic* data types
-- *not* newtypes
tyConSingleAlgDataCon_maybe (TupleTyCon {dataCon = c})
= Just c
tyConSingleAlgDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons= [c] }})
= Just c
tyConSingleAlgDataCon_maybe _
= Nothing
-- | Is this 'TyCon' that for a class instance?
isClassTyCon :: TyCon -> Bool
isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True
......@@ -1682,10 +1661,6 @@ tyConClass_maybe :: TyCon -> Maybe Class
tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
tyConClass_maybe _ = Nothing
tyConTuple_maybe :: TyCon -> Maybe TupleSort
tyConTuple_maybe (TupleTyCon {tyConTupleSort = sort}) = Just sort
tyConTuple_maybe _ = Nothing
----------------------------------------------------------------------------
tyConParent :: TyCon -> TyConParent
tyConParent (AlgTyCon {algTcParent = parent}) = parent
......
......@@ -732,32 +732,33 @@ pprTcApp _ pp tc [ty]
| tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
pprTcApp p pp tc tys
| isTupleTyCon tc && tyConArity tc == length tys
= pprTupleApp p pp tc tys
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys