quickcheck-arbitrary-adt 0.2.0.0 → 0.3.0.0

raw patch · 3 files changed

+340/−113 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• quickcheck-arbitrary-adt.cabal +49/−36
• src/Test/QuickCheck/Arbitrary/ADT.hs +85/−77
• tests/Test/QuickCheck/Arbitrary/ADTSpec.hs +206/−0

@@ -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

@@ -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`.

@@ -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