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.

tests/Test/Distribution/Version.hs

-{-# 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

tests/Test/Laws.hs

+{-# 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