diff --git a/quickcheck-arbitrary-adt.cabal b/quickcheck-arbitrary-adt.cabal --- a/quickcheck-arbitrary-adt.cabal +++ b/quickcheck-arbitrary-adt.cabal @@ -1,40 +1,53 @@ -name: quickcheck-arbitrary-adt -version: 0.2.0.0 -synopsis: Generic typeclasses for generating arbitrary ADTs -description: Improve arbitrary value generation for ADTs -homepage: https://github.com/plow-technologies/quickcheck-arbitrary-adt#readme -license: BSD3 -license-file: LICENSE -author: James M.C. Haver II -maintainer: mchaver@gmail.com -copyright: 2016 James M.C. Haver II -category: Testing -build-type: Simple -cabal-version: >=1.10 -stability: Beta - -library - hs-source-dirs: src - exposed-modules: Test.QuickCheck.Arbitrary.ADT - build-depends: base >= 4.7 && < 5 - , QuickCheck - default-language: Haskell2010 - -test-suite test - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Spec.hs - build-depends: base - , hspec - , lens - , template-haskell - , QuickCheck - , quickcheck-arbitrary-adt - , transformers +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 +name: quickcheck-arbitrary-adt +version: 0.3.0.0 +synopsis: Generic typeclasses for generating arbitrary ADTs +description: Improve arbitrary value generation for ADTs +category: Testing +stability: Beta +homepage: https://github.com/plow-technologies/quickcheck-arbitrary-adt#readme +bug-reports: https://github.com/plow-technologies/quickcheck-arbitrary-adt/issues +author: James M.C. Haver II +maintainer: mchaver@gmail.com +copyright: 2016-2017 Plow Technologies +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 source-repository head - type: git + type: git location: https://github.com/plow-technologies/quickcheck-arbitrary-adt + +library + hs-source-dirs: + src + ghc-options: -Wall -Wredundant-constraints -fprint-potential-instances + build-depends: + base >= 4.7 && < 5 + , QuickCheck + exposed-modules: + Test.QuickCheck.Arbitrary.ADT + other-modules: + Paths_quickcheck_arbitrary_adt + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + tests + build-depends: + base + , hspec + , lens + , template-haskell + , QuickCheck + , quickcheck-arbitrary-adt + , transformers + other-modules: + Test.QuickCheck.Arbitrary.ADTSpec + default-language: Haskell2010 diff --git a/src/Test/QuickCheck/Arbitrary/ADT.hs b/src/Test/QuickCheck/Arbitrary/ADT.hs --- a/src/Test/QuickCheck/Arbitrary/ADT.hs +++ b/src/Test/QuickCheck/Arbitrary/ADT.hs @@ -11,11 +11,11 @@ -} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Test.QuickCheck.Arbitrary.ADT ( -- * How to use this library @@ -40,22 +40,23 @@ ) where -import Data.Typeable - -import GHC.Generics - -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen +-- base +import Data.Typeable +import GHC.Generics +-- QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen -- $datatypes -- | ConstructorArbitraryPair holds the construct name as a string and an -- arbitrary instance of that constructor. -data ConstructorArbitraryPair a = ConstructorArbitraryPair { - capConstructor :: String -, capArbitrary :: a -} deriving (Eq,Generic,Read,Show,Typeable) +data ConstructorArbitraryPair a = + ConstructorArbitraryPair + { capConstructor :: String + , capArbitrary :: a + } deriving (Eq,Generic,Read,Show,Typeable) -- | fmap applies a function to `capArbitrary` instance Functor ConstructorArbitraryPair where @@ -65,11 +66,12 @@ arbitrary = ConstructorArbitraryPair <$> arbitrary <*> arbitrary -- | ADTArbitrarySingleton holds the type name and one ConstructorArbitraryPair. -data ADTArbitrarySingleton a = ADTArbitrarySingleton { - adtasModuleName :: String -, adtasTypeName :: String -, adtasCAP :: ConstructorArbitraryPair a -} deriving (Eq,Generic,Read,Show,Typeable) +data ADTArbitrarySingleton a = + ADTArbitrarySingleton + { adtasModuleName :: String + , adtasTypeName :: String + , adtasCAP :: ConstructorArbitraryPair a + } deriving (Eq,Generic,Read,Show,Typeable) -- | fmap applies a function to the ConstructorArbitraryPair in adtasCAP. instance Functor ADTArbitrarySingleton where @@ -80,11 +82,12 @@ -- | ADTArbitrary holds the type name and a ConstructorArbitraryPair -- for each constructor. -data ADTArbitrary a = ADTArbitrary { - adtModuleName :: String -, adtTypeName :: String -, adtCAPs :: [ConstructorArbitraryPair a] -} deriving (Eq,Generic,Read,Show,Typeable) +data ADTArbitrary a = + ADTArbitrary + { adtModuleName :: String + , adtTypeName :: String + , adtCAPs :: [ConstructorArbitraryPair a] + } deriving (Eq,Generic,Read,Show,Typeable) -- | fmap applies a function to each ConstructorArbitraryPair in adtCAPs. instance Functor ADTArbitrary where @@ -98,26 +101,26 @@ -- | ToADTArbitrary generalizes the production of arbitrary values for Sum types. -- and Product types. -class (Arbitrary a) => ToADTArbitrary a where +class ToADTArbitrary a where -- {-# MINIMAL toADTArbitrarySingleton, toADTArbitrary #-} -- | produce an arbitrary instance of one random constructor toADTArbitrarySingleton :: Proxy a -> Gen (ADTArbitrarySingleton a) - default toADTArbitrarySingleton ::( Arbitrary a - , Generic a - , GToADTArbitrarySingleton (Rep a) - , GToADTArbitrarySingleton (Rep (ADTArbitrarySingleton a))) - => Proxy a - -> Gen (ADTArbitrarySingleton a) + default toADTArbitrarySingleton :: + ( Generic a + , GToADTArbitrarySingleton (Rep a) + ) + => Proxy a + -> Gen (ADTArbitrarySingleton a) toADTArbitrarySingleton _ = fmap to <$> gToADTArbitrarySingleton (Proxy :: Proxy (Rep a)) -- | produce an arbitrary instance for each constructor in type a. toADTArbitrary :: Proxy a -> Gen (ADTArbitrary a) - default toADTArbitrary :: ( Arbitrary a - , Generic a - , GToADTArbitrary (Rep a) - , GToADTArbitrary (Rep (ADTArbitrary a))) - => Proxy a - -> Gen (ADTArbitrary a) + default toADTArbitrary :: + ( Generic a + , GToADTArbitrary (Rep a) + ) + => Proxy a + -> Gen (ADTArbitrary a) toADTArbitrary _ = fmap to <$> gToADTArbitrary (Proxy :: Proxy (Rep a)) @@ -148,31 +151,33 @@ getArb = capArbitrary . adtasCAP instance Arbitrary a => GToADTArbitrarySingleton (K1 i a) where - gToADTArbitrarySingleton _ = ADTArbitrarySingleton - <$> pure "" - <*> pure "" - <*> ( ConstructorArbitraryPair - <$> pure "" - <*> K1 <$> arbitrary - ) + gToADTArbitrarySingleton _ = + ADTArbitrarySingleton + <$> pure "" + <*> pure "" + <*> (ConstructorArbitraryPair + <$> pure "" + <*> K1 <$> arbitrary) instance (Constructor c, GToADTArbitrarySingleton rep) => GToADTArbitrarySingleton (M1 C c rep) where - gToADTArbitrarySingleton _ = ADTArbitrarySingleton - <$> pure "" - <*> pure "" - <*> ( ConstructorArbitraryPair con <$> ac) + gToADTArbitrarySingleton _ = + ADTArbitrarySingleton + <$> pure "" + <*> pure "" + <*> (ConstructorArbitraryPair con <$> ac) where kRep = gToADTArbitrarySingleton (Proxy :: Proxy rep) ac = M1 . capArbitrary . adtasCAP <$> kRep con = conName (undefined :: M1 C c rep ()) instance (Datatype t, Typeable t, GToADTArbitrarySingleton rep) => GToADTArbitrarySingleton (M1 D t rep) where - gToADTArbitrarySingleton _ = ADTArbitrarySingleton - <$> pure m - <*> pure t - <*> ( ConstructorArbitraryPair - <$> (capConstructor . adtasCAP <$> kRep) - <*> ac) + gToADTArbitrarySingleton _ = + ADTArbitrarySingleton + <$> pure m + <*> pure t + <*> (ConstructorArbitraryPair + <$> (capConstructor . adtasCAP <$> kRep) + <*> ac) where kRep = gToADTArbitrarySingleton (Proxy :: Proxy rep) ac = M1 . capArbitrary . adtasCAP <$> kRep @@ -180,18 +185,18 @@ t = datatypeName (undefined :: M1 D t rep ()) instance GToADTArbitrarySingleton rep => GToADTArbitrarySingleton (M1 S t rep) where - gToADTArbitrarySingleton _ = ADTArbitrarySingleton - <$> pure "" - <*> pure "" - <*> ( ConstructorArbitraryPair - <$> pure "" - <*> ac) + gToADTArbitrarySingleton _ = + ADTArbitrarySingleton + <$> pure "" + <*> pure "" + <*> (ConstructorArbitraryPair + <$> pure "" + <*> ac) where kRep = gToADTArbitrarySingleton (Proxy :: Proxy rep) ac = M1 . capArbitrary . adtasCAP <$> kRep - -- | GToADTArbitrary is a typeclass for generalizing the creation -- of a list of arbitrary values for each constructor of a type. It also -- returns the name of the constructor and the type name for reference and file @@ -209,7 +214,7 @@ b <- fmap R1 <$> gToADTArbitrary (Proxy :: Proxy r) return $ ADTArbitrary "" "" (adtCAPs a ++ adtCAPs b) -instance (GToADTArbitrarySingleton l, GToADTArbitrary l, GToADTArbitrarySingleton r, GToADTArbitrary r) => GToADTArbitrary (l :*: r) where +instance (GToADTArbitrarySingleton l, GToADTArbitrarySingleton r) => GToADTArbitrary (l :*: r) where gToADTArbitrary _ = do x <- getArb <$> gToADTArbitrarySingleton (Proxy :: Proxy l) y <- getArb <$> gToADTArbitrarySingleton (Proxy :: Proxy r) @@ -218,10 +223,11 @@ getArb = capArbitrary . adtasCAP instance Arbitrary a => GToADTArbitrary (K1 i a) where - gToADTArbitrary _ = ADTArbitrary - <$> pure "" - <*> pure "" - <*> (:[]) <$> genCap + gToADTArbitrary _ = + ADTArbitrary + <$> pure "" + <*> pure "" + <*> (:[]) <$> genCap where arb = arbitrary :: Gen a genCap = ConstructorArbitraryPair <$> pure "" <*> (K1 <$> arb) @@ -246,10 +252,11 @@ -- selector level instance GToADTArbitrary rep => GToADTArbitrary (M1 S t rep) where - gToADTArbitrary _ = ADTArbitrary - <$> pure "" - <*> pure "" - <*> (:[]) <$> (ConstructorArbitraryPair "" <$> ac) + gToADTArbitrary _ = + ADTArbitrary + <$> pure "" + <*> pure "" + <*> (:[]) <$> (ConstructorArbitraryPair "" <$> ac) where kRep = gToADTArbitrary (Proxy :: Proxy rep) ac = M1 . capArbitrary . head . adtCAPs <$> kRep @@ -258,7 +265,6 @@ -- | GArbitrary is a typeclass for generalizing the creation of single arbitrary -- product and sum types. It creates an arbitrary generating function of this -- style: @TypeName \<$\> arbitrary \<*\> arbitrary@. --- class GArbitrary rep where gArbitrary :: Gen (rep a) @@ -298,16 +304,18 @@ -- > import Test.QuickCheck.Arbitrary.ADT -- > -- > -- Sum Type, multiple constructors with parameters --- > data Fruit = Apple Int --- > | Orange String Int --- > | PassionFruit Int String Int +-- > data Fruit +-- > = Apple Int +-- > | Orange String Int +-- > | PassionFruit Int String Int -- > deriving (Generic, Show) -- > -- > -- Product Type, single constructor --- > data Person = Person { --- > name :: String --- > , age :: Int --- > } deriving (Generic, Show) +-- > data Person = +-- > Person +-- > { name :: String +-- > , age :: Int +-- > } deriving (Generic, Show) -- -- Any type that implements `ToADTArbitrary` must also implement `Arbitrary`. -- These examples all require that the data type is an instance of `Generic`. diff --git a/tests/Test/QuickCheck/Arbitrary/ADTSpec.hs b/tests/Test/QuickCheck/Arbitrary/ADTSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/QuickCheck/Arbitrary/ADTSpec.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Test.QuickCheck.Arbitrary.ADTSpec (main, spec) where + +-- base +import Data.Maybe (isJust) +import Data.Proxy +import GHC.Generics +-- hspec +import Test.Hspec +-- lens +import Control.Lens +-- QuickCheck +import Test.QuickCheck +-- quickcheck-adt-arbitrary +import Test.QuickCheck.Arbitrary.ADT + +-- | A tagless type has constructor which has no parameters. It has U1 in its +-- `GHC.Generics` representation. +data TaglessType = TaglessType + deriving (Eq,Generic,Show) + +instance ToADTArbitrary TaglessType +instance Arbitrary TaglessType where + arbitrary = genericArbitrary + +$(makePrisms ''TaglessType) + +-- | A sum type (disjoin union, tagged union) has multiple type constructors +-- that all result in values of different shapes, but the same type. It has +-- `:+:` and `M1 C c rep` in its `GHC.Generics` representation. +data SumType + = SumType1 Int + | SumType2 String Int + | SumType3 String [Int] Double + | SumType4 String [String] [Int] Double + deriving (Eq,Generic,Show) + +instance ToADTArbitrary SumType +instance Arbitrary SumType where + arbitrary = genericArbitrary + +$(makePrisms ''SumType) + +-- | This type is an example of a sum type that has constructors building sum +-- types. +data SumOfSums + = SSBareSumType TaglessType + | SSSumType SumType + deriving (Eq,Generic,Show) + +instance ToADTArbitrary SumOfSums +instance Arbitrary SumOfSums where + arbitrary = genericArbitrary + +$(makePrisms ''SumOfSums) + +-- | A product type has one constructor with one records. It has :*: and `M1 S s rep` +-- in its `GHC.Generics` representation. + +data ProductType = + ProductType + { name :: String + , age :: Int + } deriving (Eq,Generic,Show) + +instance ToADTArbitrary ProductType + +data PolymorphicParameterProductType a = + PolymorphicParameterProductType + { firstItem :: Int + , secondItem :: a + } deriving (Eq,Show,Generic) + +instance ToADTArbitrary (PolymorphicParameterProductType String) + +data NonGenericSumType + = NGSumType1 Int + | NGSumType2 String Int + | NGSumType3 String [Int] Double + | NGSumType4 String [String] [Int] Double + deriving (Eq, Show) + +instance ToADTArbitrary NonGenericSumType where + toADTArbitrarySingleton Proxy = + ADTArbitrarySingleton "Test.QuickCheck.Arbitrary.ADTSpec" "NonGenericSum" + <$> oneof + [ ConstructorArbitraryPair "NGSumType1" <$> (NGSumType1 <$> arbitrary) + , ConstructorArbitraryPair "NGSumType2" <$> (NGSumType2 <$> arbitrary <*> arbitrary) + , ConstructorArbitraryPair "NGSumType3" <$> (NGSumType3 <$> arbitrary <*> arbitrary <*> arbitrary) + , ConstructorArbitraryPair "NGSumType4" <$> (NGSumType4 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + ] + + toADTArbitrary Proxy = + ADTArbitrary "Test.QuickCheck.Arbitrary.ADTSpec" "NonGenericSum" + <$> sequence + [ ConstructorArbitraryPair "NGSumType1" <$> (NGSumType1 <$> arbitrary) + , ConstructorArbitraryPair "NGSumType2" <$> (NGSumType2 <$> arbitrary <*> arbitrary) + , ConstructorArbitraryPair "NGSumType3" <$> (NGSumType3 <$> arbitrary <*> arbitrary <*> arbitrary) + , ConstructorArbitraryPair "NGSumType4" <$> (NGSumType4 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + ] + +$(makePrisms ''NonGenericSumType) + +data NonGenericProductType = + NonGenericProductType + { ngName :: String + , ngAge :: Int + } deriving (Eq,Generic,Show) + +instance ToADTArbitrary NonGenericProductType where + toADTArbitrarySingleton Proxy = + ADTArbitrarySingleton "Test.QuickCheck.Arbitrary.ADTSpec" "NonGenericSum" + <$> (ConstructorArbitraryPair "NonGenericProductType" <$> (NonGenericProductType <$> arbitrary <*> arbitrary)) + + toADTArbitrary Proxy = + ADTArbitrary "Test.QuickCheck.Arbitrary.ADTSpec" "NonGenericProductType" + <$> sequence + [ ConstructorArbitraryPair "NonGenericProductType" <$> (NonGenericProductType <$> arbitrary <*> arbitrary) + ] + +spec :: Spec +spec = do + describe "QuickCheck Arbitrary ADT: Generic ToADTArbitrary type class instance" $ do + it "toADTArbitrary of a tagless type should create an instance of the bare constructor" $ do + _ <- generate (toADTArbitrarySingleton (Proxy :: Proxy TaglessType)) + taglessType <- generate (toADTArbitrary (Proxy :: Proxy TaglessType)) + let taglessTypeArbitraries = capArbitrary <$> adtCAPs taglessType + or (isJust . preview _TaglessType <$> taglessTypeArbitraries) `shouldBe` True + + it "toADTArbitrary of a sum type creates an instance with each constructor" $ do + sumTypeCAP <- capArbitrary . adtasCAP <$> generate (toADTArbitrarySingleton (Proxy :: Proxy SumType)) + sumTypes <- generate (toADTArbitrary (Proxy :: Proxy SumType)) + let sumTypeArbitraries = capArbitrary <$> adtCAPs sumTypes + + or + [ isJust . preview _SumType1 $ sumTypeCAP + , isJust . preview _SumType2 $ sumTypeCAP + , isJust . preview _SumType3 $ sumTypeCAP + , isJust . preview _SumType4 $ sumTypeCAP + ] `shouldBe` True + + and + [ or $ isJust . preview _SumType1 <$> sumTypeArbitraries + , or $ isJust . preview _SumType2 <$> sumTypeArbitraries + , or $ isJust . preview _SumType3 <$> sumTypeArbitraries + , or $ isJust . preview _SumType4 <$> sumTypeArbitraries + , length sumTypeArbitraries == 4 + ] `shouldBe` True + + it "toADTArbitrary of a sum of sum types creates an instance with each constructor of the top level" $ do + _ <- generate (toADTArbitrarySingleton (Proxy :: Proxy SumOfSums)) + sumOfSums <- generate (toADTArbitrary (Proxy :: Proxy SumOfSums)) + let sumOfSumsArbitraries = capArbitrary <$> adtCAPs sumOfSums + and + [ or $ isJust . preview _SSBareSumType <$> sumOfSumsArbitraries + , or $ isJust . preview _SSSumType <$> sumOfSumsArbitraries + , length sumOfSumsArbitraries == 2 + ] `shouldBe` True + + it "toADTArbitrary of a product type creates a single instance" $ do + _ <- generate (toADTArbitrarySingleton (Proxy :: Proxy ProductType)) + productType <- generate (toADTArbitrary (Proxy :: Proxy ProductType)) + let productTypeArbitraries = capArbitrary <$> adtCAPs productType + + length productTypeArbitraries `shouldBe` 1 + + it "toADTArbitrary of a product type that has a polymorphic parameter should work as well" $ do + _ <- generate (toADTArbitrarySingleton (Proxy :: Proxy (PolymorphicParameterProductType String))) + productType <- generate (toADTArbitrary (Proxy :: Proxy (PolymorphicParameterProductType String))) + let productTypeArbitraries = capArbitrary <$> adtCAPs productType + + length productTypeArbitraries `shouldBe` 1 + + describe "QuickCheck Arbitrary ADT: ToADTArbitrary type class instance without Generics" $ do + it "toADTArbitrary of a sum type creates an instance with each constructor" $ do + sumTypeCAP <- capArbitrary . adtasCAP <$> generate (toADTArbitrarySingleton (Proxy :: Proxy NonGenericSumType)) + sumTypes <- generate (toADTArbitrary (Proxy :: Proxy NonGenericSumType)) + let sumTypeArbitraries = capArbitrary <$> adtCAPs sumTypes + + or + [ isJust . preview _NGSumType1 $ sumTypeCAP + , isJust . preview _NGSumType2 $ sumTypeCAP + , isJust . preview _NGSumType3 $ sumTypeCAP + , isJust . preview _NGSumType4 $ sumTypeCAP + ] `shouldBe` True + + and + [ or $ isJust . preview _NGSumType1 <$> sumTypeArbitraries + , or $ isJust . preview _NGSumType2 <$> sumTypeArbitraries + , or $ isJust . preview _NGSumType3 <$> sumTypeArbitraries + , or $ isJust . preview _NGSumType4 <$> sumTypeArbitraries + , length sumTypeArbitraries == 4 + ] `shouldBe` True + + it "toADTArbitrary of a product type creates a single instance" $ do + _ <- generate (toADTArbitrarySingleton (Proxy :: Proxy NonGenericProductType)) + productType <- generate (toADTArbitrary (Proxy :: Proxy NonGenericProductType)) + let productTypeArbitraries = capArbitrary <$> adtCAPs productType + + length productTypeArbitraries `shouldBe` 1 + +main :: IO () +main = hspec spec