deriving-compat 0.5.5 → 0.5.6
raw patch · 8 files changed
+291/−76 lines, 8 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
+ Data.Deriving.Internal: primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name)
Files
- CHANGELOG.md +4/−0
- deriving-compat.cabal +5/−4
- src/Data/Deriving/Internal.hs +152/−0
- src/Data/Eq/Deriving/Internal.hs +4/−8
- src/Data/Ord/Deriving/Internal.hs +3/−43
- src/Text/Show/Deriving/Internal.hs +89/−19
- tests/ShowSpec.hs +17/−1
- tests/Types/EqOrd.hs +17/−1
CHANGELOG.md view
@@ -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.
deriving-compat.cabal view
@@ -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)
src/Data/Deriving/Internal.hs view
@@ -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
src/Data/Eq/Deriving/Internal.hs view
@@ -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
src/Data/Ord/Deriving/Internal.hs view
@@ -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
src/Text/Show/Deriving/Internal.hs view
@@ -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 "##"
tests/ShowSpec.hs view
@@ -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 :: *
tests/Types/EqOrd.hs view
@@ -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 :: *