less-arbitrary (empty) → 0.1.0.0
raw patch · 8 files changed
+610/−0 lines, 8 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, email-validate, generic-arbitrary, genvalidity, genvalidity-hspec, genvalidity-property, hashable, hspec, less-arbitrary, mtl, quickcheck-classes, quickcheck-instances, random, scientific, text, time, transformers, unordered-containers, validity, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +32/−0
- README.md +10/−0
- Setup.hs +2/−0
- less-arbitrary.cabal +101/−0
- src/Test/LessArbitrary.hs +350/−0
- test/Test/Arbitrary.hs +41/−0
- test/less/LessArbitrary.hs +69/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for less-arbitrary++0.1.0.0 -- 20200-10-17++* First version of less-arbitrary on Hackage.
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2020, Michal J. Gajda++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 Michal J. Gajda 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.++Note: this license does not apply to Spring and ACM template files
+ README.md view
@@ -0,0 +1,10 @@+To build this you need:+* pandoc+* xelatex with standard science article packages+ - easiest to get as MacTeX on Mac+ - `apt-get install -y texlive-recommended` on Ubuntu+* markdown-unlit+* pandoc-hide-codeblocks+* enTangleD for code generation (if you want to edit `.md` source file)++To read more, look into `less-arbitrary.md` which is literate source file.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ less-arbitrary.cabal view
@@ -0,0 +1,101 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: c900031eb7b423dc49cd1e66dd3e62ca0955e19cca79a555beda12a781ba8615++name: less-arbitrary+version: 0.1.0.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?+ .+ Never let it bother you again:+ this variant of Arbitrary is automatically generating instances, and allows you to see predictable linear time generators+ for most types (providing that you have any terminating constructor, that is constructor that does not go deeper into the data structure.)+ .+ Usage: + ```+ import Test.LessArbitrary+ .+ data MyDataType = ...+ deriving (Show, Generic)+ .+ instance LessArbitrary MyDataType+ instance Arbitrary where+ arbitrary = lessArbitrary+ ```+category: Web+author: Michał J. Gajda <mjgajda@migamake.com>+maintainer: Michał J. Gajda <mjgajda@migamake.com>+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ CHANGELOG.md+ README.md++library+ exposed-modules:+ Test.LessArbitrary+ other-modules:+ Paths_less_arbitrary+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , base >=4.5 && <=4.15+ , containers+ , email-validate+ , generic-arbitrary+ , genvalidity+ , genvalidity-hspec+ , genvalidity-property+ , hashable+ , hspec+ , mtl+ , random+ , scientific+ , text+ , time+ , transformers+ , unordered-containers+ , validity+ , vector+ default-language: Haskell2010++test-suite less-arbitrary+ type: exitcode-stdio-1.0+ main-is: LessArbitrary.hs+ other-modules:+ Test.Arbitrary+ Paths_less_arbitrary+ hs-source-dirs:+ test/less/+ test+ build-depends:+ QuickCheck+ , base >=4.5 && <=4.15+ , containers+ , email-validate+ , generic-arbitrary+ , genvalidity+ , genvalidity-hspec+ , genvalidity-property+ , hashable+ , hspec+ , less-arbitrary+ , mtl+ , quickcheck-classes+ , quickcheck-instances+ , random+ , scientific+ , text+ , time+ , transformers+ , unordered-containers+ , validity+ , vector+ default-language: Haskell2010
+ src/Test/LessArbitrary.hs view
@@ -0,0 +1,350 @@+-- ~\~ language=Haskell filename=src/Test/LessArbitrary.hs+-- ~\~ begin <<less-arbitrary.md|src/Test/LessArbitrary.hs>>[0]+{-# 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 UndecidableInstances #-}+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+module Test.LessArbitrary(+ LessArbitrary(..)+ , oneof+ , choose+ , CostGen(..)+ , (<$$$>)+ , ($$$?)+ , currentBudget+ , fasterArbitrary+ , genericLessArbitrary+ , genericLessArbitraryMonoid+ , flatLessArbitrary+ , spend+ , withCost+ , elements+ , forAll+ , sizedCost+ ) 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 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 qualified Test.QuickCheck as QC+import Data.Hashable++-- ~\~ begin <<less-arbitrary.md|costgen>>[0]+newtype Cost = Cost Int + deriving (Eq,Ord,Enum,Bounded,Num)++newtype CostGen a =+ CostGen {+ runCostGen :: State.StateT Cost QC.Gen a }+ deriving (Functor, Applicative, Monad, State.MonadFix)+-- ~\~ end++-- Mark a costly constructor with this instead of `<$>`+(<$$$>) :: (a -> b) -> CostGen a -> CostGen b+costlyConstructor <$$$> arg = do+ spend 1+ costlyConstructor <$> arg++-- ~\~ begin <<less-arbitrary.md|spend>>[0]+spend :: Cost -> CostGen ()+spend c = CostGen $ State.modify (-c+)+-- ~\~ end++-- ~\~ begin <<less-arbitrary.md|budget>>[0]+($$$?) :: CostGen a+ -> CostGen a+ -> CostGen a+cheapVariants $$$? costlyVariants = do+ budget <- 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]+currentBudget :: CostGen Cost+currentBudget = CostGen State.get+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|budget>>[2]+-- unused: loop breaker message type name+type family ShowType k where+ ShowType (D1 ('MetaData name _ _ _) _) = name+ ShowType other = "unknown type"++showType :: forall a.+ (Generic a+ ,KnownSymbol (ShowType (Rep a)))+ => String+showType = symbolVal (Proxy :: Proxy (ShowType (Rep a)))+-- ~\~ end+++withCost :: Int -> CostGen a -> QC.Gen a+withCost cost gen = runCostGen gen+ `State.evalStateT` Cost cost++-- ~\~ begin <<less-arbitrary.md|generic-instances>>[0]+type family Min m n where+ Min m n = ChooseSmaller (CmpNat m n) m n++type family ChooseSmaller (o::Ordering)+ (m::Nat)+ (n::Nat) where + ChooseSmaller 'LT m n = m+ ChooseSmaller 'EQ m n = m+ ChooseSmaller 'GT m n = n+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-instances>>[1]+type family Cheapness a :: Nat where+ Cheapness (a :*: b) =+ Cheapness a + Cheapness b+ Cheapness (a :+: b) =+ Min (Cheapness a) (Cheapness b)+ Cheapness U1 = 0+ -- ~\~ begin <<less-arbitrary.md|flat-types>>[0]+ Cheapness (S1 a (Rec0 Int )) = 0+ Cheapness (S1 a (Rec0 Scientific)) = 0+ Cheapness (S1 a (Rec0 Double )) = 0+ Cheapness (S1 a (Rec0 Bool )) = 0+ Cheapness (S1 a (Rec0 Text.Text )) = 1+ Cheapness (S1 a (Rec0 other )) = 1+ -- ~\~ end+ Cheapness (K1 a other) = 1+ Cheapness (C1 a other) = 1+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-instances>>[2]+instance GLessArbitrary f+ => GLessArbitrary (G.C1 c f) where+ gLessArbitrary = G.M1 <$> gLessArbitrary+ cheapest = G.M1 <$> cheapest++instance GLessArbitrary f+ => GLessArbitrary (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 =+ pure mempty $$$? genericLessArbitrary+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[1]+class GLessArbitrary datatype where+ gLessArbitrary :: CostGen (datatype p)+ cheapest :: CostGen (datatype p)++genericLessArbitrary :: (Generic a+ ,GLessArbitrary (Rep a))+ => CostGen a+genericLessArbitrary = G.to <$> gLessArbitrary+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[2]+instance GLessArbitrary f+ => GLessArbitrary (D1 m f) where + gLessArbitrary = do+ spend 1+ M1 <$> (cheapest $$$? gLessArbitrary)+ cheapest = M1 <$> cheapest+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[3]+type family SumLen a :: Nat where+ SumLen (a G.:+: b) = SumLen a + SumLen b+ SumLen a = 1+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[4]+instance GLessArbitrary 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+ 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+ gLessArbitrary = G.K1 <$> lessArbitrary+ cheapest = G.K1 <$> lessArbitrary+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|generic-less-arbitrary>>[7]+instance (GLessArbitrary a+ ,GLessArbitrary b+ ,KnownNat (SumLen a)+ ,KnownNat (SumLen b)+ ,KnownNat (Cheapness a)+ ,KnownNat (Cheapness b)+ )+ => GLessArbitrary (a Generic.:+: b) where+ gLessArbitrary =+ frequency+ [ (lfreq, L1 <$> gLessArbitrary)+ , (rfreq, R1 <$> gLessArbitrary) ]+ where+ lfreq = fromIntegral+ $ natVal (Proxy :: Proxy (SumLen a))+ rfreq = fromIntegral+ $ natVal (Proxy :: Proxy (SumLen b))+ cheapest =+ if lcheap <= rcheap+ then L1 <$> cheapest+ else R1 <$> cheapest+ where+ lcheap, rcheap :: Int+ lcheap = fromIntegral+ $ natVal (Proxy :: Proxy (Cheapness a))+ rcheap = fromIntegral+ $ natVal (Proxy :: Proxy (Cheapness b))+-- ~\~ end++-- ~\~ begin <<less-arbitrary.md|less-arbitrary-class>>[0]+class LessArbitrary a where+ lessArbitrary :: CostGen a+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|less-arbitrary-class>>[1]+ default lessArbitrary :: (Generic a+ ,GLessArbitrary (Rep a))+ => CostGen a+ lessArbitrary = genericLessArbitrary+-- ~\~ end++instance LessArbitrary Bool where+ lessArbitrary = flatLessArbitrary++instance LessArbitrary Int where+ lessArbitrary = flatLessArbitrary++instance LessArbitrary Integer where+ lessArbitrary = flatLessArbitrary++instance LessArbitrary Double where+ lessArbitrary = flatLessArbitrary++instance LessArbitrary Char where+ lessArbitrary = flatLessArbitrary++instance (LessArbitrary k+ ,LessArbitrary v)+ => LessArbitrary (k,v) where++instance (LessArbitrary k+ ,Ord k)+ => LessArbitrary (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+ lessArbitrary = Map.fromList+ <$> lessArbitrary++instance LessArbitrary Scientific where+ lessArbitrary =+ scientific <$> lessArbitrary+ <*> lessArbitrary++-- ~\~ begin <<less-arbitrary.md|arbitrary-implementation>>[0]+fasterArbitrary :: LessArbitrary a => QC.Gen a+fasterArbitrary = sizedCost lessArbitrary++sizedCost :: CostGen a -> QC.Gen a+sizedCost gen = QC.sized (`withCost` gen)+-- ~\~ end++flatLessArbitrary :: QC.Arbitrary a+ => CostGen a+flatLessArbitrary = CostGen $ lift QC.arbitrary++instance LessArbitrary a+ => LessArbitrary (Vector.Vector a) where+ lessArbitrary = Vector.fromList <$> lessArbitrary++-- ~\~ begin <<less-arbitrary.md|lifting-arbitrary>>[0]+instance LessArbitrary a+ => LessArbitrary [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+ property = QC.property+ . sizedCost+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|lifting-arbitrary>>[1]+forAll :: CostGen a -> (a -> CostGen b) -> CostGen b+forAll gen prop = gen >>= prop++oneof :: [CostGen a] -> CostGen a+oneof [] = error+ "LessArbitrary.oneof used with empty list"+oneof gs = choose (0,length gs - 1) >>= (gs !!)++elements :: [a] -> CostGen a+elements gs = (gs!!) <$> choose (0,length gs - 1)++choose :: Random a+ => (a, a)+ -> CostGen a+choose (a,b) = CostGen $ lift $ QC.choose (a, b)+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|lifting-arbitrary>>[2]+frequency :: [(Int, CostGen a)] -> CostGen a+frequency [] =+ error $ "LessArbitrary.frequency "+ ++ "used with empty list"+frequency xs+ | any (< 0) (map fst xs) =+ error $ "LessArbitrary.frequency: "+ ++ "negative weight"+ | all (== 0) (map fst xs) =+ error $ "LessArbitrary.frequency: "+ ++ "all weights were zero"+frequency xs0 = choose (1, tot) >>= (`pick` xs0)+ where+ tot = sum (map fst xs0)++ pick n ((k,x):xs)+ | n <= k = x+ | otherwise = pick (n-k) xs+ pick _ _ = error+ "LessArbitrary.pick used with empty list"+-- ~\~ end++-- ~\~ end
+ test/Test/Arbitrary.hs view
@@ -0,0 +1,41 @@+-- ~\~ language=Haskell filename=test/Test/Arbitrary.hs+-- ~\~ begin <<less-arbitrary.md|test/Test/Arbitrary.hs>>[0]+{-# language DataKinds #-}+{-# language FlexibleInstances #-}+{-# language Rank2Types #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}+{-# language AllowAmbiguousTypes #-}+module Test.Arbitrary(+ arbitraryLaws+ ) where++import Data.Proxy+import Test.QuickCheck+import Test.QuickCheck.Classes+import qualified Data.HashMap.Strict as Map+import Data.HashMap.Strict(HashMap)++-- ~\~ begin <<less-arbitrary.md|arbitrary-laws>>[0]+shrinkCheck :: forall term.+ (Arbitrary term+ ,Eq term)+ => term+ -> Bool+shrinkCheck term =+ term `notElem` shrink term++arbitraryLaws :: forall ty.+ (Arbitrary ty+ ,Show ty+ ,Eq ty)+ => Proxy ty+ -> Laws+arbitraryLaws (Proxy :: Proxy ty) =+ Laws "arbitrary"+ [("does not shrink to itself",+ property (shrinkCheck :: ty -> Bool))]+-- ~\~ end+-- ~\~ end
+ test/less/LessArbitrary.hs view
@@ -0,0 +1,69 @@+-- ~\~ language=Haskell filename=test/less/LessArbitrary.hs+-- ~\~ begin <<less-arbitrary.md|test/less/LessArbitrary.hs>>[0]+-- ~\~ begin <<less-arbitrary.md|test-file-header>>[0]+{-# language FlexibleInstances #-}+{-# language Rank2Types #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}+{-# language AllowAmbiguousTypes #-}+{-# language DeriveGeneric #-}+module Main where++import Data.Proxy+import Test.QuickCheck+import qualified GHC.Generics as Generic+import Test.QuickCheck.Classes++import Test.LessArbitrary+import Test.Arbitrary++-- ~\~ begin <<less-arbitrary.md|tree-type>>[0]+data Tree a =+ Leaf a+ | Branch [Tree a]+ deriving (Eq,Show,Generic.Generic)+-- ~\~ end+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|test-less-arbitrary-version>>[0]+instance LessArbitrary a+ => LessArbitrary (Tree a) where++instance LessArbitrary a+ => Arbitrary (Tree a) where+ arbitrary = fasterArbitrary+-- ~\~ end++-- ~\~ begin <<less-arbitrary.md|test-file-laws>>[0]++main :: IO ()+main = do+ lawsCheckMany+ [("Tree",+ [arbitraryLaws (Proxy :: Proxy (Tree Int))+ ,eqLaws (Proxy :: Proxy (Tree Int))+ ] <> otherLaws)]+-- ~\~ end+-- ~\~ begin <<less-arbitrary.md|less-arbitrary-check>>[0]+otherLaws :: [Laws]+otherLaws = [lessArbitraryLaws isLeaf]+ where+ isLeaf :: Tree Int -> Bool+ isLeaf (Leaf _) = True+ isLeaf (Branch _) = False++lessArbitraryLaws :: LessArbitrary a+ => (a -> Bool) -> Laws+lessArbitraryLaws cheapestPred =+ Laws "LessArbitrary"+ [("always selects cheapest",+ property $+ prop_alwaysCheapest cheapestPred)]++prop_alwaysCheapest :: LessArbitrary a+ => (a -> Bool) -> Gen Bool+prop_alwaysCheapest cheapestPred =+ cheapestPred <$> withCost 0 lessArbitrary+-- ~\~ end+-- ~\~ end