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 = [ ...@@ -370,7 +370,9 @@ genericTyConNames = [
compTyConName, rTyConName, pTyConName, dTyConName, compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName, cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName, 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, ...@@ -687,7 +689,11 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
conName_RDR, conFixity_RDR, conIsRecord_RDR, conName_RDR, conFixity_RDR, conIsRecord_RDR,
noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_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") u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1")
par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1")
...@@ -728,6 +734,19 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") ...@@ -728,6 +734,19 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") 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, fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
traverse_RDR, mempty_RDR, mappend_RDR :: RdrName traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
...@@ -789,7 +808,9 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName, ...@@ -789,7 +808,9 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
compTyConName, rTyConName, pTyConName, dTyConName, compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName, cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
repTyConName, rep1TyConName :: Name repTyConName, rep1TyConName, uRecTyConName,
uAddrTyConName, uCharTyConName, uDoubleTyConName,
uFloatTyConName, uIntTyConName, uWordTyConName :: Name
v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
...@@ -818,6 +839,14 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey ...@@ -818,6 +839,14 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey 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 -- Base strings Strings
unpackCStringName, unpackCStringFoldrName, unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
...@@ -1469,7 +1498,9 @@ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, ...@@ -1469,7 +1498,9 @@ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
compTyConKey, rTyConKey, pTyConKey, dTyConKey, compTyConKey, rTyConKey, pTyConKey, dTyConKey,
cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
repTyConKey, rep1TyConKey :: Unique repTyConKey, rep1TyConKey, uRecTyConKey,
uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique
v1TyConKey = mkPreludeTyConUnique 135 v1TyConKey = mkPreludeTyConUnique 135
u1TyConKey = mkPreludeTyConUnique 136 u1TyConKey = mkPreludeTyConUnique 136
...@@ -1498,21 +1529,29 @@ noSelTyConKey = mkPreludeTyConUnique 154 ...@@ -1498,21 +1529,29 @@ noSelTyConKey = mkPreludeTyConUnique 154
repTyConKey = mkPreludeTyConUnique 155 repTyConKey = mkPreludeTyConUnique 155
rep1TyConKey = mkPreludeTyConUnique 156 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 -- Type-level naturals
typeNatKindConNameKey, typeSymbolKindConNameKey, typeNatKindConNameKey, typeSymbolKindConNameKey,
typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
, typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
:: Unique :: Unique
typeNatKindConNameKey = mkPreludeTyConUnique 160 typeNatKindConNameKey = mkPreludeTyConUnique 164
typeSymbolKindConNameKey = mkPreludeTyConUnique 161 typeSymbolKindConNameKey = mkPreludeTyConUnique 165
typeNatAddTyFamNameKey = mkPreludeTyConUnique 162 typeNatAddTyFamNameKey = mkPreludeTyConUnique 166
typeNatMulTyFamNameKey = mkPreludeTyConUnique 163 typeNatMulTyFamNameKey = mkPreludeTyConUnique 167
typeNatExpTyFamNameKey = mkPreludeTyConUnique 164 typeNatExpTyFamNameKey = mkPreludeTyConUnique 168
typeNatLeqTyFamNameKey = mkPreludeTyConUnique 165 typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169
typeNatSubTyFamNameKey = mkPreludeTyConUnique 166 typeNatSubTyFamNameKey = mkPreludeTyConUnique 170
typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 167 typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
typeNatCmpTyFamNameKey = mkPreludeTyConUnique 168 typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172
ntTyConKey:: Unique ntTyConKey:: Unique
ntTyConKey = mkPreludeTyConUnique 174 ntTyConKey = mkPreludeTyConUnique 174
......
...@@ -30,6 +30,7 @@ import IfaceEnv ( newGlobalBinder ) ...@@ -30,6 +30,7 @@ import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName ) import Name hiding ( varName )
import RdrName import RdrName
import BasicTypes import BasicTypes
import TysPrim
import TysWiredIn import TysWiredIn
import PrelNames import PrelNames
import InstEnv import InstEnv
...@@ -47,6 +48,7 @@ import FastString ...@@ -47,6 +48,7 @@ import FastString
import Util import Util
import Control.Monad (mplus,forM) import Control.Monad (mplus,forM)
import Data.Maybe (isJust)
#include "HsVersions.h" #include "HsVersions.h"
...@@ -278,14 +280,19 @@ canDoGenerics tc tc_args ...@@ -278,14 +280,19 @@ canDoGenerics tc tc_args
-- it relies on instantiating *polymorphic* sum and product types -- it relies on instantiating *polymorphic* sum and product types
-- at the argument types of the constructors -- at the argument types of the constructors
bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) 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)) else (if (not (isVanillaDataCon dc))
then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
else IsValid) else IsValid)
-- Nor can we do the job if it's an existential data constructor, -- Nor can we do the job if it's an existential data constructor,
-- Nor if the args are polymorphic types (I don't think) -- 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 :: [Validity] -> Validity
mergeErrors [] = IsValid mergeErrors [] = IsValid
...@@ -586,23 +593,29 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 ...@@ -586,23 +593,29 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
-> TcM Type -> TcM Type
tc_mkRepTy gk_ tycon metaDts = tc_mkRepTy gk_ tycon metaDts =
do do
d1 <- tcLookupTyCon d1TyConName d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName c1 <- tcLookupTyCon c1TyConName
s1 <- tcLookupTyCon s1TyConName s1 <- tcLookupTyCon s1TyConName
nS1 <- tcLookupTyCon noSelTyConName nS1 <- tcLookupTyCon noSelTyConName
rec0 <- tcLookupTyCon rec0TyConName rec0 <- tcLookupTyCon rec0TyConName
rec1 <- tcLookupTyCon rec1TyConName rec1 <- tcLookupTyCon rec1TyConName
par1 <- tcLookupTyCon par1TyConName par1 <- tcLookupTyCon par1TyConName
u1 <- tcLookupTyCon u1TyConName u1 <- tcLookupTyCon u1TyConName
v1 <- tcLookupTyCon v1TyConName v1 <- tcLookupTyCon v1TyConName
plus <- tcLookupTyCon sumTyConName plus <- tcLookupTyCon sumTyConName
times <- tcLookupTyCon prodTyConName times <- tcLookupTyCon prodTyConName
comp <- tcLookupTyCon compTyConName 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] let mkSum' a b = mkTyConApp plus [a,b]
mkProd a b = mkTyConApp times [a,b] mkProd a b = mkTyConApp times [a,b]
mkComp a b = mkTyConApp comp [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] mkRec1 a = mkTyConApp rec1 [a]
mkPar1 = mkTyConTy par1 mkPar1 = mkTyConTy par1
mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
...@@ -650,6 +663,28 @@ tc_mkRepTy gk_ tycon metaDts = ...@@ -650,6 +663,28 @@ tc_mkRepTy gk_ tycon metaDts =
return (mkD tycon) 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 -- Meta-information
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
...@@ -781,22 +816,22 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt) ...@@ -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 = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys)) 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) to_alt = ( mkM1_P (genLR_P i n (mkProd_P gk us' datacon_varTys))
-- These M1s are meta-information for the datatype , to_alt_rhs
) -- These M1s are meta-information for the datatype
to_alt_rhs = case gk_ of to_alt_rhs = case gk_ of
Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
where where
argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
converter = argTyFold argVar $ ArgTyAlg converter = argTyFold argVar $ ArgTyAlg
{ata_rec0 = const $ nlHsVar unK1_RDR, {ata_rec0 = nlHsVar . unboxRepRDR,
ata_par1 = nlHsVar unPar1_RDR, ata_par1 = nlHsVar unPar1_RDR,
ata_rec1 = const $ nlHsVar unRec1_RDR, ata_rec1 = const $ nlHsVar unRec1_RDR,
ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
`nlHsCompose` nlHsVar unComp1_RDR} `nlHsCompose` nlHsVar unComp1_RDR}
-- Generates the L1/R1 sum pattern -- Generates the L1/R1 sum pattern
genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
genLR_P i n p genLR_P i n p
...@@ -832,35 +867,54 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) ...@@ -832,35 +867,54 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
prod a b = prodDataCon_RDR `nlHsApps` [a,b] prod a b = prodDataCon_RDR `nlHsApps` [a,b]
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName 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 -- 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 -- This M1 is meta-information for the selector
where converter = argTyFold argVar $ ArgTyAlg where converter = argTyFold argVar $ ArgTyAlg
{ata_rec0 = const $ nlHsVar k1DataCon_RDR, {ata_rec0 = nlHsVar . boxRepRDR,
ata_par1 = nlHsVar par1DataCon_RDR, ata_par1 = nlHsVar par1DataCon_RDR,
ata_rec1 = const $ nlHsVar rec1DataCon_RDR, ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
(nlHsVar fmap_RDR `nlHsApp` cnv)} (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 -- Build a product pattern
mkProd_P :: GenericKind -- Gen0 or Gen1 mkProd_P :: GenericKind -- Gen0 or Gen1
-> US -- Base for unique names -> US -- Base for unique names
-> [RdrName] -- List of variables to match -> [(RdrName, Type)] -- List of variables to match,
-> LPat RdrName -- Resulting product pattern -- along with their types
mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) -> LPat RdrName -- Resulting product pattern
mkProd_P gk _ vars = mkM1_P (foldBal prod appVars) mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
-- These M1s are meta-information for the constructor -- These M1s are meta-information for the constructor
where where
appVars = map (wrapArg_P gk) vars appVars = unzipWith (wrapArg_P gk) varTys
prod a b = prodDataCon_RDR `nlConPat` [a,b] prod a b = prodDataCon_RDR `nlConPat` [a,b]
wrapArg_P :: GenericKind -> RdrName -> LPat RdrName wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
-- This M1 is meta-information for the selector -- 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 :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
...@@ -883,3 +937,17 @@ foldBal' _ x [] = x ...@@ -883,3 +937,17 @@ foldBal' _ x [] = x
foldBal' _ _ [y] = y foldBal' _ _ [y] = y
foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
in foldBal' op x a `op` foldBal' op x b 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 ...@@ -74,6 +74,9 @@ Language
- Due to a :ghc-ticket:`security issue <10826>`, Safe Haskell now forbids - Due to a :ghc-ticket:`security issue <10826>`, Safe Haskell now forbids
annotations in programs marked as ``-XSafe``. 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 Compiler
~~~~~~~~ ~~~~~~~~
......
...@@ -12004,6 +12004,48 @@ we show generic serialization: ...@@ -12004,6 +12004,48 @@ we show generic serialization:
Typically this class will not be exported, as it only makes sense to Typically this class will not be exported, as it only makes sense to
have instances for the representation types. 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 Generic defaults
---------------- ----------------
......
...@@ -8,6 +8,7 @@ ...@@ -8,6 +8,7 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
...@@ -532,6 +533,65 @@ module GHC.Generics ( ...@@ -532,6 +533,65 @@ module GHC.Generics (
-- @ -- @
-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } -- 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 #if 0
-- *** Limitations -- *** Limitations
-- --
...@@ -548,6 +608,11 @@ module GHC.Generics ( ...@@ -548,6 +608,11 @@ module GHC.Generics (
V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) 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 -- ** Synonyms for convenience
, Rec0, Par0, R, P , Rec0, Par0, R, P
, D1, C1, S1, D, C, S , D1, C1, S1, D, C, S
...@@ -562,6 +627,8 @@ module GHC.Generics ( ...@@ -562,6 +627,8 @@ module GHC.Generics (
) where ) where
-- We use some base types -- We use some base types
import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
import GHC.Ptr ( Ptr )
import GHC.Types import GHC.Types
import Data.Maybe ( Maybe(..) ) import Data.Maybe ( Maybe(..) )
import Data.Either ( Either(..) ) import Data.Either ( Either(..) )
...@@ -614,6 +681,46 @@ infixr 7 :.: ...@@ -614,6 +681,46 @@ infixr 7 :.:
newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) } newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read