Commit 6cde981a authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Make GHC generics capable of handling unboxed types

This adds a data family (`URec`) and six data family instances (`UAddr`,
`UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord`) which a `deriving
Generic(1)` clause will generate if it sees `Addr#`, `Char#`, `Double#`,
`Float#`, `Int#`, or `Word#`, respectively. The programmer can then
provide instances for these data family instances to provide custom
implementations for unboxed types, similar to how derived `Eq`, `Ord`,
and `Show` instances currently special-case unboxed types.

Fixes #10868.

Test Plan: ./validate

Reviewers: goldfire, dreixel, bgamari, austin, hvr, kosmikus

Reviewed By: dreixel, kosmikus

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1239

GHC Trac Issues: #10868
parent a96f1acc
......@@ -370,7 +370,9 @@ genericTyConNames = [
compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
repTyConName, rep1TyConName
repTyConName, rep1TyConName, uRecTyConName,
uAddrTyConName, uCharTyConName, uDoubleTyConName,
uFloatTyConName, uIntTyConName, uWordTyConName
]
{-
......@@ -687,7 +689,11 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
conName_RDR, conFixity_RDR, conIsRecord_RDR,
noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
rightAssocDataCon_RDR, notAssocDataCon_RDR,
uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,
uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,
uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,
uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName
u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1")
par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1")
......@@ -728,6 +734,19 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr")
uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar")
uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble")
uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat")
uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt")
uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord")
uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#")
uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#")
uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#")
uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#")
uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#")
uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#")
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
......@@ -789,7 +808,9 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
repTyConName, rep1TyConName :: Name
repTyConName, rep1TyConName, uRecTyConName,
uAddrTyConName, uCharTyConName, uDoubleTyConName,
uFloatTyConName, uIntTyConName, uWordTyConName :: Name
v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
......@@ -818,6 +839,14 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey
uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey
uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey
uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey
uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey
uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey
uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
......@@ -1469,7 +1498,9 @@ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
compTyConKey, rTyConKey, pTyConKey, dTyConKey,
cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
repTyConKey, rep1TyConKey :: Unique
repTyConKey, rep1TyConKey, uRecTyConKey,
uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique
v1TyConKey = mkPreludeTyConUnique 135
u1TyConKey = mkPreludeTyConUnique 136
......@@ -1498,21 +1529,29 @@ noSelTyConKey = mkPreludeTyConUnique 154
repTyConKey = mkPreludeTyConUnique 155
rep1TyConKey = mkPreludeTyConUnique 156
uRecTyConKey = mkPreludeTyConUnique 157
uAddrTyConKey = mkPreludeTyConUnique 158
uCharTyConKey = mkPreludeTyConUnique 159
uDoubleTyConKey = mkPreludeTyConUnique 160
uFloatTyConKey = mkPreludeTyConUnique 161
uIntTyConKey = mkPreludeTyConUnique 162
uWordTyConKey = mkPreludeTyConUnique 163
-- Type-level naturals
typeNatKindConNameKey, typeSymbolKindConNameKey,
typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
, typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
:: Unique
typeNatKindConNameKey = mkPreludeTyConUnique 160
typeSymbolKindConNameKey = mkPreludeTyConUnique 161
typeNatAddTyFamNameKey = mkPreludeTyConUnique 162
typeNatMulTyFamNameKey = mkPreludeTyConUnique 163
typeNatExpTyFamNameKey = mkPreludeTyConUnique 164
typeNatLeqTyFamNameKey = mkPreludeTyConUnique 165
typeNatSubTyFamNameKey = mkPreludeTyConUnique 166
typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 167
typeNatCmpTyFamNameKey = mkPreludeTyConUnique 168
typeNatKindConNameKey = mkPreludeTyConUnique 164
typeSymbolKindConNameKey = mkPreludeTyConUnique 165
typeNatAddTyFamNameKey = mkPreludeTyConUnique 166
typeNatMulTyFamNameKey = mkPreludeTyConUnique 167
typeNatExpTyFamNameKey = mkPreludeTyConUnique 168
typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169
typeNatSubTyFamNameKey = mkPreludeTyConUnique 170
typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172
ntTyConKey:: Unique
ntTyConKey = mkPreludeTyConUnique 174
......
......@@ -30,6 +30,7 @@ import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
import RdrName
import BasicTypes
import TysPrim
import TysWiredIn
import PrelNames
import InstEnv
......@@ -47,6 +48,7 @@ import FastString
import Util
import Control.Monad (mplus,forM)
import Data.Maybe (isJust)
#include "HsVersions.h"
......@@ -278,14 +280,19 @@ canDoGenerics tc tc_args
-- it relies on instantiating *polymorphic* sum and product types
-- at the argument types of the constructors
bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
then (NotValid (ppr dc <+> text
"must not have exotic unlifted or polymorphic arguments"))
else (if (not (isVanillaDataCon dc))
then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
else IsValid)
-- Nor can we do the job if it's an existential data constructor,
-- Nor if the args are polymorphic types (I don't think)
bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
bad_arg_type ty = (isUnLiftedType ty && not (allowedUnliftedTy ty))
|| not (isTauTy ty)
allowedUnliftedTy :: Type -> Bool
allowedUnliftedTy = isJust . unboxedRepRDRs
mergeErrors :: [Validity] -> Validity
mergeErrors [] = IsValid
......@@ -586,23 +593,29 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
-> TcM Type
tc_mkRepTy gk_ tycon metaDts =
do
d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName
s1 <- tcLookupTyCon s1TyConName
nS1 <- tcLookupTyCon noSelTyConName
rec0 <- tcLookupTyCon rec0TyConName
rec1 <- tcLookupTyCon rec1TyConName
par1 <- tcLookupTyCon par1TyConName
u1 <- tcLookupTyCon u1TyConName
v1 <- tcLookupTyCon v1TyConName
plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName
d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName
s1 <- tcLookupTyCon s1TyConName
nS1 <- tcLookupTyCon noSelTyConName
rec0 <- tcLookupTyCon rec0TyConName
rec1 <- tcLookupTyCon rec1TyConName
par1 <- tcLookupTyCon par1TyConName
u1 <- tcLookupTyCon u1TyConName
v1 <- tcLookupTyCon v1TyConName
plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName
uAddr <- tcLookupTyCon uAddrTyConName
uChar <- tcLookupTyCon uCharTyConName
uDouble <- tcLookupTyCon uDoubleTyConName
uFloat <- tcLookupTyCon uFloatTyConName
uInt <- tcLookupTyCon uIntTyConName
uWord <- tcLookupTyCon uWordTyConName
let mkSum' a b = mkTyConApp plus [a,b]
mkProd a b = mkTyConApp times [a,b]
mkComp a b = mkTyConApp comp [a,b]
mkRec0 a = mkTyConApp rec0 [a]
mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a
mkRec1 a = mkTyConApp rec1 [a]
mkPar1 = mkTyConTy par1
mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
......@@ -650,6 +663,28 @@ tc_mkRepTy gk_ tycon metaDts =
return (mkD tycon)
-- Given the TyCons for each URec-related type synonym, check to see if the
-- given type is an unlifted type that generics understands. If so, return
-- its representation type. Otherwise, return Rec0.
-- See Note [Generics and unlifted types]
mkBoxTy :: TyCon -- UAddr
-> TyCon -- UChar
-> TyCon -- UDouble
-> TyCon -- UFloat
-> TyCon -- UInt
-> TyCon -- UWord
-> TyCon -- Rec0
-> Type
-> Type
mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty
| ty == addrPrimTy = mkTyConTy uAddr
| ty == charPrimTy = mkTyConTy uChar
| ty == doublePrimTy = mkTyConTy uDouble
| ty == floatPrimTy = mkTyConTy uFloat
| ty == intPrimTy = mkTyConTy uInt
| ty == wordPrimTy = mkTyConTy uWord
| otherwise = mkTyConApp rec0 [ty]
--------------------------------------------------------------------------------
-- Meta-information
--------------------------------------------------------------------------------
......@@ -781,22 +816,22 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt)
from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
-- These M1s are meta-information for the datatype
to_alt = ( mkM1_P (genLR_P i n (mkProd_P gk us' datacon_varTys))
, to_alt_rhs
) -- These M1s are meta-information for the datatype
to_alt_rhs = case gk_ of
Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
where
argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
converter = argTyFold argVar $ ArgTyAlg
{ata_rec0 = const $ nlHsVar unK1_RDR,
{ata_rec0 = nlHsVar . unboxRepRDR,
ata_par1 = nlHsVar unPar1_RDR,
ata_rec1 = const $ nlHsVar unRec1_RDR,
ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
`nlHsCompose` nlHsVar unComp1_RDR}
-- Generates the L1/R1 sum pattern
genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
genLR_P i n p
......@@ -832,35 +867,54 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
prod a b = prodDataCon_RDR `nlHsApps` [a,b]
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
wrapArg_E Gen0_DC (var, ty) = mkM1_E $
boxRepRDR ty `nlHsVarApps` [var]
-- This M1 is meta-information for the selector
wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
converter ty `nlHsApp` nlHsVar var
-- This M1 is meta-information for the selector
where converter = argTyFold argVar $ ArgTyAlg
{ata_rec0 = const $ nlHsVar k1DataCon_RDR,
{ata_rec0 = nlHsVar . boxRepRDR,
ata_par1 = nlHsVar par1DataCon_RDR,
ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
(nlHsVar fmap_RDR `nlHsApp` cnv)}
boxRepRDR :: Type -> RdrName
boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
unboxRepRDR :: Type -> RdrName
unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
-- Retrieve the RDRs associated with each URec data family instance
-- constructor. See Note [Generics and unlifted types]
unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs ty
| ty == addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR)
| ty == charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR)
| ty == doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
| ty == floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR)
| ty == intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR)
| ty == wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR)
| otherwise = Nothing
-- Build a product pattern
mkProd_P :: GenericKind -- Gen0 or Gen1
-> US -- Base for unique names
-> [RdrName] -- List of variables to match
-> LPat RdrName -- Resulting product pattern
mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
mkProd_P :: GenericKind -- Gen0 or Gen1
-> US -- Base for unique names
-> [(RdrName, Type)] -- List of variables to match,
-- along with their types
-> LPat RdrName -- Resulting product pattern
mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
-- These M1s are meta-information for the constructor
where
appVars = map (wrapArg_P gk) vars
appVars = unzipWith (wrapArg_P gk) varTys
prod a b = prodDataCon_RDR `nlConPat` [a,b]
wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
-- This M1 is meta-information for the selector
wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
wrapArg_P Gen1 v _ = m1DataCon_RDR `nlConVarPat` [v]
mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
......@@ -883,3 +937,17 @@ foldBal' _ x [] = x
foldBal' _ _ [y] = y
foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
in foldBal' op x a `op` foldBal' op x b
{-
Note [Generics and unlifted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally, all constants are marked with K1/Rec0. The exception to this rule is
when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
that case, we must use a data family instance of URec (from GHC.Generics) to
mark it. As a result, before we can generate K1 or unK1, we must first check
to see if the type is actually one of the unlifted types for which URec has a
data family instance; if so, we generate that instead.
See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
details on why URec is implemented the way it is.
-}
......@@ -74,6 +74,9 @@ Language
- Due to a :ghc-ticket:`security issue <10826>`, Safe Haskell now forbids
annotations in programs marked as ``-XSafe``.
- Generic instances can be derived for data types whose constructors have
arguments with certain unlifted types. See :ref:`generic-programming` for
more details.
Compiler
~~~~~~~~
......
......@@ -12004,6 +12004,48 @@ we show generic serialization:
Typically this class will not be exported, as it only makes sense to
have instances for the representation types.
Unlifted representation types
-----------------------------
The data family ``URec`` is provided to enable generic programming over
datatypes with certain unlifted arguments. There are six instances corresponding
to common unlifted types: ::
data family URec a p
data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# }
data instance URec Char p = UChar { uChar# :: Char# }
data instance URec Double p = UDouble { uDouble# :: Double# }
data instance URec Int p = UInt { uInt# :: Int# }
data instance URec Float p = UFloat { uFloat# :: Float# }
data instance URec Word p = UWord { uWord# :: Word# }
Six type synonyms are provided for convenience: ::
type UAddr = URec (Ptr ())
type UChar = URec Char
type UDouble = URec Double
type UFloat = URec Float
type UInt = URec Int
type UWord = URec Word
As an example, this data declaration: ::
data IntHash = IntHash Int#
deriving Generic
results in the following ``Generic`` instance: ::
instance Generic IntHash where
type Rep IntHash =
D1 D1IntHash
(C1 C1_0IntHash
(S1 NoSelector UInt))
A user could provide, for example, a ``GSerialize UInt`` instance so that a
``Serialize IntHash`` instance could be easily defined in terms of
``GSerialize``.
Generic defaults
----------------
......
......@@ -8,6 +8,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}
-----------------------------------------------------------------------------
-- |
......@@ -532,6 +533,65 @@ module GHC.Generics (
-- @
-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) }
-- @
-- *** Representation of unlifted types
--
-- |
--
-- If one were to attempt to derive a Generic instance for a datatype with an
-- unlifted argument (for example, 'Int#'), one might expect the occurrence of
-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work,
-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@.
-- In fact, polymorphism over unlifted types is disallowed completely.
--
-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int'
-- instead. With this approach, however, the programmer has no way of knowing
-- whether the 'Int' is actually an 'Int#' in disguise.
--
-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark
-- occurrences of common unlifted types:
--
-- @
-- data family URec a p
--
-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' }
-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' }
-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' }
-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' }
-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' }
-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' }
-- @
--
-- Several type synonyms are provided for convenience:
--
-- @
-- type 'UAddr' = 'URec' ('Ptr' ())
-- type 'UChar' = 'URec' 'Char'
-- type 'UDouble' = 'URec' 'Double'
-- type 'UFloat' = 'URec' 'Float'
-- type 'UInt' = 'URec' 'Int'
-- type 'UWord' = 'URec' 'Word'
-- @
--
-- The declaration
--
-- @
-- data IntHash = IntHash Int#
-- deriving 'Generic'
-- @
--
-- yields
--
-- @
-- instance 'Generic' IntHash where
-- type 'Rep' IntHash =
-- 'D1' D1IntHash
-- ('C1' C1_0IntHash
-- ('S1' 'NoSelector' 'UInt'))
-- @
--
-- Currently, only the six unlifted types listed above are generated, but this
-- may be extended to encompass more unlifted types in the future.
#if 0
-- *** Limitations
--
......@@ -548,6 +608,11 @@ module GHC.Generics (
V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..)
, (:+:)(..), (:*:)(..), (:.:)(..)
-- ** Unboxed representation types
, URec(..)
, type UAddr, type UChar, type UDouble
, type UFloat, type UInt, type UWord
-- ** Synonyms for convenience
, Rec0, Par0, R, P
, D1, C1, S1, D, C, S
......@@ -562,6 +627,8 @@ module GHC.Generics (
) where
-- We use some base types
import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
import GHC.Ptr ( Ptr )
import GHC.Types
import Data.Maybe ( Maybe(..) )
import Data.Either ( Either(..) )
......@@ -614,6 +681,46 @@ infixr 7 :.:
newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) }
deriving (Eq, Ord, Read, Show, Generic)
-- | Constants of kind @#@
data family URec (a :: *) (p :: *)
-- | Used for marking occurrences of 'Addr#'
data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# }
deriving (Eq, Ord, Generic)
-- | Used for marking occurrences of 'Char#'
data instance URec Char p = UChar { uChar# :: Char# }
deriving (Eq, Ord, Show, Generic)
-- | Used for marking occurrences of 'Double#'
data instance URec Double p = UDouble { uDouble# :: Double# }
deriving (Eq, Ord, Show, Generic)
-- | Used for marking occurrences of 'Float#'
data instance URec Float p = UFloat { uFloat# :: Float# }
deriving (Eq, Ord, Show, Generic)
-- | Used for marking occurrences of 'Int#'
data instance URec Int p = UInt { uInt# :: Int# }
deriving (Eq, Ord, Show, Generic)
-- | Used for marking occurrences of 'Word#'
data instance URec Word p = UWord { uWord# :: Word# }
deriving (Eq, Ord, Show, Generic)
-- | Type synonym for 'URec': 'Addr#'
type UAddr = URec (Ptr ())
-- | Type synonym for 'URec': 'Char#'
type UChar = URec Char
-- | Type synonym for 'URec': 'Double#'
type UDouble = URec Double
-- | Type synonym for 'URec': 'Float#'
type UFloat = URec Float
-- | Type synonym for 'URec': 'Int#'
type UInt = URec Int
-- | Type synonym for 'URec': 'Word#'
type UWord = URec Word
-- | Tag for K1: recursion (of kind *)
data R
-- | Tag for K1: parameters (other than the last)
......@@ -642,7 +749,6 @@ type C1 = M1 C
-- | Type synonym for encoding meta-information for record selectors
type S1 = M1 S
-- | Class for datatypes that represent datatypes
class Datatype (d :: *) where
-- | The name of the datatype (unqualified)
......
......@@ -62,6 +62,10 @@
super-class of `Monoid` in the future). These modules were
provided by the `semigroups` package previously. (#10365)
* Add `URec`, `UAddr`, `UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord` to
`GHC.Generics` as part of making GHC generics capable of handling
unlifted types (#10868)
## 4.8.1.0 *Jul 2015*
* Bundled with GHC 7.10.2
......
{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies, FlexibleInstances #-}
{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies,
FlexibleInstances, MagicHash #-}
module Main where
import GHC.Exts
import GHC.Generics hiding (C, D)
import GEq1A
......@@ -20,6 +22,13 @@ data family F a b :: * -> *
data instance F Int b c = F b Int c
deriving Generic
data U a = U a Addr# Char# Double# Float# Int# Word#
deriving Generic
data family UF a b :: * -> *
data instance UF Int b c = UF b c Addr# Char# Double# Float# Int# Word#
deriving Generic
-- Example values
c0 = C0
c1 = C1
......@@ -35,17 +44,27 @@ f1 :: F Int Float Char
f1 = F 0.0 3 'h'
f2 = F 0.0 4 'h'
u0 :: U Int
u0 = U 1 "1"# '1'# 1.0## 1.0# 1# 1##
uf0 :: UF Int Int Int
uf0 = UF 2 2 "1"# '2'# 2.0## 2.0# 2# 2##
-- Generic instances
instance GEq C
instance (GEq a) => GEq (D a)
instance (GEq a, GEq b) => GEq (a :**: b)
instance (GEq b, GEq c) => GEq (F Int b c)
instance (GEq a) => GEq (U a)
instance (GEq b, GEq c) => GEq (UF Int b c)
-- Tests
teq0 = geq c0 c1
teq1 = geq d0 d1
teq2 = geq d0 d0
teq3 = geq p1 p1
teq4 = geq f1 f2
teq0 = geq c0 c1
teq1 = geq d0 d1
teq2 = geq d0 d0
teq3 = geq p1 p1
teq4 = geq f1 f2
teq5 = geq u0 u0
teq6 = geq uf0 uf0
main = mapM_ print [teq0, teq1, teq2, teq3, teq4]
main = mapM_ print [teq0, teq1, teq2, teq3, teq4, teq5, teq6]
......@@ -3,3 +3,5 @@ False
True
True
False
True
True
{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE TypeOperators, DefaultSignatures,
FlexibleContexts, FlexibleInstances, MagicHash #-}
module GEq1A where
import GHC.Exts
import GHC.Generics
class GEq' f where
......@@ -26,13 +28,25 @@ instance (GEq' a, GEq' b) => GEq' (a :+: b) where
instance (GEq' a, GEq' b) => GEq' (a :*: b) where
geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
class GEq a where
-- Unboxed types
instance GEq' UAddr where
geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)
instance GEq' UChar where
geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)
instance GEq' UDouble where
geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)
instance GEq' UFloat where
geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)
instance GEq' UInt where
geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)
instance GEq' UWord where
geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)
class GEq a where
geq :: a -> a -> Bool
default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
geq x y = geq' (from x) (from y)
-- Base types instances (ad-hoc)
instance GEq Char where geq = (==)
instance GEq Int where geq = (==)
......
......@@ -5,13 +5,14 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE IncoherentInstances #-} -- :-/
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE MagicHash #-}
module GShow (
-- * Generic show class
GShow(..)
) where
import GHC.Exts
import GHC.Generics
--------------------------------------------------------------------------------
......@@ -36,10 +37,10 @@ instance (GShow c) => GShow' (K1 i c) where
-- No instances for P or Rec because gshow is only applicable to types of kind *
instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
gshowsPrec' _ n c@(M1 x) =
gshowsPrec' _ n c@(M1 x) =
case (fixity, conIsTuple c) of
(Prefix,False) -> showParen (n > 10 && not (isNullary x))
( showString (conName c)
(Prefix,False) -> showParen (n > 10 && not (isNullary x))
( showString (conName c)
. if (isNullary x) then id else showChar ' '
. showBraces t (gshowsPrec' t 10 x))
(Prefix,True) -> showParen (n > 10) (showBraces t (gshowsPrec' t 10 x))
......@@ -58,7 +59,7 @@ instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
conIsTuple c = case conName c of
('(':',':_) -> True
otherwise -> False
isNullary (M1 x) = isNullary x
instance (Selector s, GShow' a) => GShow' (M1 S s a) where
......@@ -85,12 +86,23 @@ instance (GShow' a, GShow' b) => GShow' (a :*: b) where
gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b
gshowsPrec' t@Pref n (a :*: b) =
gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b
-- If we have a product then it is not a nullary constructor
isNullary _ = False
class GShow a where
-- Unboxed instances
instance GShow' UChar where
gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#'
instance GShow' UDouble where