quickcheck-arbitrary-template (empty) → 0.2.0.0
raw patch · 9 files changed
+490/−0 lines, 9 filesdep +QuickCheckdep +basedep +safe
Dependencies added: QuickCheck, base, safe, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, template-haskell
Files
- ChangeLog.md +5/−0
- LICENSE +9/−0
- README.md +74/−0
- quickcheck-arbitrary-template.cabal +69/−0
- src/Test/QuickCheck/TH/Generators.hs +3/−0
- src/Test/QuickCheck/TH/Generators/Internal.hs +149/−0
- src/Test/QuickCheck/TH/Generators/Internal/BuildArbitrary.hs +101/−0
- test/Spec.hs +5/−0
- test/Test/QuickCheck/TH/GeneratorsSpec.hs +75/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for quickcheck-arbitrary-template++## 0.2.0.0 -- 2018-02-07++* Add version range template-haskell >= 2.11 && < 2.13 and add support for 2.12.
+ LICENSE view
@@ -0,0 +1,9 @@+The MIT License (MIT)++Copyright (c) 2016 Plow Technologies++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,74 @@+# quickcheck-arbitrary-template++Test.QuickCheck.TH.GeneratorsSpec++contains one routine:+``` makeArbitrary ```++Which builds, a generator that can be used to create an arbitrary instance.++It does not create the instance directly for you. ++It supports creating sum types and record types+each constructor may have at most 7 arguments.++## Installation++``` stack build ```+++## Usage++An example (from the tests)++``` haskell+{-# LANGUAGE TemplateHaskell #-}+module Test.QuickCheck.TH.GeneratorsSpec (tests) where++import Test.QuickCheck.TH.Generators++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import Data.List+import Data.Ord++++-- | These example types should build arbitrary instances correctly ++data ExampleSumTypes = ExampleSum0 + | ExampleSum1 Int+ | ExampleSum2 Int Int+ | ExampleSum3 Int Int Int+ | ExampleSum4 Int Int Int Int+ | ExampleSum5 Int Int Int Int Int+ | ExampleSum6 Int Int Int Int Int Int+ | ExampleSum7 Int Int Int Int Int Int+ deriving (Show,Ord,Eq)++makeArbitrary ''ExampleSumTypes+++instance Arbitrary ExampleSumTypes where+ arbitrary = arbitraryExampleSumTypes++tests :: TestTree+tests = testGroup "Tests" [properties]++properties :: TestTree+properties = testGroup "Properties" [qcProps]++qcProps = testGroup "(checked by QuickCheck)"+ [ QC.testProperty "sort == sort . reverse" (+ \list -> sort (list :: [ExampleSumTypes]) == sort (reverse list)) ]++```++## How to run tests++```+stack test quickcheck-arbitrary-template+```+
+ quickcheck-arbitrary-template.cabal view
@@ -0,0 +1,69 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 49a4245a932af4c748794086e93568274578a49db3655729351b10ea8498ca8d++name: quickcheck-arbitrary-template+version: 0.2.0.0+synopsis: Generate QuickCheck Gen for Sum Types+description: Building Sum Type arbitrary instance is kind of a pain. This tool helps automate the process.+category: Testing+homepage: https://github.com/plow-technologies/quickcheck-arbitrary-adt#readme+bug-reports: https://github.com/plow-technologies/quickcheck-arbitrary-template/issues+author: Scott Murphy <scottmurphy09@gmail.com>+maintainer: Scott Murphy <scottmurphy09@gmail.com>+copyright: 2016-2018 Plow Technologies+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/plow-technologies/quickcheck-arbitrary-template++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ QuickCheck+ , base >=4 && <5+ , safe+ , template-haskell >=2.11 && <2.13+ exposed-modules:+ Test.QuickCheck.TH.Generators+ Test.QuickCheck.TH.Generators.Internal+ Test.QuickCheck.TH.Generators.Internal.BuildArbitrary+ other-modules:+ Paths_quickcheck_arbitrary_template+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ src+ test+ ghc-options: -Wall+ build-depends:+ QuickCheck+ , base >=4 && <5+ , safe+ , tasty+ , tasty-golden+ , tasty-hunit+ , tasty-quickcheck+ , template-haskell >=2.11 && <2.13+ other-modules:+ Test.QuickCheck.TH.Generators+ Test.QuickCheck.TH.Generators.Internal+ Test.QuickCheck.TH.Generators.Internal.BuildArbitrary+ Test.QuickCheck.TH.GeneratorsSpec+ Paths_quickcheck_arbitrary_template+ default-language: Haskell2010
+ src/Test/QuickCheck/TH/Generators.hs view
@@ -0,0 +1,3 @@+module Test.QuickCheck.TH.Generators (makeArbitrary) where++import Test.QuickCheck.TH.Generators.Internal (makeArbitrary)
+ src/Test/QuickCheck/TH/Generators/Internal.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.QuickCheck.TH.Generators.Internal (makeArbitrary) where+++import Data.Monoid ((<>))++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Test.QuickCheck+import Test.QuickCheck.TH.Generators.Internal.BuildArbitrary+++-- | create buildArb1 through buildArb20 automatically+$(buildArbAny 1)+$(buildArbAny 2)+$(buildArbAny 3)+$(buildArbAny 4)+$(buildArbAny 5)+$(buildArbAny 6)+$(buildArbAny 7)+$(buildArbAny 8)+$(buildArbAny 9)+$(buildArbAny 10)+$(buildArbAny 11)+$(buildArbAny 12)+$(buildArbAny 13)+$(buildArbAny 14)+$(buildArbAny 15)+$(buildArbAny 16)+$(buildArbAny 17)+$(buildArbAny 18)+$(buildArbAny 19)+$(buildArbAny 20)++-- | Boilerplate for top level splices.+--+-- The given 'Name' must be from a type constructor. Furthermore, the+-- type constructor must be either a data type or a newtype. Any other+-- value will result in an exception.+withType :: Name+ -> ([TyVarBndr] -> [Con] -> Q a)+ -- ^ Function that generates the actual code. Will be applied+ -- to the type variable binders and constructors extracted+ -- from the given 'Name'.+ -> Q a+ -- ^ Resulting value in the 'Q'uasi monad.+withType name f = do+ info <- reify name+ case info of+ TyConI dec ->+ case dec of+ DataD _ _ tvbs _ cons' _ -> f tvbs cons'+ NewtypeD _ _ tvbs _ con _ -> f tvbs [con]+ other -> error $ "Example.TH.withType: Unsupported type: "+ ++ show other+ _ -> error "Example.TH.withType: I need the name of a type."+++-- | Extracts the name from a constructor.++-- | Make a ('Gen' a) for type 'a'+-- Currently support arbitrary Sum types up to 7 params+-- per constructor.+--+-- Record Types not currently supported+makeArbitrary :: Name -> Q [Dec]+makeArbitrary n = withType n runConstructionApp+ where+ runConstructionApp _ con = do+ dec <- applyCon n con+ return dec++-- | build the function taht applys the type constructor+applyCon :: Name -> [Con] -> DecsQ+applyCon n cons' = sequence [signature,value]+ where+ signature = sigD finalFunctionName (appT (conT ''Gen) (conT n))+ value = valD (varP finalFunctionName) (normalB (makeArbList cons')) []+ finalFunctionName = mkName ("arbitrary" <> nameBase n)+++-- | select one of the list of generators+-- Q Exp == oneOf [Gen *]+makeArbList :: [Con] -> Q Exp+makeArbList cons' = appE (varE 'oneof)+ (listE $ asNormalOrRecC applyConExp cons' )++-- | Normal Constructors are the only ones we are considering+asNormalOrRecC :: ((Name, [StrictType]) -> a) -> [Con] -> [a]+asNormalOrRecC f cons' = foldr decodeC [] cons'+ where+ decodeC (RecC n l) lst = (f (n, varStrictToStrict <$> l)) : lst+ decodeC (NormalC n l) lst = (f (n, l)) : lst+ decodeC _ lst = lst+ varStrictToStrict (_ , s,t) = (s,t)++-- | This is where we run the sum type thing+-- Q Exp+applyConExp :: (Name, [StrictType]) -> ExpQ+applyConExp deconstructedConstructor = runMapAndApp argCount+ where+ conName = fst deconstructedConstructor+ argCount = fromIntegral . length . snd $ deconstructedConstructor :: Integer+ runMapAndApp :: Integer -> ExpQ+ runMapAndApp 0 = appE (varE 'arbReturn ) (conE conName)+ runMapAndApp 1 = appE (varE 'buildArb1 ) (conE conName)+ runMapAndApp 2 = appE (varE 'buildArb2 ) (conE conName)+ runMapAndApp 3 = appE (varE 'buildArb3 ) (conE conName)+ runMapAndApp 4 = appE (varE 'buildArb4 ) (conE conName)+ runMapAndApp 5 = appE (varE 'buildArb5 ) (conE conName)+ runMapAndApp 6 = appE (varE 'buildArb6 ) (conE conName)+ runMapAndApp 7 = appE (varE 'buildArb7 ) (conE conName)+ runMapAndApp 8 = appE (varE 'buildArb8 ) (conE conName)+ runMapAndApp 9 = appE (varE 'buildArb9 ) (conE conName)+ runMapAndApp 10 = appE (varE 'buildArb10 ) (conE conName)+ runMapAndApp 11 = appE (varE 'buildArb11 ) (conE conName)+ runMapAndApp 12 = appE (varE 'buildArb12 ) (conE conName)+ runMapAndApp 13 = appE (varE 'buildArb13 ) (conE conName)+ runMapAndApp 14 = appE (varE 'buildArb14 ) (conE conName)+ runMapAndApp 15 = appE (varE 'buildArb15 ) (conE conName)+ runMapAndApp 16 = appE (varE 'buildArb16 ) (conE conName)+ runMapAndApp 17 = appE (varE 'buildArb17 ) (conE conName)+ runMapAndApp 18 = appE (varE 'buildArb18 ) (conE conName)+ runMapAndApp 19 = appE (varE 'buildArb19 ) (conE conName)+ runMapAndApp 20 = appE (varE 'buildArb20 ) (conE conName)++ runMapAndApp _ = error "Arbitrary TypeConstructors only defined for 0 to 20 parameters"++{- attempting to automate it further+applyConExp :: (Name, [StrictType]) -> ExpQ+applyConExp deconstructedConstructor = -- runMapAndApp argCount+ case (argCount >= 0) && (argCount <= 20) of+ True -> do+ mBuildArbn <- lookupValueName buildArb+ case mBuildArbn of+ Nothing -> error "Could not find buildArbn function, TH error"+ Just buildArbn -> appE (varE buildArbn) (conE conName)++ False -> error "Arbitrary TypeConstructors only defined for 0 to 20 parameters"+ where+ conName = fst deconstructedConstructor+ argCount = fromIntegral . length . snd $ deconstructedConstructor :: Int+ buildArb = "buildArb" ++ show argCount+-}++arbReturn :: a -> Gen a+arbReturn = return
+ src/Test/QuickCheck/TH/Generators/Internal/BuildArbitrary.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.QuickCheck.TH.Generators.Internal.BuildArbitrary where++import Language.Haskell.TH++import Safe+++-- | automatically build functions named `buildArbn` where n is an integer+-- greater than 0. $(buildArbAny 3) creates a function buildArb3 which takes+-- a constructor that takes 3 parameters, and returns an arbitrary instances+-- of that constructor. It assumes that the constructors type is an instance+-- of Arbitrary.+--+-- buildArb1 :: Arbitrary a+-- => (a -> b)+-- -> Gen b+-- buildArb1 f = f <$> arbitrary+--+-- buildArb2 :: (Arbitrary a, Arbitrary a1)+-- => (a1 -> a -> b)+-- -> Gen b+-- buildArb2 f = f <$> arbitrary <*> arbitrary++buildArbAny :: Int -> Q [Dec]+buildArbAny l+ | l < 1 = return []+ | otherwise = do+ -- name of the function to be returned+ let buildArbName = mkName ("buildArb" ++ show l)++ -- names of parameters used in the buildArbn function+ arbParameterNames <- mapM newName $ (("a" ++) . show) <$> [0..(l-1)] -- one for each parameter of f+ let mFirstArbParameterName = headMay arbParameterNames+ mRestArbParameterNames = tailMay arbParameterNames+ bName <- newName "b" -- the return type of buildArbn+ fName <- newName "f" -- the sum type constructor++ -- types used in the buildArbn function+ mArbitraryTypeName <- lookupTypeName "Arbitrary"+ mGenTypeName <- lookupTypeName "Gen"++ -- functions used in the buildArbn function+ mFmapName <- lookupValueName "<$>"+ mApName <- lookupValueName "<*>"+ mArbitraryValue <- lookupValueName "arbitrary"++ -- check if all the types and functions were found+ case (,,,,,,) <$> mFirstArbParameterName <*> mRestArbParameterNames <*> mArbitraryTypeName <*> mGenTypeName <*> mFmapName <*> mApName <*> mArbitraryValue of+ Nothing -> return []+ Just (firstArbParameterName,restArbParameterNames,arbitraryTypeName,genTypeName,fmapName,apName,arbitraryValue) -> do+ -- all of the variables in the function to be created, input and output+ let plainTVs = PlainTV <$> (arbParameterNames ++ [bName])+ -- Arbitrary type instance required for all vars in arbParameterNames+ typeClassRequirements = (AppT (ConT arbitraryTypeName) ) <$> (VarT <$> arbParameterNames)+ genB = AppT (ConT genTypeName) (VarT bName)++ -- last parameter and return type+ -- (a -> Gen b)+ aToGenB = (AppT+ (AppT+ ArrowT+ (VarT firstArbParameterName))+ (VarT bName))+ -- fold function+ buildFunctionArgument old new = (AppT+ (AppT+ ArrowT+ (VarT new))+ old)+ -- build the rest of the parameters+ preFunctionArgument = AppT ArrowT $ foldl buildFunctionArgument+ aToGenB+ restArbParameterNames+ -- TH encoding for function arguments+ functionArgument = AppT preFunctionArgument genB++ -- build the function body+ -- f <$> arbitrary+ fFmapArbitrary = (InfixE (Just (VarE fName)) (VarE fmapName) (Just (VarE arbitraryValue)))+ arbRs = replicate (length arbParameterNames - 1) arbitraryValue++ -- build rest of body by folding <*> arbitrary+ preFunctionBody = foldl (\old new -> InfixE (Just old) (VarE apName) (Just (VarE new)))+ fFmapArbitrary+ arbRs++ -- TH encoding for function body+ functionBody = FunD buildArbName [Clause [VarP fName] (NormalB preFunctionBody) []]++ return+ [SigD+ buildArbName+ (ForallT+ plainTVs+ typeClassRequirements+ functionArgument+ )+ , functionBody+ ]
+ test/Spec.hs view
@@ -0,0 +1,5 @@+import Test.QuickCheck.TH.GeneratorsSpec +import Test.Tasty++main :: IO ()+main = defaultMain tests
+ test/Test/QuickCheck/TH/GeneratorsSpec.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.QuickCheck.TH.GeneratorsSpec (tests) where++import Data.List++import Test.QuickCheck.TH.Generators++import Test.Tasty+import Test.Tasty.QuickCheck (Arbitrary)+import qualified Test.Tasty.QuickCheck as QC++++-- | These example types should build arbitrary instances correctly++data ExampleSumTypes = ExampleSum0+ | ExampleSum1 Int+ | ExampleSum2 Int Int+ | ExampleSum3 Int Int Int+ | ExampleSum4 Int Int Int Int+ | ExampleSum5 Int Int Int Int Int+ | ExampleSum6 Int Int Int Int Int Int+ | ExampleSum7 Int Int Int Int Int Int Int+ | ExampleSum8 Int Int Int Int Int Int Int Int+ | ExampleSum9 Int Int Int Int Int Int Int Int Int+ | ExampleSum10 Int Int Int Int Int Int Int Int Int Int++ deriving (Show,Ord,Eq)++data ExampleProductType = ExampleProductType {+ _field0 :: Int+, _field1 :: Int+, _field2 :: Int+, _field3 :: Int+, _field4 :: Int+, _field5 :: Int+, _field6 :: Int+, _field7 :: Int+, _field8 :: Int+, _field9 :: Int+, _field10 :: Int+, _field11 :: Int+, _field12 :: Int+, _field13 :: Int+, _field14 :: Int+, _field15 :: Int+, _field16 :: Int+, _field17 :: Int+, _field18 :: Int+, _field19 :: Int++} deriving (Show,Ord,Eq)++makeArbitrary ''ExampleSumTypes+makeArbitrary ''ExampleProductType++instance Arbitrary ExampleSumTypes where+ arbitrary = arbitraryExampleSumTypes++instance Arbitrary ExampleProductType where+ arbitrary = arbitraryExampleProductType++tests :: TestTree+tests = testGroup "Tests" [properties]++properties :: TestTree+properties = testGroup "Properties" [qcProps]++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)"+ [ QC.testProperty "ExampleSumTypes sort == sort . reverse" (+ \list -> sort (list :: [ExampleSumTypes]) == sort (reverse list)) ,+ QC.testProperty "ExampleProductTypes sort == sort . reverse" (+ \list -> sort (list :: [ExampleProductType]) == sort (reverse list)) ]