less-arbitrary 0.1.7.0 → 0.1.8.0
raw patch · 4 files changed
+187/−133 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- less-arbitrary.cabal +5/−5
- src/Test/LessArbitrary.hs +152/−110
- src/Test/LessArbitrary/Laws.hs +11/−6
- test/less/LessArbitrary.hs +19/−12
less-arbitrary.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack ----- hash: d30ca38bcbe9101a7c179c5cc3776be35b4afb646db121fc65bb6ed099cf261b+-- hash: b0a355788abef7dbaf0d7e5cbcb66a193c430d26e49679c48cccc006d49399fc name: less-arbitrary-version: 0.1.7.0+version: 0.1.8.0 synopsis: Linear time testing with variant of Arbitrary class that always terminates. description: Ever found non-terminating Arbitrary instance? Ever wondered what would be a runtime cost of particular Arbitrary instance?@@ -54,7 +54,7 @@ src build-depends: QuickCheck- , base >=4.5 && <=4.15+ , base >=4.5 && <=4.17 , containers , email-validate , generic-arbitrary@@ -85,7 +85,7 @@ test build-depends: QuickCheck- , base >=4.5 && <=4.15+ , base >=4.5 && <=4.17 , containers , email-validate , generic-arbitrary
src/Test/LessArbitrary.hs view
@@ -1,21 +1,22 @@ -- ~\~ language=Haskell filename=src/Test/LessArbitrary.hs -- ~\~ begin <<less-arbitrary.md|src/Test/LessArbitrary.hs>>[0]-{-# language DefaultSignatures #-}-{-# language FlexibleInstances #-}-{-# language FlexibleContexts #-}+{-# language DefaultSignatures #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-} {-# language GeneralizedNewtypeDeriving #-}-{-# language Rank2Types #-}-{-# language PolyKinds #-}-{-# language MultiParamTypeClasses #-}-{-# language MultiWayIf #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language TypeOperators #-}-{-# language TypeFamilies #-}-{-# language TupleSections #-}-{-# language UndecidableInstances #-}-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}+{-# language InstanceSigs #-}+{-# language Rank2Types #-}+{-# language PolyKinds #-}+{-# language MultiParamTypeClasses #-}+{-# language MultiWayIf #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeOperators #-}+{-# language TypeFamilies #-}+{-# language TupleSections #-}+{-# language UndecidableInstances #-}+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-} module Test.LessArbitrary( LessArbitrary(..) , oneof@@ -34,74 +35,95 @@ , elements , forAll , sizedCost+ , StartingState(..) ) where -import qualified Data.HashMap.Strict as Map-import qualified Data.Set as Set-import qualified Data.Vector as Vector-import qualified Data.Text as Text-import Control.Monad(replicateM)-import Data.Scientific-import Data.Proxy-import qualified Test.QuickCheck.Gen as QC+import qualified Data.HashMap.Strict as Map+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import qualified Data.Text as Text+import Control.Monad (replicateM)+import Data.Scientific+import Data.Proxy+import qualified Test.QuickCheck.Gen as QC import qualified Control.Monad.State.Strict as State-import Control.Monad.Trans.Class-import System.Random(Random)-import GHC.Generics as G-import GHC.Generics as Generic-import GHC.TypeLits-import GHC.Stack+import Control.Arrow (first, second)+import Control.Monad.Trans.Class+import System.Random (Random)+import GHC.Generics as G+import GHC.Generics as Generic+import GHC.TypeLits+import GHC.Stack import qualified Test.QuickCheck as QC-import Data.Hashable+import Data.Hashable import Test.LessArbitrary.Cost +-- ~\~ begin <<less-arbitrary.md|starting-state>>[0]+class StartingState s where+ startingState :: s++instance StartingState () where+ startingState = ()+-- ~\~ end -- ~\~ begin <<less-arbitrary.md|costgen>>[0]-newtype CostGen a =+newtype CostGen s a = CostGen {- runCostGen :: State.StateT Cost QC.Gen a }+ runCostGen :: State.StateT (Cost, s) QC.Gen a+ } deriving (Functor, Applicative, Monad, State.MonadFix)++instance State.MonadState s (CostGen s) where+ state :: forall s a.+ (s -> (a, s)) -> CostGen s a+ state nestedMod = CostGen $ State.state mod+ where+ mod :: (Cost, s) -> (a, (Cost, s))+ mod (aCost, aState) = (result, (aCost, newState))+ where+ (result, newState) = nestedMod aState -- ~\~ end -- Mark a costly constructor with this instead of `<$>`-(<$$$>) :: (a -> b) -> CostGen a -> CostGen b+(<$$$>) :: (a -> b) -> CostGen s a -> CostGen s b costlyConstructor <$$$> arg = do spend 1 costlyConstructor <$> arg -- ~\~ begin <<less-arbitrary.md|spend>>[0]-spend :: Cost -> CostGen ()+spend :: Cost -> CostGen s () spend c = do- CostGen $ State.modify (-c+)+ CostGen $ State.modify (first (-c+)) checkBudget -- ~\~ end -- ~\~ begin <<less-arbitrary.md|budget>>[0] ($$$?) :: HasCallStack- => CostGen a- -> CostGen a- -> CostGen a+ => CostGen s a+ -> CostGen s a+ -> CostGen s a cheapVariants $$$? costlyVariants = do- budget <- CostGen State.get+ budget <- fst <$> CostGen State.get if | budget > (0 :: Cost) -> costlyVariants | budget > -10000 -> cheapVariants | otherwise -> error $ "Recursive structure with no loop breaker." -- ~\~ end -- ~\~ begin <<less-arbitrary.md|budget>>[1]-checkBudget :: HasCallStack => CostGen ()+checkBudget :: HasCallStack => CostGen s () checkBudget = do- budget <- CostGen State.get+ budget <- fst <$> CostGen State.get if budget < -10000 then error "Recursive structure with no loop breaker." else return () -- ~\~ end -- ~\~ begin <<less-arbitrary.md|budget>>[2]-currentBudget :: CostGen Cost-currentBudget = CostGen State.get+currentBudget :: CostGen s Cost+currentBudget = fst <$> CostGen State.get -- ~\~ end -- ~\~ begin <<less-arbitrary.md|budget>>[3] -- unused: loop breaker message type name+-- FIXME: use to make nicer error message type family ShowType k where ShowType (D1 ('MetaData name _ _ _) _) = name ShowType other = "unknown type"@@ -114,10 +136,17 @@ -- ~\~ end -withCost :: Int -> CostGen a -> QC.Gen a-withCost cost gen = runCostGen gen- `State.evalStateT` Cost cost+withCost :: forall s a.+ StartingState s+ => Int+ -> CostGen s a+ -> QC.Gen a+withCost cost gen = withCostAndState cost startingState gen +withCostAndState :: Int -> s -> CostGen s a -> QC.Gen a+withCostAndState cost state gen = runCostGen gen+ `State.evalStateT` (Cost cost, state)+ -- ~\~ begin <<less-arbitrary.md|generic-instances>>[0] type family Min m n where Min m n = ChooseSmaller (CmpNat m n) m n@@ -148,38 +177,38 @@ Cheapness (C1 a other) = 1 -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-instances>>[2]-instance GLessArbitrary f- => GLessArbitrary (G.C1 c f) where+instance GLessArbitrary s f+ => GLessArbitrary s (G.C1 c f) where gLessArbitrary = G.M1 <$> gLessArbitrary cheapest = G.M1 <$> cheapest -instance GLessArbitrary f- => GLessArbitrary (G.S1 c f) where+instance GLessArbitrary s f+ => GLessArbitrary s (G.S1 c f) where gLessArbitrary = G.M1 <$> gLessArbitrary cheapest = G.M1 <$> cheapest -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[0]-genericLessArbitraryMonoid :: (Generic a- ,GLessArbitrary (Rep a)- ,Monoid a )- => CostGen a+genericLessArbitraryMonoid :: (Generic a+ ,GLessArbitrary s (Rep a)+ ,Monoid a )+ => CostGen s a genericLessArbitraryMonoid = pure mempty $$$? genericLessArbitrary -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[1]-class GLessArbitrary datatype where- gLessArbitrary :: CostGen (datatype p)- cheapest :: CostGen (datatype p)+class GLessArbitrary s datatype where+ gLessArbitrary :: CostGen s (datatype p)+ cheapest :: CostGen s (datatype p) -genericLessArbitrary :: (Generic a- ,GLessArbitrary (Rep a))- => CostGen a+genericLessArbitrary :: (Generic a+ ,GLessArbitrary s (Rep a))+ => CostGen s a genericLessArbitrary = G.to <$> gLessArbitrary -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[2]-instance GLessArbitrary f- => GLessArbitrary (D1 m f) where +instance GLessArbitrary s f+ => GLessArbitrary s (D1 m f) where gLessArbitrary = do spend 1 M1 <$> (cheapest $$$? gLessArbitrary)@@ -191,34 +220,34 @@ SumLen a = 1 -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[4]-instance GLessArbitrary G.U1 where+instance GLessArbitrary s G.U1 where gLessArbitrary = pure G.U1 cheapest = pure G.U1 -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[5]-instance (GLessArbitrary a- ,GLessArbitrary b)- => GLessArbitrary (a G.:*: b) where+instance (GLessArbitrary s a+ ,GLessArbitrary s b)+ => GLessArbitrary s (a G.:*: b) where gLessArbitrary = (G.:*:) <$> gLessArbitrary <*> gLessArbitrary cheapest = (G.:*:) <$> cheapest <*> cheapest -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[6]-instance LessArbitrary c- => GLessArbitrary (G.K1 i c) where+instance LessArbitrary s c+ => GLessArbitrary s (G.K1 i c) where gLessArbitrary = G.K1 <$> lessArbitrary cheapest = G.K1 <$> lessArbitrary -- ~\~ end -- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[7]-instance (GLessArbitrary a- ,GLessArbitrary b+instance (GLessArbitrary s a+ ,GLessArbitrary s b ,KnownNat (SumLen a) ,KnownNat (SumLen b) ,KnownNat (Cheapness a) ,KnownNat (Cheapness b) )- => GLessArbitrary (a Generic.:+: b) where+ => GLessArbitrary s (a Generic.:+: b) where gLessArbitrary = frequency [ (lfreq, L1 <$> gLessArbitrary)@@ -241,104 +270,116 @@ -- ~\~ end -- ~\~ begin <<less-arbitrary.md|less-arbitrary-class>>[0]-class LessArbitrary a where- lessArbitrary :: CostGen a+class StartingState s+ => LessArbitrary s a where+ lessArbitrary :: CostGen s a -- ~\~ end -- ~\~ begin <<less-arbitrary.md|less-arbitrary-class>>[1]- default lessArbitrary :: (Generic a- ,GLessArbitrary (Rep a))- => CostGen a+ default lessArbitrary :: (Generic a+ ,GLessArbitrary s (Rep a))+ => CostGen s a lessArbitrary = genericLessArbitrary -- ~\~ end -instance LessArbitrary Bool where+instance StartingState s+ => LessArbitrary s Bool where lessArbitrary = flatLessArbitrary -instance LessArbitrary Int where+instance StartingState s+ => LessArbitrary s Int where lessArbitrary = flatLessArbitrary -instance LessArbitrary Integer where+instance StartingState s+ => LessArbitrary s Integer where lessArbitrary = flatLessArbitrary -instance LessArbitrary Double where+instance StartingState s+ => LessArbitrary s Double where lessArbitrary = flatLessArbitrary -instance LessArbitrary Char where+instance StartingState s+ => LessArbitrary s Char where lessArbitrary = flatLessArbitrary -instance (LessArbitrary k- ,LessArbitrary v)- => LessArbitrary (k,v) where+instance (LessArbitrary s k+ ,LessArbitrary s v)+ => LessArbitrary s (k,v) where -instance (LessArbitrary k- ,Ord k)- => LessArbitrary (Set.Set k) where+instance (LessArbitrary s k+ ,Ord k)+ => LessArbitrary s (Set.Set k) where lessArbitrary = Set.fromList <$> lessArbitrary -instance (LessArbitrary k- ,Eq k- ,Ord k- ,Hashable k - ,LessArbitrary v)- => LessArbitrary (Map.HashMap k v) where+instance (LessArbitrary s k+ ,Eq k+ ,Ord k+ ,Hashable k + ,LessArbitrary s v)+ => LessArbitrary s (Map.HashMap k v) where lessArbitrary = Map.fromList <$> lessArbitrary -instance LessArbitrary Scientific where+instance StartingState s+ => LessArbitrary s Scientific where lessArbitrary = scientific <$> lessArbitrary <*> lessArbitrary -- ~\~ begin <<less-arbitrary.md|arbitrary-implementation>>[0]-fasterArbitrary :: LessArbitrary a => QC.Gen a-fasterArbitrary = sizedCost lessArbitrary+fasterArbitrary :: forall s a.+ LessArbitrary s a+ => QC.Gen a+fasterArbitrary = (sizedCost :: CostGen s a -> QC.Gen a) (lessArbitrary :: CostGen s a) -sizedCost :: CostGen a -> QC.Gen a+sizedCost :: LessArbitrary s a+ => CostGen s a+ -> QC.Gen a sizedCost gen = QC.sized (`withCost` gen) -- ~\~ end flatLessArbitrary :: QC.Arbitrary a- => CostGen a+ => CostGen s a flatLessArbitrary = CostGen $ lift QC.arbitrary -instance LessArbitrary a- => LessArbitrary (Vector.Vector a) where+instance LessArbitrary s a+ => LessArbitrary s (Vector.Vector a) where lessArbitrary = Vector.fromList <$> lessArbitrary -- ~\~ begin <<less-arbitrary.md|lifting-arbitrary>>[0]-instance LessArbitrary a- => LessArbitrary [a] where+instance LessArbitrary s a+ => LessArbitrary s [a] where lessArbitrary = pure [] $$$? do budget <- currentBudget len <- choose (1,fromEnum budget) spend $ Cost len replicateM len lessArbitrary -instance QC.Testable a- => QC.Testable (CostGen a) where+instance (QC.Testable a+ ,LessArbitrary s a)+ => QC.Testable (CostGen s a) where property = QC.property . sizedCost -- ~\~ end -- ~\~ begin <<less-arbitrary.md|lifting-arbitrary>>[1]-forAll :: CostGen a -> (a -> CostGen b) -> CostGen b+forAll :: CostGen s a -> (a -> CostGen s b) -> CostGen s b forAll gen prop = gen >>= prop oneof :: HasCallStack- => [CostGen a] -> CostGen a+ => [CostGen s a] -> CostGen s a oneof [] = error "LessArbitrary.oneof used with empty list" oneof gs = choose (0,length gs - 1) >>= (gs !!) -elements :: [a] -> CostGen a+elements :: [a] -> CostGen s a elements gs = (gs!!) <$> choose (0,length gs - 1) choose :: Random a => (a, a)- -> CostGen a+ -> CostGen s a choose (a,b) = CostGen $ lift $ QC.choose (a, b) -- | Choose but only up to the budget (for array and list sizes)-budgetChoose :: CostGen Int+budgetChoose :: CostGen s Int budgetChoose = do Cost b <- currentBudget CostGen $ lift $ QC.choose (1, b)@@ -354,7 +395,8 @@ -- ~\~ end -- ~\~ begin <<less-arbitrary.md|lifting-arbitrary>>[2] frequency :: HasCallStack- => [(Int, CostGen a)] -> CostGen a+ => [(Int, CostGen s a)]+ -> CostGen s a frequency [] = error $ "LessArbitrary.frequency " ++ "used with empty list"
src/Test/LessArbitrary/Laws.hs view
@@ -5,6 +5,7 @@ {-# language Rank2Types #-} {-# language MultiParamTypeClasses #-} {-# language ScopedTypeVariables #-}+{-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# language AllowAmbiguousTypes #-}@@ -20,17 +21,21 @@ import Data.HashMap.Strict(HashMap) -- ~\~ begin <<less-arbitrary.md|less-arbitrary-laws>>[0]-lessArbitraryLaws :: LessArbitrary a- => (a -> Bool) -> Laws+lessArbitraryLaws :: forall s a.+ LessArbitrary s a+ => (a -> Bool)+ -> Laws lessArbitraryLaws cheapestPred = Laws "LessArbitrary" [("always selects cheapest", property $- prop_alwaysCheapest cheapestPred)]+ (prop_alwaysCheapest @s @a) cheapestPred)] -prop_alwaysCheapest :: LessArbitrary a- => (a -> Bool) -> Gen Bool+prop_alwaysCheapest :: forall s a.+ LessArbitrary s a+ => (a -> Bool)+ -> Gen Bool prop_alwaysCheapest cheapestPred =- cheapestPred <$> withCost 0 lessArbitrary+ cheapestPred <$> (withCost @s @a) 0 lessArbitrary -- ~\~ end -- ~\~ end
test/less/LessArbitrary.hs view
@@ -2,23 +2,26 @@ -- ~\~ begin <<less-arbitrary.md|test/less/LessArbitrary.hs>>[0] -- ~\~ begin <<less-arbitrary.md|test-file-header>>[0] {-# language FlexibleInstances #-}+{-# language InstanceSigs #-} {-# language Rank2Types #-} {-# language MultiParamTypeClasses #-} {-# language ScopedTypeVariables #-}+{-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# language AllowAmbiguousTypes #-} {-# language DeriveGeneric #-} module Main where -import Data.Proxy-import Test.QuickCheck+import Data.Proxy+import Test.QuickCheck+import qualified Test.QuickCheck.Gen as QC import qualified GHC.Generics as Generic-import Test.QuickCheck.Classes+import Test.QuickCheck.Classes -import Test.LessArbitrary-import Test.Arbitrary.Laws-import Test.LessArbitrary.Laws+import Test.LessArbitrary+import Test.Arbitrary.Laws+import Test.LessArbitrary.Laws -- ~\~ begin <<less-arbitrary.md|tree-type>>[0] data Tree a =@@ -28,12 +31,16 @@ -- ~\~ end -- ~\~ end -- ~\~ begin <<less-arbitrary.md|test-less-arbitrary-version>>[0]-instance LessArbitrary a- => LessArbitrary (Tree a) where+instance (Arbitrary a+ ,LessArbitrary s a)+ => LessArbitrary s (Tree a) where+ lessArbitrary = genericLessArbitrary -instance LessArbitrary a- => Arbitrary (Tree a) where- arbitrary = fasterArbitrary+instance (LessArbitrary () (Tree a)+ ,Arbitrary a)+ => Arbitrary (Tree a) where+ arbitrary = fasterArbitrary @() @(Tree a)+ shrink = recursivelyShrink -- ~\~ end -- ~\~ begin <<less-arbitrary.md|test-file-laws>>[0]@@ -48,7 +55,7 @@ -- ~\~ end -- ~\~ begin <<less-arbitrary.md|less-arbitrary-check>>[0] otherLaws :: [Laws]-otherLaws = [lessArbitraryLaws isLeaf]+otherLaws = [lessArbitraryLaws @() isLeaf] where isLeaf :: Tree Int -> Bool isLeaf (Leaf _) = True