diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.5.6 [2019.05.02] +* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields + of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. + ### 0.5.5 [2019.04.26] * Support `th-abstraction-0.3` or later. diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.5.5 +version: 0.5.6 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -71,7 +71,8 @@ , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 cabal-version: >=1.10 source-repository head @@ -129,7 +130,7 @@ build-depends: base >= 4.3 && < 4.9 if flag(template-haskell-2-11) - build-depends: template-haskell >= 2.11 && < 2.15 + build-depends: template-haskell >= 2.11 && < 2.16 , ghc-boot-th else build-depends: template-haskell >= 2.5 && < 2.11 @@ -166,7 +167,7 @@ , hspec >= 1.8 , QuickCheck >= 2 && < 3 , tagged >= 0.7 && < 1 - , template-haskell >= 2.5 && < 2.15 + , template-haskell >= 2.5 && < 2.16 build-tool-depends: hspec-discover:hspec-discover >= 1.8 if flag(base-4-9) diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -1076,6 +1076,72 @@ tvbs' = go tvbsAndFVs #endif +primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name) +primOrdFunTbl = Map.fromList + [ (addrHashTypeName, ( ltAddrHashValName + , leAddrHashValName + , eqAddrHashValName + , geAddrHashValName + , gtAddrHashValName + )) + , (charHashTypeName, ( ltCharHashValName + , leCharHashValName + , eqCharHashValName + , geCharHashValName + , gtCharHashValName + )) + , (doubleHashTypeName, ( ltDoubleHashValName + , leDoubleHashValName + , eqDoubleHashValName + , geDoubleHashValName + , gtDoubleHashValName + )) + , (floatHashTypeName, ( ltFloatHashValName + , leFloatHashValName + , eqFloatHashValName + , geFloatHashValName + , gtFloatHashValName + )) + , (intHashTypeName, ( ltIntHashValName + , leIntHashValName + , eqIntHashValName + , geIntHashValName + , gtIntHashValName + )) + , (wordHashTypeName, ( ltWordHashValName + , leWordHashValName + , eqWordHashValName + , geWordHashValName + , gtWordHashValName + )) +#if MIN_VERSION_base(4,13,0) + , (int8HashTypeName, ( ltInt8HashValName + , leInt8HashValName + , eqInt8HashValName + , geInt8HashValName + , gtInt8HashValName + )) + , (int16HashTypeName, ( ltInt16HashValName + , leInt16HashValName + , eqInt16HashValName + , geInt16HashValName + , gtInt16HashValName + )) + , (word8HashTypeName, ( ltWord8HashValName + , leWord8HashValName + , eqWord8HashValName + , geWord8HashValName + , gtWord8HashValName + )) + , (word16HashTypeName, ( ltWord16HashValName + , leWord16HashValName + , eqWord16HashValName + , geWord16HashValName + , gtWord16HashValName + )) +#endif + ] + removeClassApp :: Type -> Type removeClassApp (AppT _ t2) = t2 removeClassApp t = t @@ -2037,4 +2103,90 @@ readSymFieldValName :: Name readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField" +#endif + +#if MIN_VERSION_base(4,13,0) +eqInt8HashValName :: Name +eqInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt8#" + +eqInt16HashValName :: Name +eqInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#" + +eqWord8HashValName :: Name +eqWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#" + +eqWord16HashValName :: Name +eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#" + +extendInt8HashValName :: Name +extendInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendInt8#" + +extendInt16HashValName :: Name +extendInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendInt16#" + +extendWord8HashValName :: Name +extendWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendWord8#" + +extendWord16HashValName :: Name +extendWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendWord16#" + +geInt8HashValName :: Name +geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#" + +geInt16HashValName :: Name +geInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#" + +geWord8HashValName :: Name +geWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#" + +geWord16HashValName :: Name +geWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#" + +gtInt8HashValName :: Name +gtInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#" + +gtInt16HashValName :: Name +gtInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#" + +gtWord8HashValName :: Name +gtWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#" + +gtWord16HashValName :: Name +gtWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#" + +int8HashTypeName :: Name +int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#" + +int16HashTypeName :: Name +int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#" + +leInt8HashValName :: Name +leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#" + +leInt16HashValName :: Name +leInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#" + +leWord8HashValName :: Name +leWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#" + +leWord16HashValName :: Name +leWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#" + +ltInt8HashValName :: Name +ltInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#" + +ltInt16HashValName :: Name +ltInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#" + +ltWord8HashValName :: Name +ltWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#" + +ltWord16HashValName :: Name +ltWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#" + +word8HashTypeName :: Name +word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#" + +word16HashTypeName :: Name +word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#" #endif diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -268,14 +268,10 @@ makePrimEqExpr n = primOpAppExpr aExpr n bExpr primEqExpr :: Q Exp - primEqExpr - | tyName == addrHashTypeName = makePrimEqExpr eqAddrHashValName - | tyName == charHashTypeName = makePrimEqExpr eqCharHashValName - | tyName == doubleHashTypeName = makePrimEqExpr eqDoubleHashValName - | tyName == floatHashTypeName = makePrimEqExpr eqFloatHashValName - | tyName == intHashTypeName = makePrimEqExpr eqIntHashValName - | tyName == wordHashTypeName = makePrimEqExpr eqWordHashValName - | otherwise = infixApp aExpr (varE eqValName) bExpr + primEqExpr = + case Map.lookup tyName primOrdFunTbl of + Just (_, _, eq, _, _) -> makePrimEqExpr eq + Nothing -> infixApp aExpr (varE eqValName) bExpr makeCaseForArg eClass tvMap conName ty a b = makeCaseForType eClass tvMap conName ty `appE` varE a `appE` varE b diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -40,7 +40,6 @@ import Data.Deriving.Internal import Data.List (partition) import qualified Data.Map as Map -import Data.Maybe (isJust) import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib @@ -688,52 +687,13 @@ ascribeBool e = sigE e $ conT boolTypeName primOrdFuns :: Name -> (Name, Name, Name, Name, Name) -primOrdFuns tyName = case lookup tyName primOrdFunTbl of +primOrdFuns tyName = + case Map.lookup tyName primOrdFunTbl of Just names -> names Nothing -> error $ nameBase tyName ++ " is not supported." -primOrdFunTbl :: [(Name, (Name, Name, Name, Name, Name))] -primOrdFunTbl = - [ (addrHashTypeName, ( ltAddrHashValName - , leAddrHashValName - , eqAddrHashValName - , geAddrHashValName - , gtAddrHashValName - )) - , (charHashTypeName, ( ltCharHashValName - , leCharHashValName - , eqCharHashValName - , geCharHashValName - , gtCharHashValName - )) - , (doubleHashTypeName, ( ltDoubleHashValName - , leDoubleHashValName - , eqDoubleHashValName - , geDoubleHashValName - , gtDoubleHashValName - )) - , (floatHashTypeName, ( ltFloatHashValName - , leFloatHashValName - , eqFloatHashValName - , geFloatHashValName - , gtFloatHashValName - )) - , (intHashTypeName, ( ltIntHashValName - , leIntHashValName - , eqIntHashValName - , geIntHashValName - , gtIntHashValName - )) - , (wordHashTypeName, ( ltWordHashValName - , leWordHashValName - , eqWordHashValName - , geWordHashValName - , gtWordHashValName - )) - ] - isSupportedUnliftedType :: Type -> Bool -isSupportedUnliftedType (ConT tyName) = isJust $ lookup tyName primOrdFunTbl +isSupportedUnliftedType (ConT tyName) = Map.member tyName primOrdFunTbl isSupportedUnliftedType _ = False isSingleton :: [a] -> Bool diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-| Module: Text.Show.Deriving.Internal Copyright: (C) 2015-2017 Ryan Scott @@ -53,6 +54,7 @@ import Data.Deriving.Internal import Data.List import qualified Data.Map as Map +import Data.Map (Map) import Data.Maybe (fromMaybe) import GHC.Show (appPrec, appPrec1) @@ -501,27 +503,24 @@ tyVarE = varE tyExpName showE :: Q Exp - showE | tyName == charHashTypeName = showPrimE cHashDataName oneHashE - | tyName == doubleHashTypeName = showPrimE dHashDataName twoHashE - | tyName == floatHashTypeName = showPrimE fHashDataName oneHashE - | tyName == intHashTypeName = showPrimE iHashDataName oneHashE - | tyName == wordHashTypeName = showPrimE wHashDataName twoHashE - | otherwise = varE showsPrecValName `appE` integerE p `appE` tyVarE + showE = + case Map.lookup tyName primShowTbl of + Just ps -> showPrimE ps + Nothing -> varE showsPrecValName `appE` integerE p `appE` tyVarE - -- Starting with GHC 7.10, data types containing unlifted types with derived Show - -- instances show hashed literals with actual hash signs, and negative hashed - -- literals are not surrounded with parentheses. - showPrimE :: Name -> Q Exp -> Q Exp - showPrimE con hashE + showPrimE :: PrimShow -> Q Exp + showPrimE PrimShow{primShowBoxer, primShowPostfixMod, primShowConv} + -- Starting with GHC 8.0, data types containing unlifted types with + -- derived Show instances show hashed literals with actual hash signs, + -- and negative hashed literals are not surrounded with parentheses. | ghc8ShowBehavior opts - = infixApp (varE showsPrecValName `appE` integerE 0 `appE` (conE con `appE` tyVarE)) - (varE composeValName) - hashE - | otherwise = varE showsPrecValName `appE` integerE p `appE` (conE con `appE` tyVarE) - - oneHashE, twoHashE :: Q Exp - oneHashE = varE showCharValName `appE` charE '#' - twoHashE = varE showStringValName `appE` stringE "##" + = primShowConv $ infixApp (primE 0) (varE composeValName) primShowPostfixMod + | otherwise + = primE p + where + primE :: Int -> Q Exp + primE prec = varE showsPrecValName `appE` integerE prec + `appE` primShowBoxer tyVarE makeShowForArg p sClass _ conName tvMap ty tyExpName = makeShowForType sClass conName tvMap False ty `appE` integerE p `appE` varE tyExpName @@ -665,3 +664,74 @@ charE :: Char -> Q Exp charE = litE . charL + +data PrimShow = PrimShow + { primShowBoxer :: Q Exp -> Q Exp + , primShowPostfixMod :: Q Exp + , primShowConv :: Q Exp -> Q Exp + } + +primShowTbl :: Map Name PrimShow +primShowTbl = Map.fromList + [ (charHashTypeName, PrimShow + { primShowBoxer = appE (conE cHashDataName) + , primShowPostfixMod = oneHashE + , primShowConv = id + }) + , (doubleHashTypeName, PrimShow + { primShowBoxer = appE (conE dHashDataName) + , primShowPostfixMod = twoHashE + , primShowConv = id + }) + , (floatHashTypeName, PrimShow + { primShowBoxer = appE (conE fHashDataName) + , primShowPostfixMod = oneHashE + , primShowConv = id + }) + , (intHashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) + , primShowPostfixMod = oneHashE + , primShowConv = id + }) + , (wordHashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) + , primShowPostfixMod = twoHashE + , primShowConv = id + }) +#if MIN_VERSION_base(4,13,0) + , (int8HashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt8HashValName) + , primShowPostfixMod = oneHashE + , primShowConv = mkNarrowE "narrowInt8#" + }) + , (int16HashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt16HashValName) + , primShowPostfixMod = oneHashE + , primShowConv = mkNarrowE "narrowInt16#" + }) + , (word8HashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord8HashValName) + , primShowPostfixMod = twoHashE + , primShowConv = mkNarrowE "narrowWord8#" + }) + , (word16HashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord16HashValName) + , primShowPostfixMod = twoHashE + , primShowConv = mkNarrowE "narrowWord16#" + }) +#endif + ] + +#if MIN_VERSION_base(4,13,0) +mkNarrowE :: String -> Q Exp -> Q Exp +mkNarrowE narrowStr e = + foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` charE ')') + [ varE showStringValName `appE` stringE ('(':narrowStr ++ " ") + , e + ] +#endif + +oneHashE, twoHashE :: Q Exp +oneHashE = varE showCharValName `appE` charE '#' +twoHashE = varE showStringValName `appE` stringE "##" diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs --- a/tests/ShowSpec.hs +++ b/tests/ShowSpec.hs @@ -22,7 +22,11 @@ import Data.Deriving -import GHC.Exts (Char#, Double#, Float#, Int#, Word#) +import GHC.Exts ( Char#, Double#, Float#, Int#, Word# +#if MIN_VERSION_base(4,13,0) + , Int8#, Int16#, Word8#, Word16# +#endif + ) import Prelude () import Prelude.Compat @@ -43,6 +47,12 @@ , tcDouble# :: Double# , tcChar# :: Char# , tcWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tcInt8# :: Int8# + , tcInt16# :: Int16# + , tcWord8# :: Word8# + , tcWord16# :: Word16# +#endif } data TyCon2 a b c d where @@ -78,6 +88,12 @@ , tfDouble# :: Double# , tfChar# :: Char# , tfWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tfInt8# :: Int8# + , tfInt16# :: Int16# + , tfWord8# :: Word8# + , tfWord16# :: Word16# +#endif } data family TyFamily2 w x y z :: * diff --git a/tests/Types/EqOrd.hs b/tests/Types/EqOrd.hs --- a/tests/Types/EqOrd.hs +++ b/tests/Types/EqOrd.hs @@ -22,7 +22,11 @@ #endif import Data.Deriving -import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) +import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word# +#if MIN_VERSION_base(4,13,0) + , Int8#, Int16#, Word8#, Word16# +#endif + ) -- Plain data types @@ -50,6 +54,12 @@ , tcDouble# :: Double# , tcChar# :: Char# , tcWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tcInt8# :: Int8# + , tcInt16# :: Int16# + , tcWord8# :: Word8# + , tcWord16# :: Word16# +#endif } data TyCon2 a b c d where @@ -100,6 +110,12 @@ , tfDouble# :: Double# , tfChar# :: Char# , tfWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tfInt8# :: Int8# + , tfInt16# :: Int16# + , tfWord8# :: Word8# + , tfWord16# :: Word16# +#endif } data family TyFamily2 w x y z :: *