961d7ef · typeable/generic-arbitrary

git.iko.soy/typeable/generic-arbitrary

more test and docs

commit961d7ef917b5a090cb8d00b4da729d9868d4b3fb authorAleksey Uymanov <s9gf4ult@gmail.com> dateTue 9 Aug 2022, 12:01 (4 years ago) parent3bc62d3

5 files changed+110−11

compare with master

unifiedsplit

generic-arbitrary.cabal+4−1 src/Test/QuickCheck/Arbitrary/Generic.hs+60−5 test/Aux.hs+10 test/NoTypecheckTest.hs+2−5 test/ParametersTest.hs+34

generic-arbitrary.cabal+4−1

@@ -62,8 +62,10 @@ test-suite test

6262 , tasty-discover

6363 , tasty-hunit

6464 , tasty-quickcheck

65− other-modules: LimitationDemo

65+ other-modules: Aux

66+ , LimitationDemo

6667 , NoTypecheckTest

68+ , ParametersTest

6769 , RecursiveTest

6870 default-extensions: AllowAmbiguousTypes

6971 , CPP

@@ -80,6 +82,7 @@ test-suite test

8082 , PolyKinds

8183 , RankNTypes

8284 , ScopedTypeVariables

85+ , TypeApplications

8386 , TypeFamilies

8487 , TypeOperators

8588 , TypeSynonymInstances

src/Test/QuickCheck/Arbitrary/Generic.hs+60−5

@@ -1,6 +1,7 @@

1−{- |

1+{-|

3−Generic implementation of the 'arbitrary' method. Example usage:

3+This module is a generic implementation of the 'arbitrary' method. Example

4+usage:

56@

67data Foo = Foo

@@ -74,8 +75,52 @@ data R2 = R2 R1

7475@

7576

7677This code will compile and the @arbitrary@ generated will always hand. Yes,

77−there is a problem with mutually recursive types

78+there is a problem with mutually recursive types.

7879

80+Now lets see an example of datatype with parameters

81+

82+@

83+data A a = A a

84+ deriving (Eq, Ord, Show)

85+ deriving anyclass NFData

86+ deriving (Generic)

87+

88+instance (Arbitrary a) => Arbitrary (A a) where

89+ arbitrary = genericArbitrary

90+ shrink = genericShrink

91+@

92+

93+It should work from first glance, but on compilation it will throw an error:

94+

95+@

96+ • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary

97+ (A a)

98+ (GHC.Generics.D1

99+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)

100+ (GHC.Generics.C1

101+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)

102+ (GHC.Generics.S1

103+ ('GHC.Generics.MetaSel

104+ 'Nothing

105+ 'GHC.Generics.NoSourceUnpackedness

106+ 'GHC.Generics.NoSourceStrictness

107+ 'GHC.Generics.DecidedLazy)

108+ (GHC.Generics.Rec0 a))))

109+ (TypesDiffer (A a) a))

110+ arising from a use of ‘genericArbitrary’

111+@

112+

113+Here the @TypesDiffer@ is a type familty dealing with recursive types and

114+helping us to eliminate inproper instances. To convince the compiller, that the

115+@a@ parameter is not an @A a@ we must fix the instance with additional constraint

116+

117+@

118+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where

119+ arbitrary = genericArbitrary

120+ shrink = genericShrink

121+@

122+

123+Now everything compiles.

79124

80125-}

81126

@@ -85,10 +130,18 @@ module Test.QuickCheck.Arbitrary.Generic

85130 , GenericArbitrary(..)

86131#endif

87132 , Arg

133+ , TypesDiffer

134+ , AllFieldsFinal

135+ , Finite

136+ , ArgumentsCount

137+ , SumLen

88138 , genericArbitrary

89139 , genericShrink

90140 ) where

91141

142+

143+

144+

92145import Control.Applicative

93146import Data.Coerce (coerce)

94147import Data.Proxy

@@ -99,6 +152,8 @@ import Test.QuickCheck as QC

99152#if MIN_VERSION_QuickCheck(2, 14, 0)

100153import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)

101154

155+

156+

102157-- | Newtype for @DerivingVia@

103158newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }

104159 deriving (Show, Eq)

@@ -113,12 +168,12 @@ instance

113168 shrink = coerce (genericShrink :: a -> [a])

114169#endif

115170

171+type Arg self field = (TypesDiffer self field ~ 'True)

172+

116173type family TypesDiffer a b where

117174 TypesDiffer a a = 'False

118175 TypesDiffer a b = 'True

119176

120−type Arg self field = (TypesDiffer self field ~ 'True)

121−

122177type family AllFieldsFinal self (a :: * -> *) :: Bool where

123178 AllFieldsFinal self U1 = 'True

124179 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b

test/Aux.hsnew file+10

@@ -0,0 +1,10 @@

1+module Aux where

3+import Control.Exception

4+import Test.QuickCheck

6+failGeneration :: forall a. (Arbitrary a, Show a) => IO ()

7+failGeneration = do

8+ try (generate (arbitrary :: Gen a) >>= print) >>= \case

9+ Left (_ :: SomeException) -> pure ()

10+ Right _ -> error "Error expected"

test/NoTypecheckTest.hs+2−5

@@ -5,7 +5,7 @@

66module NoTypecheckTest where

8−import Control.Exception

8+import Aux

99import GHC.Generics (Generic)

1010import Test.QuickCheck

1111import Test.QuickCheck.Arbitrary.Generic

@@ -20,7 +20,4 @@ instance Arbitrary R where

2020 shrink = genericShrink

2121

2222unit_mustFail :: IO ()

23−unit_mustFail = do

24− try (generate (arbitrary :: Gen R) >>= print) >>= \case

25− Left (_ :: SomeException) -> pure ()

26− Right _ -> error "Error expected"

23+unit_mustFail = failGeneration @R

test/ParametersTest.hsnew file+34

@@ -0,0 +1,34 @@

1+{-# OPTIONS_GHC -fdefer-type-errors #-}

2+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}

4+module ParametersTest where

6+import Aux

7+import Control.DeepSeq

8+import GHC.Generics (Generic)

9+import Test.QuickCheck

10+import Test.QuickCheck.Arbitrary.Generic

11+

12+data A a = A a

13+ deriving (Eq, Ord, Show)

14+ deriving anyclass NFData

15+ deriving (Generic)

16+

17+instance (Arbitrary a) => Arbitrary (A a) where

18+ arbitrary = genericArbitrary

19+ shrink = genericShrink

20+

21+data B a = B a

22+ deriving (Eq, Ord, Show)

23+ deriving anyclass NFData

24+ deriving (Generic)

25+

26+instance (Arg (B a) a, Arbitrary a) => Arbitrary (B a) where

27+ arbitrary = genericArbitrary

28+ shrink = genericShrink

29+

30+unit_argumentConstraintFail :: IO ()

31+unit_argumentConstraintFail = failGeneration @(A Int)

32+

33+prop_properArgumentConstraint :: B Int -> Property

34+prop_properArgumentConstraint = total