Commit 9bb49ba4 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Update and extend the Version quickcheck properties

One property fails. The failure reveals that the VersionInterval type
is not quite a canonical representation of the VersionRange semantics.
This is because the lowest Version is [0] and not -infinity, so for
example the intervals (.., 0] and [0,0] are equivalent.
parent 27fc3247
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Distribution.Version where
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-}
module Test.Distribution.Version (properties) where
import Distribution.Version
import Test.QuickCheck
import Test.QuickCheck.Utils
import qualified Test.Laws as Laws
import Control.Monad (liftM, liftM2)
import Data.Maybe (isJust, fromJust)
import Data.List (sort, sortBy, nub)
import Data.Ord (comparing)
properties :: [Property]
properties =
-- properties to validate the test framework
[ property prop_nonNull
, property prop_gen_intervals1
, property prop_gen_intervals2
, property prop_equivalentVersionRange
, property prop_intermediateVersion
-- the basic syntactic version range functions
, property prop_anyVersion
, property prop_noVersion
, property prop_thisVersion
, property prop_notThisVersion
, property prop_laterVersion
, property prop_orLaterVersion
, property prop_earlierVersion
, property prop_orEarlierVersion
, property prop_unionVersionRanges
, property prop_intersectVersionRanges
, property prop_withinVersion
, property prop_foldVersionRange
-- the semantic query functions
, property prop_isAnyVersion1
, property prop_isAnyVersion2
, property prop_isNoVersion
, property prop_isSpecificVersion1
, property prop_isSpecificVersion2
, property prop_simplifyVersionRange1
, property prop_simplifyVersionRange1'
, property prop_simplifyVersionRange2
, property prop_simplifyVersionRange2'
, property prop_simplifyVersionRange2'' --FIXME
-- converting between version ranges and version intervals
, property prop_to_intervals
, property prop_to_intervals_canonical
, property prop_to_intervals_canonical'
, property prop_from_intervals
, property prop_to_from_intervals
, property prop_from_to_intervals
, property prop_from_to_intervals'
-- union and intersection of version intervals
, property prop_unionVersionIntervals
, property prop_unionVersionIntervals_idempotent
, property prop_unionVersionIntervals_commutative
, property prop_unionVersionIntervals_associative
, property prop_intersectVersionIntervals
, property prop_intersectVersionIntervals_idempotent
, property prop_intersectVersionIntervals_commutative
, property prop_intersectVersionIntervals_associative
, property prop_union_intersect_distributive
, property prop_intersect_union_distributive
]
instance Arbitrary Version where
arbitrary = do
......@@ -21,7 +81,7 @@ instance Arbitrary Version where
smallListOf1 = adjustSize (\n -> min 5 (n `div` 3)) . listOf1
shrink (Version branch []) =
[ Version branch' [] | branch' <- shrink branch ]
[ Version branch' [] | branch' <- shrink branch, not (null branch') ]
shrink (Version branch _tags) =
[ Version branch [] ]
......@@ -35,10 +95,417 @@ instance Arbitrary VersionRange where
, (1, liftM orLaterVersion arbitrary)
, (1, liftM earlierVersion arbitrary)
, (1, liftM orEarlierVersion arbitrary)
, (1, liftM WildcardVersion arbitrary)
, (1, liftM withinVersion arbitrary)
] ++ if n == 0 then [] else
[ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2)
, (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
]
where
verRangeExp2 = verRangeExp (n `div` 2)
---------------------------
-- VersionRange properties
--
prop_nonNull :: Version -> Bool
prop_nonNull = not . null . versionBranch
prop_anyVersion :: Version -> Bool
prop_anyVersion v' =
withinRange v' anyVersion == True
prop_noVersion :: Version -> Bool
prop_noVersion v' =
withinRange v' noVersion == False
prop_thisVersion :: Version -> Version -> Bool
prop_thisVersion v v' =
withinRange v' (thisVersion v)
== (v' == v)
prop_notThisVersion :: Version -> Version -> Bool
prop_notThisVersion v v' =
withinRange v' (notThisVersion v)
== (v' /= v)
prop_laterVersion :: Version -> Version -> Bool
prop_laterVersion v v' =
withinRange v' (laterVersion v)
== (v' > v)
prop_orLaterVersion :: Version -> Version -> Bool
prop_orLaterVersion v v' =
withinRange v' (orLaterVersion v)
== (v' >= v)
prop_earlierVersion :: Version -> Version -> Bool
prop_earlierVersion v v' =
withinRange v' (earlierVersion v)
== (v' < v)
prop_orEarlierVersion :: Version -> Version -> Bool
prop_orEarlierVersion v v' =
withinRange v' (orEarlierVersion v)
== (v' <= v)
prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
prop_unionVersionRanges vr1 vr2 v' =
withinRange v' (unionVersionRanges vr1 vr2)
== (withinRange v' vr1 || withinRange v' vr2)
prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
prop_intersectVersionRanges vr1 vr2 v' =
withinRange v' (intersectVersionRanges vr1 vr2)
== (withinRange v' vr1 && withinRange v' vr2)
prop_withinVersion :: Version -> Version -> Bool
prop_withinVersion v v' =
withinRange v' (withinVersion v)
== (v' >= v && v' < upper v)
where
upper (Version lower t) = Version (init lower ++ [last lower + 1]) t
prop_foldVersionRange :: VersionRange -> Bool
prop_foldVersionRange range =
range
== foldVersionRange anyVersion thisVersion
laterVersion earlierVersion
(\v _ -> withinVersion v)
unionVersionRanges intersectVersionRanges
range
prop_isAnyVersion1 :: VersionRange -> Version -> Property
prop_isAnyVersion1 range version =
isAnyVersion range ==> withinRange version range
prop_isAnyVersion2 :: VersionRange -> Property
prop_isAnyVersion2 range =
isAnyVersion range ==>
foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)
(\_ _ -> False) (\_ _ -> False) (\_ _ -> False)
(simplifyVersionRange range)
prop_isNoVersion :: VersionRange -> Version -> Property
prop_isNoVersion range version =
isNoVersion range ==> not (withinRange version range)
prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property
prop_isSpecificVersion1 range (NonEmpty versions) =
isJust version && not (null versions') ==>
allEqual (fromJust version : versions')
where
version = isSpecificVersion range
versions' = filter (`withinRange` range) versions
allEqual xs = and (zipWith (==) xs (tail xs))
prop_isSpecificVersion2 :: VersionRange -> Property
prop_isSpecificVersion2 range =
isJust version ==>
foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)
(\_ _ -> Nothing) (\_ _ -> Nothing) (\_ _ -> Nothing)
(simplifyVersionRange range)
== version
where
version = isSpecificVersion range
-- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'.
--
prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool
prop_simplifyVersionRange1 range version =
withinRange version range == withinRange version (simplifyVersionRange range)
prop_simplifyVersionRange1' :: VersionRange -> Bool
prop_simplifyVersionRange1' range =
range `equivalentVersionRange` (simplifyVersionRange range)
-- | 'simplifyVersionRange' produces a canonical form for ranges with
-- equivalent semantics.
--
prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property
prop_simplifyVersionRange2 r r' v =
r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
withinRange v r == withinRange v r'
prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property
prop_simplifyVersionRange2' r r' =
r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
r `equivalentVersionRange` r'
prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property
prop_simplifyVersionRange2'' r r' =
r /= r' && r `equivalentVersionRange` r' ==>
simplifyVersionRange r == simplifyVersionRange r'
--------------------
-- VersionIntervals
--
-- | Generating VersionIntervals
--
-- This is a tad tricky as VersionIntervals is an abstract type, so we first
-- make a local type for generating the internal representation. Then we check
-- that this lets us construct valid 'VersionIntervals'.
--
newtype VersionIntervals' = VersionIntervals' [VersionInterval]
deriving (Eq, Show)
instance Arbitrary VersionIntervals' where
arbitrary = do
lbound <- arbitrary
ubound <- arbitrary
bounds <- arbitrary
let intervals = mergeTouching
. map fixEmpty
. replaceLower lbound
. replaceUpper ubound
. pairs
. sortBy (comparing fst)
$ bounds
return (VersionIntervals' intervals)
where
pairs ((l, lb):(u, ub):bs) = (LowerBound l lb, UpperBound u ub)
: pairs bs
pairs _ = []
replaceLower NoLowerBound ((_,u):is) = (NoLowerBound, u) : is
replaceLower _ is = is
replaceUpper NoUpperBound [(l,_)] = [(l, NoUpperBound)]
replaceUpper NoUpperBound (i:is) = i : replaceUpper NoUpperBound is
replaceUpper _ is = is
-- merge adjacent intervals that touch
mergeTouching (i1@(l,u):i2@(l',u'):is)
| doesNotTouch u l' = i1 : mergeTouching (i2:is)
| otherwise = mergeTouching ((l,u'):is)
mergeTouching is = is
doesNotTouch :: UpperBound -> LowerBound -> Bool
doesNotTouch NoUpperBound _ = False
doesNotTouch _ NoLowerBound = False
doesNotTouch (UpperBound u ub) (LowerBound l lb) =
u < l
|| (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
fixEmpty (LowerBound l _, UpperBound u _)
| l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound)
fixEmpty i = i
shrink (VersionIntervals' intervals) =
[ VersionIntervals' intervals' | intervals' <- shrink intervals ]
instance Arbitrary Bound where
arbitrary = elements [ExclusiveBound, InclusiveBound]
instance Arbitrary LowerBound where
arbitrary = oneof [return NoLowerBound
,liftM2 LowerBound arbitrary arbitrary]
instance Arbitrary UpperBound where
arbitrary = oneof [return NoUpperBound
,liftM2 UpperBound arbitrary arbitrary]
-- | Check that our VersionIntervals' arbitrary instance generates intervals
-- that satisfies the invariant.
--
prop_gen_intervals1 :: VersionIntervals' -> Bool
prop_gen_intervals1 (VersionIntervals' intervals) =
isJust (mkVersionIntervals intervals)
instance Arbitrary VersionIntervals where
arbitrary = do
VersionIntervals' intervals <- arbitrary
case mkVersionIntervals intervals of
Just xs -> return xs
-- | Check that constructing our intervals type and converting it to a
-- 'VersionRange' and then into the true intervals type gives us back
-- the exact same sequence of intervals. This tells us that our arbitrary
-- instance for 'VersionIntervals'' is ok.
--
prop_gen_intervals2 :: VersionIntervals' -> Bool
prop_gen_intervals2 (VersionIntervals' intervals') =
asVersionIntervals (fromVersionIntervals intervals) == intervals'
where
Just intervals = mkVersionIntervals intervals'
-- | Check that 'VersionIntervals' models 'VersionRange' via
-- 'toVersionIntervals'.
--
prop_to_intervals :: VersionRange -> Version -> Bool
prop_to_intervals range version =
withinRange version range == withinIntervals version intervals
where
intervals = toVersionIntervals range
-- | Check that semantic equality on 'VersionRange's is the same as converting
-- to 'VersionIntervals' and doing syntactic equality.
--
prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property
prop_to_intervals_canonical r r' =
r /= r' && r `equivalentVersionRange` r' ==>
toVersionIntervals r == toVersionIntervals r'
prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property
prop_to_intervals_canonical' r r' =
r /= r' && toVersionIntervals r == toVersionIntervals r' ==>
r `equivalentVersionRange` r'
-- | Check that 'VersionIntervals' models 'VersionRange' via
-- 'fromVersionIntervals'.
--
prop_from_intervals :: VersionIntervals -> Version -> Bool
prop_from_intervals intervals version =
withinRange version range == withinIntervals version intervals
where
range = fromVersionIntervals intervals
-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on
-- 'VersionIntervals'.
--
prop_to_from_intervals :: VersionIntervals -> Bool
prop_to_from_intervals intervals =
toVersionIntervals (fromVersionIntervals intervals) == intervals
-- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on
-- 'VersionRange', though not necessarily a syntactic identity.
--
prop_from_to_intervals :: VersionRange -> Bool
prop_from_to_intervals range =
range' `equivalentVersionRange` range
where
range' = fromVersionIntervals (toVersionIntervals range)
-- | Equivalent of 'prop_from_to_intervals'
--
prop_from_to_intervals' :: VersionRange -> Version -> Bool
prop_from_to_intervals' range version =
withinRange version range' == withinRange version range
where
range' = fromVersionIntervals (toVersionIntervals range)
-- | The semantics of 'unionVersionIntervals' is (||).
--
prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals
-> Version -> Bool
prop_unionVersionIntervals is1 is2 v =
withinIntervals v (unionVersionIntervals is1 is2)
== (withinIntervals v is1 || withinIntervals v is2)
-- | 'unionVersionIntervals' is idempotent
--
prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool
prop_unionVersionIntervals_idempotent =
Laws.idempotent_binary unionVersionIntervals
-- | 'unionVersionIntervals' is commutative
--
prop_unionVersionIntervals_commutative :: VersionIntervals
-> VersionIntervals -> Bool
prop_unionVersionIntervals_commutative =
Laws.commutative unionVersionIntervals
-- | 'unionVersionIntervals' is associative
--
prop_unionVersionIntervals_associative :: VersionIntervals
-> VersionIntervals
-> VersionIntervals -> Bool
prop_unionVersionIntervals_associative =
Laws.associative unionVersionIntervals
-- | The semantics of 'intersectVersionIntervals' is (&&).
--
prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals
-> Version -> Bool
prop_intersectVersionIntervals is1 is2 v =
withinIntervals v (intersectVersionIntervals is1 is2)
== (withinIntervals v is1 && withinIntervals v is2)
-- | 'intersectVersionIntervals' is idempotent
--
prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool
prop_intersectVersionIntervals_idempotent =
Laws.idempotent_binary intersectVersionIntervals
-- | 'intersectVersionIntervals' is commutative
--
prop_intersectVersionIntervals_commutative :: VersionIntervals
-> VersionIntervals -> Bool
prop_intersectVersionIntervals_commutative =
Laws.commutative intersectVersionIntervals
-- | 'intersectVersionIntervals' is associative
--
prop_intersectVersionIntervals_associative :: VersionIntervals
-> VersionIntervals
-> VersionIntervals -> Bool
prop_intersectVersionIntervals_associative =
Laws.associative intersectVersionIntervals
-- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals'
--
prop_union_intersect_distributive :: Property
prop_union_intersect_distributive =
Laws.distributive_left unionVersionIntervals intersectVersionIntervals
.&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals
-- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals'
--
prop_intersect_union_distributive :: Property
prop_intersect_union_distributive =
Laws.distributive_left intersectVersionIntervals unionVersionIntervals
.&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals
--------------------------------
-- equivalentVersionRange helper
prop_equivalentVersionRange :: VersionRange -> VersionRange
-> Version -> Property
prop_equivalentVersionRange range range' version =
equivalentVersionRange range range' && range /= range' ==>
withinRange version range == withinRange version range'
equivalentVersionRange :: VersionRange -> VersionRange -> Bool
equivalentVersionRange vr1 vr2 =
let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))
minPoint = Version [0] []
maxPoint | null allVersionsUsed = minPoint
| otherwise = case maximum allVersionsUsed of
Version vs _ -> Version (vs ++ [1]) []
probeVersions = minPoint : maxPoint
: intermediateVersions allVersionsUsed
in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions
where
versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x])
(\x y -> [x,y]) (++) (++)
intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2
: intermediateVersions (v2:vs)
intermediateVersions vs = vs
intermediateVersion :: Version -> Version -> Version
intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2"
intermediateVersion (Version v1 _) (Version v2 _) =
Version (intermediateList v1 v2) []
where
intermediateList :: [Int] -> [Int] -> [Int]
intermediateList [] (_:_) = [0]
intermediateList (x:xs) (y:ys)
| x < y = x : xs ++ [0]
| otherwise = x : intermediateList xs ys
prop_intermediateVersion :: Version -> Version -> Property
prop_intermediateVersion v1 v2 =
(v1 /= v2) && not (adjacentVersions v1 v2) ==>
if v1 < v2
then let v = intermediateVersion v1 v2
in (v1 < v && v < v2)
else let v = intermediateVersion v2 v1
in v1 > v && v > v2
adjacentVersions :: Version -> Version -> Bool
adjacentVersions (Version v1 _) (Version v2 _) = v1 ++ [0] == v2
|| v2 ++ [0] == v1
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Laws where
import Prelude
import Prelude (Functor(..))
import Prelude hiding (Num((+), (*)))
import Data.Monoid (Monoid(..), Endo(..))
import qualified Data.Foldable as Foldable
idempotent_unary f x = f fx == fx where fx = f x
-- Basic laws on binary operators
idempotent_binary (+) x = x + x == x
commutative (+) x y = x + y == y + x
associative (+) x y z = (x + y) + z == x + (y + z)
distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z)
distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x)
-- | The first 'fmap' law
--
-- > fmap id == id
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment