diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +* 1.1.1.0 (17 May 2022) + + - Test with GHC 8.6 through 9.2 + - Update maintainer and source repository information diff --git a/Test/Feat/Access.hs b/Test/Feat/Access.hs --- a/Test/Feat/Access.hs +++ b/Test/Feat/Access.hs @@ -27,7 +27,6 @@ --import Data.Modifiers -- base -import Data.List import Data.Ratio((%)) @@ -90,11 +89,11 @@ uni :: [Finite a] -> Int -> Gen a uni [] _ = error "uniform: empty enumeration" uni ps maxp = let (incl, rest) = splitAt maxp ps - fin = mconcat incl - in case fCard fin of + f = mconcat incl + in case fCard f of 0 -> uni rest 1 - _ -> do i <- choose (0,fCard fin-1) - return (fIndex fin i) + _ -> do i <- choose (0,fCard f - 1) + return (fIndex f i) -- | Enumerates every nth value of the enumeration from a given starting index. @@ -105,14 +104,14 @@ skipping :: Enumerate a -> Index -> Integer -> Enumerate a skipping _ o0 step | step <= 0 || o0 < 0 = error "skippingWith: invalid argument" skipping e o0 step = fromParts $ go o0 (parts e) where - go o [] = [] + go _ [] = [] go o _ | o < 0 = error "negative" go o (p:ps) = p' : go o' ps where -- error (show (space,take,o')) : space = fCard p - o - (take,o') | space <= 0 = (0,o-fCard p) + (nTake,o') | space <= 0 = (0,o-fCard p) | space < step = (1,step-space) | otherwise = (space `quotRem` step) - p' = Finite{fCard = take + p' = Finite{fCard = nTake , fIndex = \i -> fIndex p (i*step + o)} -- | A version of values with a limited number of values in each inner list. @@ -124,7 +123,7 @@ -- This is "fair" if we consider using samplePart on the next part as well. -- An alternative would be to make the last index used |crd-1|. samplePart :: Index -> Finite a -> Finite a - samplePart m f@(Finite crd ix) = + samplePart m f@(Finite crd _) = let step = crd % m in if crd <= m then f diff --git a/Test/Feat/Class.hs b/Test/Feat/Class.hs --- a/Test/Feat/Class.hs +++ b/Test/Feat/Class.hs @@ -13,11 +13,11 @@ -- compatability {-# DEPRECATED nullary "use c0 instead" #-} --- nullary :: x -> Memoizable f x +nullary :: Sized f => a -> Shareable f a nullary x = c0 x {-# DEPRECATED unary "use c1 instead" #-} --- unary :: (Enumerable a, MemoSized f) => (a -> x) -> f x +unary :: (Sized f, Enumerable a, Typeable f) => (a -> x) -> Shareable f x unary x = c1 x {-# DEPRECATED shared "use access instead" #-} @@ -25,8 +25,9 @@ shared = access +funcurry :: (a -> b -> c) -> (a,b) -> c funcurry = uncurry {-# DEPRECATED consts "use datatype instead" #-} ---consts :: (Typeable a, MemoSized f) => [f a] -> Closed (f a) +consts :: (Sized f, Typeable f, Typeable a) => [Shareable f a] -> Shared f a consts xs = datatype xs diff --git a/Test/Feat/Driver.hs b/Test/Feat/Driver.hs --- a/Test/Feat/Driver.hs +++ b/Test/Feat/Driver.hs @@ -1,7 +1,7 @@ -- | A simple testing driver for testing properties using FEAT. --- Contains three drivers with different levels of flexibility of configuration. +-- Contains three drivers with different levels of flexibility of configuration. -- --- Ironically, this code is mostly untested at the moment. +-- Ironically, this code is mostly untested at the moment. module Test.Feat.Driver( -- * Simple test driver test @@ -12,7 +12,7 @@ -- * Extremely flexible test driver , testFlex , Result(..) - , FlexibleOptions(..) + , FlexibleOptions , FlexOptions(..) , defFlex , toFlex @@ -38,11 +38,11 @@ } deriving (Show,Read) -- | Much more flexible options for configuring every part of the test execution. --- @a@ is the parameter type of the property. +-- @a@ is the parameter type of the property. type FlexibleOptions a = IO (FlexOptions a) -- | FlexOptions -data FlexOptions a = FlexOptions +data FlexOptions a = FlexOptions { fIO :: IO Bool -> IO (Result,[a]) -- ^ The whole execution of the test is sent through this function. , fReport :: a -> IO Bool -- ^ Applied to each found counterexample, return False to stop testing , fOutput :: String -> IO () -- ^ Print text @@ -53,7 +53,7 @@ data Result = Exhausted -- ^ Reached max size | Quota -- ^ Reached max number of counterexamples | TimedOut - | Other + | Other deriving Show -- | 60 seconds timeout, maximum size of 100, bound of 100000 tests per size @@ -90,11 +90,11 @@ return (n < mx) doIO io = do mb <- maybe (fmap Just io) (\t -> timeout (t*1000000) io) (oTimeoutSec o) - res <- readIORef res - return $ maybe (TimedOut,res) (\b -> if b then (Exhausted,res) else (Quota,res)) mb - skip = maybe id (\(i,n) e -> skipping e i n) (oSkipping o) - bound = maybe id (\n e -> bounded e n) (oBounded o) - sizes = maybe id (\bs e -> sizeRange e bs) (oSizeFromTo o) + res' <- readIORef res + return $ maybe (TimedOut,res') (\b -> if b then (Exhausted,res') else (Quota,res')) mb + skip = maybe id (flip (uncurry . skipping)) (oSkipping o) + bound = maybe id (flip bounded) (oBounded o) + sizes = maybe id (flip sizeRange) (oSizeFromTo o) return $ FlexOptions { fIO = doIO , fOutput = if oSilent o then const (return ()) else putStr @@ -110,7 +110,7 @@ -- | Test with basic options. Returns a list of counterexamples. testOptions :: Enumerable a => Options -> (a -> Bool) -> IO [a] testOptions o p = fmap snd $ testFlex fo p - where + where fo = toFlex o -- | The most flexible test driver, can be configured to behave in almost any way. @@ -119,11 +119,11 @@ op <- ioOp let e = fProcess op (fEnum op) lazyResult = [(n,filter (not . p) xs) | (n,xs) <- valuesWith e] - runSize k (n,cs) = do + runSize k (n,cs) = do fOutput op $ "*** Searching in " ++ show n ++ " values of size " ++ show k ++ "\n" - doWhile (map (\x -> fOutput op "Counterexample found!\n" >> fReport op x) cs) - rxs@(r,_) <- fIO op ((doWhile $ zipWith runSize [0..] lazyResult)) - case r of + doWhile (map (\x -> fOutput op "Counterexample found!\n" >> fReport op x) cs) + rxs@(r,_) <- fIO op ((doWhile $ zipWith runSize [0 :: Integer ..] lazyResult)) + case r of Exhausted -> fOutput op "Search space exhausted\n" TimedOut -> fOutput op "Timed out\n" _ -> return () @@ -133,4 +133,3 @@ doWhile :: [IO Bool] -> IO Bool doWhile [] = return True doWhile (iob:iobs) = iob >>= \b -> if b then doWhile iobs else return False - diff --git a/Test/Feat/Enumerate.hs b/Test/Feat/Enumerate.hs --- a/Test/Feat/Enumerate.hs +++ b/Test/Feat/Enumerate.hs @@ -42,10 +42,8 @@ import Data.List(transpose) import Test.Feat.Finite -type Part = Int - -- | A functional enumeration of type @t@ is a partition of --- @t@ into finite numbered sets called Parts. Each parts contains values +-- @t@ into finite numbered sets. Each part contains values -- of a certain cost (typically the size of the value). data Enumerate a = Enumerate { revParts :: RevList (Finite a) @@ -82,7 +80,6 @@ -- | The @'mappend'@ is (disjoint) @'union'@ instance Monoid (Enumerate a) where mempty = empty - mappend = union mconcat = econcat -- | Optimal 'mconcat' on enumerations. @@ -95,6 +92,7 @@ -- Product of two enumerations +cartesian :: Enumerate a -> Enumerate b -> Enumerate (a,b) cartesian (Enumerate xs1) (Enumerate xs2) = Enumerate (xs1 `prod` xs2) prod :: RevList (Finite a) -> RevList (Finite b) -> RevList (Finite (a,b)) @@ -103,7 +101,7 @@ -- We need to thread carefully here, making sure that guarded recursion is safe prod' [] = [] - prod' (ry:rys) = go ry rys where + prod' (h:t) = go h t where go ry rys = conv xs0 ry : case rys of (ry':rys') -> go ry' rys' [] -> prod'' ry xst @@ -126,7 +124,7 @@ then let (q, r) = (i `quotRem` fCard f2) in (fIndex f1 q, fIndex f2 r) else prodSel f1s f2s (i-mul) - prodSel _ _ = \i -> error "index out of bounds" + prodSel _ _ = \_ -> error "index out of bounds" union :: Enumerate a -> Enumerate a -> Enumerate a @@ -155,14 +153,14 @@ fmap f = toRev . fmap f . fromRev instance Semigroup a => Semigroup (RevList a) where - (<>) xs ys = toRev $ zipMon (fromRev xs) (fromRev ys) where + (<>) as bs = toRev $ zipMon (fromRev as) (fromRev bs) where zipMon :: Semigroup a => [a] -> [a] -> [a] zipMon (x:xs) (y:ys) = x <> y : zipMon xs ys zipMon xs ys = xs ++ ys -- Maybe this should be append instead? -- | Padded zip -instance (Monoid a, Semigroup a) => Monoid (RevList a) where +instance Semigroup a => Monoid (RevList a) where mempty = toRev[] mappend = (<>) @@ -170,13 +168,15 @@ -- Haskell implementation evaluating any inital segment of -- @'reversals' (toRev xs)@ uses linear memory in the size of the segment. toRev:: [a] -> RevList a -toRev xs = RevList xs $ go [] xs where +toRev as = RevList as $ go [] as where go _ [] = [] go rev (x:xs) = let rev' = x:rev in rev' : go rev' xs -- | Adds an element to the head of a @RevList@. Constant memory iff the -- the reversals of the resulting list are not evaluated (which is frequently -- the case in @Feat@). +revCons :: a -> RevList a -> RevList a revCons a = toRev. (a:) . fromRev +revPure :: a -> RevList a revPure a = RevList [a] [[a]] diff --git a/Test/Feat/Finite.hs b/Test/Feat/Finite.hs --- a/Test/Feat/Finite.hs +++ b/Test/Feat/Finite.hs @@ -1,72 +1,70 @@ --- | A datatype of finite sequences -module Test.Feat.Finite (Finite (..), Index, fromFinite, finFin) where - -import Control.Applicative -import Data.Semigroup -import Data.Monoid - -type Index = Integer -data Finite a = Finite {fCard :: Index, fIndex :: Index -> a} - -finEmpty = Finite 0 (\i -> error "index: Empty") - -finUnion :: Finite a -> Finite a -> Finite a -finUnion f1 f2 - | fCard f1 == 0 = f2 - | fCard f2 == 0 = f1 - | otherwise = Finite car sel where - car = fCard f1 + fCard f2 - sel i = if i < fCard f1 - then fIndex f1 i - else fIndex f2 (i-fCard f1) - -instance Functor Finite where - fmap f fin = fin{fIndex = f . fIndex fin} - -instance Applicative Finite where - pure = finPure - a <*> b = fmap (uncurry ($)) (finCart a b) - -instance Alternative Finite where - empty = finEmpty - (<|>) = finUnion - -instance Semigroup (Finite a) where - (<>) = finUnion - -instance Monoid (Finite a) where - mempty = finEmpty - mappend = finUnion - mconcat xs = Finite - (sum $ map fCard xs) - (sumSel $ filter ((>0) . fCard) xs) - -sumSel :: [Finite a] -> (Index -> a) -sumSel (f:rest) = \i -> if i < fCard f - then fIndex f i - else sumSel rest (i-fCard f) -sumSel _ = error "Index out of bounds" - -finCart :: Finite a -> Finite b -> Finite (a,b) -finCart f1 f2 = Finite car sel where - car = fCard f1 * fCard f2 - sel i = let (q, r) = (i `quotRem` fCard f2) - in (fIndex f1 q, fIndex f2 r) - -finPure :: a -> Finite a -finPure a = Finite 1 one where - one 0 = a - one _ = error "Index out of bounds" - - -fromFinite :: Finite a -> (Index,[a]) -fromFinite (Finite c ix) = (c,map ix [0..c-1]) - - -instance Show a => Show (Finite a) where - show = show . fromFinite - -finFin :: Integer -> Finite Integer -finFin k | k <= 0 = finEmpty -finFin k = Finite k (\i -> i) +-- | A datatype of finite sequences +module Test.Feat.Finite (Finite (..), Index, fromFinite, finFin) where +import Control.Applicative + +type Index = Integer +data Finite a = Finite {fCard :: Index, fIndex :: Index -> a} + +finEmpty :: Finite a +finEmpty = Finite 0 (\_ -> error "index: Empty") + +finUnion :: Finite a -> Finite a -> Finite a +finUnion f1 f2 + | fCard f1 == 0 = f2 + | fCard f2 == 0 = f1 + | otherwise = Finite car sel where + car = fCard f1 + fCard f2 + sel i = if i < fCard f1 + then fIndex f1 i + else fIndex f2 (i-fCard f1) + +instance Functor Finite where + fmap f fin = fin{fIndex = f . fIndex fin} + +instance Applicative Finite where + pure = finPure + a <*> b = fmap (uncurry ($)) (finCart a b) + +instance Alternative Finite where + empty = finEmpty + (<|>) = finUnion + +instance Semigroup (Finite a) where + (<>) = finUnion + +instance Monoid (Finite a) where + mempty = finEmpty + mappend = finUnion + mconcat xs = Finite + (sum $ map fCard xs) + (sumSel $ filter ((>0) . fCard) xs) + +sumSel :: [Finite a] -> (Index -> a) +sumSel (f:rest) = \i -> if i < fCard f + then fIndex f i + else sumSel rest (i-fCard f) +sumSel _ = error "Index out of bounds" + +finCart :: Finite a -> Finite b -> Finite (a,b) +finCart f1 f2 = Finite car sel where + car = fCard f1 * fCard f2 + sel i = let (q, r) = (i `quotRem` fCard f2) + in (fIndex f1 q, fIndex f2 r) + +finPure :: a -> Finite a +finPure a = Finite 1 one where + one 0 = a + one _ = error "Index out of bounds" + + +fromFinite :: Finite a -> (Index,[a]) +fromFinite (Finite c ix) = (c,map ix [0..c-1]) + + +instance Show a => Show (Finite a) where + show = show . fromFinite + +finFin :: Integer -> Finite Integer +finFin k | k <= 0 = finEmpty +finFin k = Finite k (\i -> i) diff --git a/testing-feat.cabal b/testing-feat.cabal --- a/testing-feat.cabal +++ b/testing-feat.cabal @@ -1,5 +1,5 @@ Name: testing-feat -Version: 1.1.0.0 +Version: 1.1.1.0 Synopsis: Functional Enumeration of Algebraic Types Description: Feat (Functional Enumeration of Algebraic Types) provides enumerations as functions from natural numbers to values @@ -16,13 +16,13 @@ ball. . The generators are provided by the size-based package. This means other libraries that implement the Sized class can use the same generator definitions. One such is the - , that uses laziness to search for values and test properties. This is typically a lot faster than Feat for properties that have preconditions (logical implication), but can not be used for random selection of values. + , that uses laziness to search for values and test properties. This is typically a lot faster than Feat for properties that have preconditions (logical implication), but can not be used for random selection of values. License: BSD3 License-file: LICENSE Author: Jonas Duregård -Maintainer: jonas.duregard@gmail.com -Homepage: https://github.com/JonasDuregard/testing-feat +Maintainer: byorgey@gmail.com +Homepage: https://github.com/size-based/testing-feat Copyright: Jonas Duregård Category: Testing Build-type: Simple @@ -30,12 +30,16 @@ examples/template-haskell/th.hs examples/haskell-src-exts/hse.hs examples/lambda-terms/lambdas.hs -Cabal-version: >=1.6 + CHANGELOG.md +Cabal-version: >=1.10 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 + source-repository head type: git - location: https://github.com/JonasDuregard/testing-feat -Library + location: https://github.com/size-based/testing-feat +Library + default-language: Haskell2010 Hs-source-dirs: . Exposed-modules: Test.Feat, @@ -48,10 +52,8 @@ Test.Feat.Modifiers Test.Feat.Class - Build-depends: + Build-depends: base >= 4.5 && < 5, QuickCheck > 2 && < 3, size-based < 0.2, testing-type-modifiers < 0.2 - if impl(ghc < 8.0) - Build-depends: semigroups < 0.19