Merge pull request #3973 from phadej/version-show

Show Version returning "mkVersion [...]"

Cabal/Distribution/Version.hs

@@ -92,6 +92,8 @@ import qualified Text.PrettyPrint as Disp
 import Text.PrettyPrint ((<+>))
 import Control.Exception (assert)
 
+import qualified Text.Read as Read
+
 -- -----------------------------------------------------------------------------
 -- Versions
 
@@ -113,7 +115,7 @@ data Version = PV0 {-# UNPACK #-} !Word64
              -- which all fall into the [0..0xfffe] range), then PV0
              -- MUST be used. This is essential for the 'Eq' instance
              -- to work.
-             deriving (Data,Eq,Generic,Show,Read,Typeable)
+             deriving (Data,Eq,Generic,Typeable)
 
 instance Ord Version where
     compare (PV0 x)    (PV0 y)    = compare x y
@@ -137,6 +139,17 @@ instance Ord Version where
         y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1
         y4 = fromIntegral               (w .&. 0xffff) - 1
 
+instance Show Version where
+    showsPrec d v = showParen (d > 10)
+        $ showString "mkVersion "
+        . showsPrec 11 (versionNumbers v)
+
+instance Read Version where
+    readPrec = Read.parens $ do
+        Read.Ident "mkVersion" <- Read.lexP
+        v <- Read.step Read.readPrec
+        return (mkVersion v)
+
 instance Binary Version
 
 instance NFData Version where

Cabal/tests/UnitTests/Distribution/Utils/NubList.hs

-{-# LANGUAGE CPP #-}
+-- to suppress WARNING in "Distribution.Compat.Prelude.Internal"
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
 module UnitTests.Distribution.Utils.NubList
     ( tests
     ) where
 
-#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid
-#endif
+import Prelude ()
+import Distribution.Compat.Prelude.Internal
+
 import Distribution.Utils.NubList
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -13,10 +14,15 @@ import Test.Tasty.QuickCheck
 
 tests :: [TestTree]
 tests =
-    [ testCase "Numlist retains ordering" testOrdering
-    , testCase "Numlist removes duplicates" testDeDupe
-    , testProperty "Monoid Numlist Identity" prop_Identity
-    , testProperty "Monoid Numlist Associativity" prop_Associativity
+    [ testCase "NubList retains ordering example" testOrdering
+    , testCase "NubList removes duplicates example" testDeDupe
+    , testProperty "NubList retains ordering" prop_Ordering
+    , testProperty "NubList removes duplicates" prop_DeDupe
+    , testProperty "fromNubList . toNubList = nub" prop_Nub
+    , testProperty "Monoid NubList Identity" prop_Identity
+    , testProperty "Monoid NubList Associativity" prop_Associativity
+    -- NubListR
+    , testProperty "NubListR removes duplicates from the right" prop_DeDupeR
     ]
 
 someIntList :: [Int]
@@ -36,6 +42,30 @@ testDeDupe =
 -- ---------------------------------------------------------------------------
 -- QuickCheck properties for NubList
 
+prop_Ordering :: [Int] -> Property
+prop_Ordering xs =
+    mempty <> toNubList xs' === toNubList xs' <> mempty
+  where
+    xs' = nub xs
+
+prop_DeDupe :: [Int] -> Property
+prop_DeDupe xs =
+    fromNubList (toNubList (xs' ++ xs)) === xs' -- Note, we append primeless xs
+  where
+    xs' = nub xs
+
+prop_DeDupeR :: [Int] -> Property
+prop_DeDupeR xs =
+    fromNubListR (toNubListR (xs ++ xs')) === xs' -- Note, we prepend primeless xs
+  where
+    xs' = nub xs
+
+prop_Nub :: [Int] -> Property
+prop_Nub xs = rhs === lhs
+  where
+    rhs = fromNubList (toNubList xs)
+    lhs = nub xs
+
 prop_Identity :: [Int] -> Bool
 prop_Identity xs =
     mempty `mappend` toNubList xs == toNubList xs `mappend` mempty

Cabal/tests/UnitTests/Distribution/Version.hs

+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans
                 -fno-warn-incomplete-patterns
                 -fno-warn-deprecations
@@ -21,79 +22,89 @@ import Data.Maybe (isJust, fromJust)
 import Data.List (sort, sortBy, nub)
 import Data.Ord  (comparing)
 import Data.Function (on)
+#if MIN_VERSION_base(4,6,0)
+import Text.Read (readMaybe)
+#endif
 
 versionTests :: [TestTree]
 versionTests =
-  zipWith (\n p -> testProperty ("Range Property " ++ show n) p) [1::Int ..]
-    -- properties to validate the test framework
-  [ property prop_nonNull
-  , property prop_gen_intervals1
-  , property prop_gen_intervals2
---, property prop_equivalentVersionRange --FIXME: runs out of test cases
-  , property prop_intermediateVersion
-
     -- test 'Version' type
-  , property prop_VersionId
-  , property prop_VersionId2
-  , property prop_VersionEq
-  , property prop_VersionEq2
-  , property prop_VersionOrd
-  , property prop_VersionOrd2
-
-    -- 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_differenceVersionRanges
-  , property prop_invertVersionRange
-  , property prop_withinVersion
-  , property prop_foldVersionRange
-  , property prop_foldVersionRange'
-
-    -- the semantic query functions
---, property prop_isAnyVersion1       --FIXME: runs out of test cases
---, property prop_isAnyVersion2       --FIXME: runs out of test cases
---, property prop_isNoVersion         --FIXME: runs out of test cases
---, property prop_isSpecificVersion1  --FIXME: runs out of test cases
---, property prop_isSpecificVersion2  --FIXME: runs out of test cases
-  , property prop_simplifyVersionRange1
-  , property prop_simplifyVersionRange1'
---, property prop_simplifyVersionRange2   --FIXME: runs out of test cases
---, property prop_simplifyVersionRange2'  --FIXME: runs out of test cases
---, property prop_simplifyVersionRange2'' --FIXME: actually wrong
-
-    -- converting between version ranges and version intervals
-  , property prop_to_intervals
---, property prop_to_intervals_canonical  --FIXME: runs out of test cases
---, property prop_to_intervals_canonical' --FIXME: runs out of test cases
-  , 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
-
-    -- inversion of version intervals
-  , property prop_invertVersionIntervals
-  , property prop_invertVersionIntervalsTwice
-  ]
+    [ tp "versionNumbers . mkVersion = id @[NonNegative Int]"  prop_VersionId
+    , tp "versionNumbers . mkVersion = id @Base.Version"       prop_VersionId2
+    , tp "(==) = (==) `on` versionNumbers"                     prop_VersionEq
+    , tp "(==) = (==) `on` mkVersion"                          prop_VersionEq2
+    , tp "compare = compare `on` versionNumbers"               prop_VersionOrd
+    , tp "compare = compare `on` mkVersion"                    prop_VersionOrd2
+
+    , tp "readMaybe . show = Just"                             prop_ShowRead
+    , tp "read example"                                        prop_ShowRead_example
+    ]
+
+    ++ 
+    zipWith (\n p -> testProperty ("Range Property " ++ show n) p) [1::Int ..]
+      -- properties to validate the test framework
+    [ property prop_nonNull
+    , property prop_gen_intervals1
+    , property prop_gen_intervals2
+  --, property prop_equivalentVersionRange --FIXME: runs out of test cases
+    , property prop_intermediateVersion
+
+    , 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_differenceVersionRanges
+    , property prop_invertVersionRange
+    , property prop_withinVersion
+    , property prop_foldVersionRange
+    , property prop_foldVersionRange'
+
+      -- the semantic query functions
+  --, property prop_isAnyVersion1       --FIXME: runs out of test cases
+  --, property prop_isAnyVersion2       --FIXME: runs out of test cases
+  --, property prop_isNoVersion         --FIXME: runs out of test cases
+  --, property prop_isSpecificVersion1  --FIXME: runs out of test cases
+  --, property prop_isSpecificVersion2  --FIXME: runs out of test cases
+    , property prop_simplifyVersionRange1
+    , property prop_simplifyVersionRange1'
+  --, property prop_simplifyVersionRange2   --FIXME: runs out of test cases
+  --, property prop_simplifyVersionRange2'  --FIXME: runs out of test cases
+  --, property prop_simplifyVersionRange2'' --FIXME: actually wrong
+
+      -- converting between version ranges and version intervals
+    , property prop_to_intervals
+  --, property prop_to_intervals_canonical  --FIXME: runs out of test cases
+  --, property prop_to_intervals_canonical' --FIXME: runs out of test cases
+    , 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
+
+      -- inversion of version intervals
+    , property prop_invertVersionIntervals
+    , property prop_invertVersionIntervalsTwice
+    ]
+  where
+    tp :: Testable p => String -> p -> TestTree
+    tp = testProperty
 
 -- parseTests :: [TestTree]
 -- parseTests =
@@ -204,6 +215,17 @@ prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool
 prop_VersionOrd2 (VersionArb v1) (VersionArb v2) =
     (==) v1 v2 == ((==) `on` mkVersion) v1 v2
 
+prop_ShowRead :: Version -> Property
+#if MIN_VERSION_base(4,6,0)
+prop_ShowRead v = Just v === readMaybe (show v)
+#else
+-- readMaybe is since base-4.6
+prop_ShowRead v = v === read (show v)
+#endif
+
+prop_ShowRead_example :: Bool
+prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]"
+
 ---------------------------
 -- VersionRange properties
 --