diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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.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) diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -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 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 @@ -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 diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -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 diff --git a/tests/ReadSpec.hs b/tests/ReadSpec.hs --- a/tests/ReadSpec.hs +++ b/tests/ReadSpec.hs @@ -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