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

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
= pprTupleApp p pp tc sort 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 -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3
ty_args = drop arity tys -- Drop the kind args
, ty_args `lengthIs` arity -- Result is saturated
= pprPromotionQuote tc <>
(tupleParens (tupleTyConSort dc_tc) $
(tupleParens tup_sort $
sep (punctuate comma (map (pp TopPrec) ty_args)))
| otherwise
= sdocWithDynFlags (pprTcApp_help p pp tc tys)
pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc
pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> TupleSort -> [a] -> SDoc
-- Print a saturated tuple
pprTupleApp p pp tc tys
pprTupleApp p pp tc sort tys
| null tys
, ConstraintTuple <- tupleTyConSort tc
, ConstraintTuple <- sort
= maybeParen p TopPrec $
ppr tc <+>