Refactor TyCon to eliminate TupleTyCon
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 30 Apr 2015 22:33:42 +0000 (23:33 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 1 May 2015 07:31:22 +0000 (08:31 +0100)
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.

compiler/coreSyn/PprCore.hs
compiler/deSugar/Check.hs
compiler/iface/BinIface.hs
compiler/iface/IfaceType.hs
compiler/iface/MkIface.hs
compiler/prelude/TysWiredIn.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcTyDecls.hs
compiler/types/TyCon.hs
compiler/types/TypeRep.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs

index 59c5214..24abf18 100644 (file)
@@ -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
index 9956def..3d855d4 100644 (file)
@@ -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)
index 4ec9ec7..e99ad4d 100644 (file)
@@ -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
index e83c25e..dc3c5c5 100644 (file)
@@ -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
 
index 5e16c16..7e17a13 100644 (file)
@@ -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
index 6181415..87db098 100644 (file)
@@ -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)
index 3d43935..d18e6ed 100644 (file)
@@ -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)
index d279ff5..6787c9c 100644 (file)
@@ -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 * -> ... -> * -> *
index 4db72f6..74799b8 100644 (file)
@@ -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
index c91ddda..f755f3f 100644 (file)
@@ -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 <+> dcolon <+> ppr (tyConKind tc)
   | otherwise
   = pprPromotionQuote tc <>
-    tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+    tupleParens sort (sep (punctuate comma (map (pp TopPrec) tys)))
 
 pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc
 -- This one has accss to the DynFlags
index 7b4d5aa..0ef679d 100644 (file)
@@ -146,6 +146,13 @@ vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
                             , is_enum   = is_enum
                             }
        }
+
+vectAlgTyConRhs tc (TupleTyCon { data_con = con })
+  = vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False })
+    -- I'm not certain this is what you want to do for tuples,
+    -- but it's the behaviour we had before I refactored the
+    -- representation of AlgTyConRhs to add tuples
+
 vectAlgTyConRhs tc (NewTyCon {})
   = do dflags <- getDynFlags
        cantVectorise dflags noNewtypeErr (ppr tc)