diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for less-arbitrary + +0.1.0.0 -- 20200-10-17 + +* First version of less-arbitrary on Hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/less-arbitrary.cabal b/less-arbitrary.cabal new file mode 100644 --- /dev/null +++ b/less-arbitrary.cabal @@ -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 +maintainer: Michał J. Gajda +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 diff --git a/src/Test/LessArbitrary.hs b/src/Test/LessArbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Test/LessArbitrary.hs @@ -0,0 +1,350 @@ +-- ~\~ language=Haskell filename=src/Test/LessArbitrary.hs +-- ~\~ begin <>[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 <>[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 <>[0] +spend :: Cost -> CostGen () +spend c = CostGen $ State.modify (-c+) +-- ~\~ end + +-- ~\~ begin <>[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 <>[1] +currentBudget :: CostGen Cost +currentBudget = CostGen State.get +-- ~\~ end +-- ~\~ begin <>[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 <>[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 <>[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 <>[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 <>[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 <>[0] +genericLessArbitraryMonoid :: (Generic a + ,GLessArbitrary (Rep a) + ,Monoid a ) + => CostGen a +genericLessArbitraryMonoid = + pure mempty $$$? genericLessArbitrary +-- ~\~ end +-- ~\~ begin <>[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 <>[2] +instance GLessArbitrary f + => GLessArbitrary (D1 m f) where + gLessArbitrary = do + spend 1 + M1 <$> (cheapest $$$? gLessArbitrary) + cheapest = M1 <$> cheapest +-- ~\~ end +-- ~\~ begin <>[3] +type family SumLen a :: Nat where + SumLen (a G.:+: b) = SumLen a + SumLen b + SumLen a = 1 +-- ~\~ end +-- ~\~ begin <>[4] +instance GLessArbitrary G.U1 where + gLessArbitrary = pure G.U1 + cheapest = pure G.U1 +-- ~\~ end +-- ~\~ begin <>[5] +instance (GLessArbitrary a + ,GLessArbitrary b) + => GLessArbitrary (a G.:*: b) where + gLessArbitrary = (G.:*:) <$> gLessArbitrary + <*> gLessArbitrary + cheapest = (G.:*:) <$> cheapest + <*> cheapest +-- ~\~ end +-- ~\~ begin <>[6] +instance LessArbitrary c + => GLessArbitrary (G.K1 i c) where + gLessArbitrary = G.K1 <$> lessArbitrary + cheapest = G.K1 <$> lessArbitrary +-- ~\~ end +-- ~\~ begin <>[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 <>[0] +class LessArbitrary a where + lessArbitrary :: CostGen a +-- ~\~ end +-- ~\~ begin <>[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 <>[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 <>[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 <>[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 <>[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 diff --git a/test/Test/Arbitrary.hs b/test/Test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Arbitrary.hs @@ -0,0 +1,41 @@ +-- ~\~ language=Haskell filename=test/Test/Arbitrary.hs +-- ~\~ begin <>[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 <>[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 diff --git a/test/less/LessArbitrary.hs b/test/less/LessArbitrary.hs new file mode 100644 --- /dev/null +++ b/test/less/LessArbitrary.hs @@ -0,0 +1,69 @@ +-- ~\~ language=Haskell filename=test/less/LessArbitrary.hs +-- ~\~ begin <>[0] +-- ~\~ begin <>[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 <>[0] +data Tree a = + Leaf a + | Branch [Tree a] + deriving (Eq,Show,Generic.Generic) +-- ~\~ end +-- ~\~ end +-- ~\~ begin <>[0] +instance LessArbitrary a + => LessArbitrary (Tree a) where + +instance LessArbitrary a + => Arbitrary (Tree a) where + arbitrary = fasterArbitrary +-- ~\~ end + +-- ~\~ begin <>[0] + +main :: IO () +main = do + lawsCheckMany + [("Tree", + [arbitraryLaws (Proxy :: Proxy (Tree Int)) + ,eqLaws (Proxy :: Proxy (Tree Int)) + ] <> otherLaws)] +-- ~\~ end +-- ~\~ begin <>[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