deriving-compat 0.4.1 → 0.4.2
raw patch · 6 files changed
+118/−15 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +8/−0
- deriving-compat.cabal +4/−4
- src/Data/Deriving.hs +3/−0
- src/Data/Deriving/Internal.hs +43/−1
- src/Text/Read/Deriving/Internal.hs +12/−6
- tests/ReadSpec.hs +48/−4
CHANGELOG.md view
@@ -1,3 +1,11 @@+### 0.4.2 [2018.05.14]+* Backport the fixes for GHC Trac+ [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364)+ and+ [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918),+ which significantly improve the compliation times of derived `Read`+ instances.+ ### 0.4.1 [2018.02.04] * Add `Data.Deriving.Via`, which allows emulating the behavior of the `GeneralizedNewtypeDeriving` and `DerivingVia` extensions.
deriving-compat.cabal view
@@ -1,5 +1,5 @@ name: deriving-compat-version: 0.4.1+version: 0.4.2 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions@@ -70,7 +70,7 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2- , GHC == 8.4.1+ , GHC == 8.4.2 cabal-version: >=1.10 source-repository head@@ -131,7 +131,7 @@ build-depends: base >= 4.3 && < 4.9 if flag(template-haskell-2-11)- build-depends: template-haskell >= 2.11 && < 2.13+ build-depends: template-haskell >= 2.11 && < 2.14 , ghc-boot-th else build-depends: template-haskell >= 2.5 && < 2.11@@ -167,7 +167,7 @@ , hspec >= 1.8 , QuickCheck >= 2 && < 3 , tagged >= 0.7 && < 1- , template-haskell >= 2.5 && < 2.13+ , template-haskell >= 2.5 && < 2.14 build-tool-depends: hspec-discover:hspec-discover >= 1.8 if flag(base-4-9)
src/Data/Deriving.hs view
@@ -98,6 +98,9 @@ * For derived `Foldable` instances, do not error on empty data types. Instead, simply return the folded state (for `foldr`) or `mempty` (for `foldMap`), without inspecting the arguments.++* In GHC 8.6, deriving `Read` was changed so as to factor out certain commonly+ used subexpressions, which significantly improve compliation times. -} {- $derive
src/Data/Deriving/Internal.hs view
@@ -40,8 +40,11 @@ import Data.Set (Set) import Text.ParserCombinators.ReadPrec (ReadPrec)+import qualified Text.Read.Lex as L -#if !(MIN_VERSION_base(4,7,0))+#if MIN_VERSION_base(4,7,0)+import GHC.Read (expectP)+#else import GHC.Read (lexP) import Text.Read (pfail)@@ -1490,6 +1493,17 @@ rangeValName :: Name rangeValName = mkNameG_v "base" "GHC.Arr" "range" +readFieldHash :: String -> ReadPrec a -> ReadPrec a+readFieldHash fieldName readVal = do+ expectP (L.Ident fieldName)+ expectP (L.Symbol "#")+ expectP (L.Punc "=")+ readVal+{-# NOINLINE readFieldHash #-}++readFieldHashValName :: Name+readFieldHashValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash"+ readListValName :: Name readListValName = mkNameG_v "base" "GHC.Read" "readList" @@ -1954,6 +1968,12 @@ getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual"++readFieldValName :: Name+readFieldValName = mkNameG_v "base" "GHC.Read" "readField"++readSymFieldValName :: Name+readSymFieldValName = mkNameG_v "base" "GHC.Read" "readSymField" #else appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"@@ -1966,4 +1986,26 @@ getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"++readField :: String -> ReadPrec a -> ReadPrec a+readField fieldName readVal = do+ expectP (L.Ident fieldName)+ expectP (L.Punc "=")+ readVal+{-# NOINLINE readField #-}++readFieldValName :: Name+readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField"++readSymField :: String -> ReadPrec a -> ReadPrec a+readSymField fieldName readVal = do+ expectP (L.Punc "(")+ expectP (L.Symbol fieldName)+ expectP (L.Punc ")")+ expectP (L.Punc "=")+ readVal+{-# NOINLINE readSymField #-}++readSymFieldValName :: Name+readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField" #endif
src/Text/Read/Deriving/Internal.hs view
@@ -633,13 +633,19 @@ makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty let readStmt = bindS (varP tyExpName) $- varE resetValName `appE` wrapReadS urp (return rExp)- return (readLbl ++ [readPunc "=", readStmt], varExp)+ read_field `appE`+ (varE resetValName `appE` wrapReadS urp (return rExp))+ return ([readStmt], varExp) where- readLbl | isSym lblStr- = [readPunc "(", symbolPat lblStr, readPunc ")"]- | otherwise- = identHPat lblStr+ mk_read_field readFieldName lbl+ = varE readFieldName `appE` stringE lbl+ read_field+ | isSym lblStr+ = mk_read_field readSymFieldValName lblStr+ | Just (ss, '#') <- snocView lblStr+ = mk_read_field readFieldHashValName ss+ | otherwise+ = mk_read_field readFieldValName lblStr makeReadForType :: ReadClass -> Bool
tests/ReadSpec.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -16,12 +17,18 @@ module ReadSpec where import Data.Deriving+import Data.Functor.Classes (Read1, readsPrec1)+import Data.Proxy import Prelude () import Prelude.Compat import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary(..)) +import Text.Read (minPrec)+ import Types.ReadShow () -------------------------------------------------------------------------------@@ -31,7 +38,7 @@ data TyCon# a b = TyCon# { tcA# :: a , tcB# :: b-}+} deriving (Eq, Show) data Empty a b @@ -42,7 +49,7 @@ data instance TyFamily# a b = TyFamily# { tfA# :: a , tfB# :: b-}+} deriving (Eq, Show) ------------------------------------------------------------------------------- @@ -54,6 +61,9 @@ $(deriveRead2 ''TyCon#) #endif +instance (Arbitrary a, Arbitrary b) => Arbitrary (TyCon# a b) where+ arbitrary = TyCon# <$> arbitrary <*> arbitrary+ $(deriveRead ''Empty) $(deriveRead1 ''Empty) #if defined(NEW_FUNCTOR_CLASSES)@@ -68,13 +78,47 @@ # if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 'TyFamily#) # endif++instance (Arbitrary a, Arbitrary b) => Arbitrary (TyFamily# a b) where+ arbitrary = TyFamily# <$> arbitrary <*> arbitrary #endif ------------------------------------------------------------------------------- +prop_Read :: forall f a. (Read a, Read (f a), Read1 f,+ Eq (f a), Show (f a))+ => f a -> Bool+prop_Read x = readArb readsPrec == readArb readsPrec1+ where+ readArb :: (Int -> ReadS (f a)) -> f a+ readArb = read' (show x)++readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a),+ Read a, Read (f a), Read1 f)+ => Proxy (f a) -> Spec+readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Bool)++-- Adapted from the definition of readEither+readEither' :: String -> (Int -> ReadS a) -> Either String a+readEither' s rs =+ case [ x | (x,"") <- rs minPrec s ] of+ [x] -> Right x+ [] -> Left "Prelude.read: no parse"+ _ -> Left "Prelude.read: ambiguous parse"++read' :: String -> (Int -> ReadS a) -> a+read' s = either error id . readEither' s++-------------------------------------------------------------------------------+ main :: IO () main = hspec spec spec :: Spec-spec = pure ()-+spec = parallel $ do+ describe "TyCon#" $+ readSpec (Proxy :: Proxy (TyCon# Char Int))+#if MIN_VERSION_template_haskell(2,7,0)+ describe "TyFamily#" $+ readSpec (Proxy :: Proxy (TyFamily# Char Int))+#endif