diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright James M.C. Haver II (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James M.C. Haver II nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/quickcheck-arbitrary-adt.cabal b/quickcheck-arbitrary-adt.cabal new file mode 100644 --- /dev/null +++ b/quickcheck-arbitrary-adt.cabal @@ -0,0 +1,39 @@ +name: quickcheck-arbitrary-adt +version: 0.1.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 + +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 + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/plow-technologies/quickcheck-arbitrary-adt diff --git a/src/Test/QuickCheck/Arbitrary/ADT.hs b/src/Test/QuickCheck/Arbitrary/ADT.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Arbitrary/ADT.hs @@ -0,0 +1,342 @@ + +-- | Type classes to assist random generation of values for various types of +-- abstract data types. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.QuickCheck.Arbitrary.ADT ( + -- * How to use this library + -- $use + + -- * Data types + -- $datatypes + ConstructorArbitraryPair(..) + , ADTArbitrarySingleton(..) + , ADTArbitrary(..) + + -- * Type classes + -- $typeclasses + , ToADTArbitrary(..) + + -- * Generic type classes + -- $generictypeclasses + , GToADTArbitrarySingleton(..) + , GToADTArbitrary(..) + , GArbitrary(..) + , genericArbitrary + + ) where + +import Data.Typeable + +import GHC.Generics + +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) + +-- | fmap applies a function to `_capArbitrary` +instance Functor ConstructorArbitraryPair where + fmap f (ConstructorArbitraryPair c a) = ConstructorArbitraryPair c (f a) + +instance (Arbitrary a) => Arbitrary (ConstructorArbitraryPair a) where + arbitrary = ConstructorArbitraryPair <$> arbitrary <*> arbitrary + +-- | ADTArbitrarySingleton holds the type name and one ConstructorArbitraryPair. +data ADTArbitrarySingleton a = ADTArbitrarySingleton { + _adtasTypeName :: String +, _adtasCAP :: ConstructorArbitraryPair a +} deriving (Eq,Generic,Read,Show,Typeable) + +-- | fmap applies a function to the ConstructorArbitraryPair in _adtasCAP. +instance Functor ADTArbitrarySingleton where + fmap f (ADTArbitrarySingleton t c) = ADTArbitrarySingleton t (f <$> c) + +instance (Arbitrary a) => Arbitrary (ADTArbitrarySingleton a) where + arbitrary = ADTArbitrarySingleton <$> arbitrary <*> arbitrary + +-- | ADTArbitrary holds the type name and a ConstructorArbitraryPair +-- for each constructor. +data ADTArbitrary a = ADTArbitrary { + _adtTypeName :: String +, _adtCAPs :: [ConstructorArbitraryPair a] +} deriving (Eq,Generic,Read,Show,Typeable) + +-- | fmap applies a function to each ConstructorArbitraryPair in _adtCAPs. +instance Functor ADTArbitrary where + fmap f (ADTArbitrary t cs) = ADTArbitrary t (fmap f <$> cs) + +instance (Arbitrary a) => Arbitrary (ADTArbitrary a) where + arbitrary = ADTArbitrary <$> arbitrary <*> arbitrary + + + +-- $typeclasses + +-- | ToADTArbitrary generalizes the production of arbitrary values for Sum types. +-- and Product types. +class (Arbitrary a) => 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) + 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) + toADTArbitrary _ = fmap to <$> gToADTArbitrary (Proxy :: Proxy (Rep a)) + + + +-- $generictypeclasses + +-- | GToADTArbitrarySingleton creates an arbitrary value and returns the name of the +-- constructor that was used to create it and the type name. + +class GToADTArbitrarySingleton rep where + gToADTArbitrarySingleton :: Proxy rep -> Gen (ADTArbitrarySingleton (rep a)) + +instance GToADTArbitrarySingleton U1 where + gToADTArbitrarySingleton _ = pure $ ADTArbitrarySingleton "" $ ConstructorArbitraryPair "" U1 + +instance (GToADTArbitrarySingleton l, GToADTArbitrarySingleton r) => GToADTArbitrarySingleton (l :+: r) where + gToADTArbitrarySingleton _ = do + b <- arbitrary + if b then fmap L1 <$> gToADTArbitrarySingleton (Proxy :: Proxy l) + else fmap R1 <$> gToADTArbitrarySingleton (Proxy :: Proxy r) + +instance (GToADTArbitrarySingleton l, GToADTArbitrarySingleton r) => GToADTArbitrarySingleton (l :*: r) where + gToADTArbitrarySingleton _ = do + x <- getArb <$> gToADTArbitrarySingleton (Proxy :: Proxy l) + y <- getArb <$> gToADTArbitrarySingleton (Proxy :: Proxy r) + return $ ADTArbitrarySingleton "" $ ConstructorArbitraryPair "" (x :*: y) + where + getArb = _capArbitrary . _adtasCAP + +instance Arbitrary a => GToADTArbitrarySingleton (K1 i a) where + gToADTArbitrarySingleton _ = ADTArbitrarySingleton + <$> pure "" + <*> ( ConstructorArbitraryPair + <$> pure "" + <*> K1 <$> arbitrary + ) + +instance (Constructor c, GToADTArbitrarySingleton rep) => GToADTArbitrarySingleton (M1 C c rep) where + gToADTArbitrarySingleton _ = ADTArbitrarySingleton + <$> 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 t + <*> ( ConstructorArbitraryPair + <$> (_capConstructor . _adtasCAP <$> kRep) + <*> ac) + where + kRep = gToADTArbitrarySingleton (Proxy :: Proxy rep) + ac = M1 . _capArbitrary . _adtasCAP <$> kRep + t = datatypeName (undefined :: M1 D t rep ()) + +instance GToADTArbitrarySingleton rep => GToADTArbitrarySingleton (M1 S t rep) where + gToADTArbitrarySingleton _ = ADTArbitrarySingleton + <$> 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 +-- creation. + +class GToADTArbitrary rep where + gToADTArbitrary :: Proxy rep -> Gen (ADTArbitrary (rep a)) + +instance GToADTArbitrary U1 where + gToADTArbitrary _ = pure $ ADTArbitrary "" [ConstructorArbitraryPair "" U1] + +instance (GToADTArbitrary l, GToADTArbitrary r) => GToADTArbitrary (l :+: r) where + gToADTArbitrary _ = do + a <- fmap L1 <$> gToADTArbitrary (Proxy :: Proxy l) + 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 + gToADTArbitrary _ = do + x <- getArb <$> gToADTArbitrarySingleton (Proxy :: Proxy l) + y <- getArb <$> gToADTArbitrarySingleton (Proxy :: Proxy r) + return $ ADTArbitrary "" [ConstructorArbitraryPair "" (x :*: y)] + where + getArb = _capArbitrary . _adtasCAP + +instance Arbitrary a => GToADTArbitrary (K1 i a) where + gToADTArbitrary _ = ADTArbitrary + <$> pure "" + <*> (:[]) <$> genCap + where + arb = arbitrary :: Gen a + genCap = ConstructorArbitraryPair <$> pure "" <*> (K1 <$> arb) + +-- constructor level +instance (Constructor c, GToADTArbitrary rep) => GToADTArbitrary (M1 C c rep) where + gToADTArbitrary _ = ADTArbitrary <$> pure "" <*> (:[]) . ConstructorArbitraryPair con <$> ac + where + kRep = gToADTArbitrary (Proxy :: Proxy rep) + ac = M1 . _capArbitrary . head . _adtCAPs <$> kRep + con = conName (undefined :: M1 C c rep ()) + +-- type level +instance (Datatype t, GToADTArbitrary rep) => GToADTArbitrary (M1 D t rep) where + gToADTArbitrary _ = ADTArbitrary <$> pure t <*> m1caps + where + kRep = gToADTArbitrary (Proxy :: Proxy rep) + caps = _adtCAPs <$> kRep + m1caps = (fmap . fmap) M1 <$> caps + t = datatypeName (undefined :: M1 D t rep ()) + +-- selector level +instance GToADTArbitrary rep => GToADTArbitrary (M1 S t rep) where + gToADTArbitrary _ = ADTArbitrary + <$> pure "" + <*> (:[]) <$> (ConstructorArbitraryPair "" <$> ac) + where + kRep = gToADTArbitrary (Proxy :: Proxy rep) + ac = M1 . _capArbitrary . head . _adtCAPs <$> kRep + + +-- | 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) + +instance GArbitrary U1 where + gArbitrary = pure U1 + +instance (GArbitrary l, GArbitrary r) => GArbitrary (l :+: r) where + gArbitrary = do + b <- arbitrary + if b then L1 <$> gArbitrary + else R1 <$> gArbitrary + +instance (GArbitrary l, GArbitrary r) => GArbitrary (l :*: r) where + gArbitrary = (:*:) <$> gArbitrary <*> gArbitrary + +instance Arbitrary a => GArbitrary (K1 i a) where + gArbitrary = K1 <$> arbitrary + +instance GArbitrary rep => GArbitrary (M1 i t rep) where + gArbitrary = M1 <$> gArbitrary + +genericArbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a +genericArbitrary = to <$> gArbitrary + +-- $use +-- +-- How to use `ToADTArbitrary` with Generic. +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import Data.Proxy +-- > import GHC.Generics +-- > import Test.QuickCheck +-- > import Test.QuickCheck.Arbitrary.ADT +-- > +-- > -- Sum Type, multiple constructors with parameters +-- > 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) +-- +-- Any type that implements `ToADTArbitrary` must also implement `Arbitrary`. +-- These examples all require that the data type is an instance of `Generic`. +-- +-- @ +-- instance Arbitrary Fruit where +-- arbitrary = `genericArbitrary` +-- +-- instance `ToADTArbitrary` Fruit +-- +-- instance Arbitrary Person where +-- arbitrary = `genericArbitrary` +-- +-- instance `ToADTArbitrary` Person +-- @ +-- +-- Now we can use `toADTArbitrarySingleton` to produce an arbitrary value of +-- one random constructor along with some metadata. `toADTArbitrary` will +-- produce an arbitrary value for each constructor and return it along with +-- a String of the constructor name. +-- +-- @ +-- λ> generate (toADTArbitrarySingleton (Proxy :: Proxy Fruit)) +-- ADTArbitrarySingleton { +-- _adtasTypeName = \"Fruit\" +-- , _adtasCAP = ConstructorArbitraryPair { +-- _capConstructor = \"Apple\", _capArbitrary = Apple 30}} +-- +-- λ> generate (toADTArbitrary (Proxy :: Proxy Fruit)) +-- ADTArbitrary { +-- _adtTypeName = \"Fruit\" +-- , _adtCAPs = [ +-- ConstructorArbitraryPair { +-- _capConstructor = \"Apple\" +-- , _capArbitrary = Apple 17} +-- , ConstructorArbitraryPair { +-- _capConstructor = \"Orange\" +-- , _capArbitrary = Orange \"abcdef\" 18} +-- , ConstructorArbitraryPair { +-- _capConstructor = \"PassionFruit\" +-- , _capArbitrary = PassionFruit 16 "datadata" 6}]} +-- +-- λ> generate (toADTArbitrarySingleton (Proxy :: Proxy Person)) +-- ADTArbitrarySingleton { +-- _adtasTypeName = \"Person\" +-- , _adtasCAP = ConstructorArbitraryPair {_capConstructor = \"Person\", _capArbitrary = Person {name = "John Doe", age = 30}}} +-- +-- λ> generate (toADTArbitrary (Proxy :: Proxy Person)) +-- ADTArbitrary { +-- _adtTypeName = \"Person\" +-- , _adtCAPs = [ConstructorArbitraryPair {_capConstructor = \"Person\", _capArbitrary = Person {name = "Jane Doe", age = 15}}]} +-- @ diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}