Cabal-tests/tests/RPMVerCmp.hs

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2 {-# LANGUAGE OverloadedStrings        #-}
   3 module Main where
   4
   5 import Foreign.C.String (CString)
   6 import Foreign.C.Types  (CInt (..))
   7 import System.IO.Unsafe (unsafePerformIO)
   8 import Data.Bits ((.&.))
   9
  10 import Test.QuickCheck       (Arbitrary (..), (===))
  11 import Test.Tasty            (defaultMain, testGroup)
  12 import Test.Tasty.HUnit      (assertEqual, testCase)
  13 import Test.Tasty.QuickCheck (testProperty)
  14
  15 import Distribution.Pretty                 (prettyShow)
  16 import Distribution.Types.PkgconfigVersion (rpmvercmp)
  17 import Distribution.Types.Version
  18
  19 import qualified Data.ByteString       as BS
  20 import qualified Data.ByteString.Char8 as BS8
  21
  22 -------------------------------------------------------------------------------
  23 -- C reference implementation
  24 -------------------------------------------------------------------------------
  25
  26 foreign import ccall unsafe "rpmvercmp" c_rmpvercmp
  27     :: CString -> CString -> CInt
  28
  29 rpmvercmpRef :: BS.ByteString -> BS.ByteString -> Ordering
  30 rpmvercmpRef a b = unsafePerformIO $
  31     BS.useAsCString a $ \a' ->
  32     BS.useAsCString b $ \b' ->
  33         return $ fromInt $ c_rmpvercmp a' b'
  34   where
  35     fromInt = flip compare 0
  36
  37 -------------------------------------------------------------------------------
  38 -- Tests
  39 -------------------------------------------------------------------------------
  40
  41 main :: IO ()
  42 main = defaultMain $ testGroup "rpmvercmp"
  43     [ testGroup "examples"
  44         [ example "openssl" "1.1.0g" "1.1.0i" LT
  45         , example "openssl" "1.0.2h" "1.1.0"  LT
  46
  47         , example "simple" "1.2.3" "1.2.4" LT
  48         , example "word" "apple" "banana" LT
  49
  50         , example "corner case" "r" "" GT
  51         , example "corner case" "0" "1" LT
  52         , example "corner case" "1" "0.0" GT
  53         ]
  54     , testGroup "Properties"
  55         [ testProperty "ref reflexive" $ \a ->
  56             rpmvercmpRef (BS.pack a) (BS.pack a) === EQ
  57         , testProperty "pure reflexive" $ \a ->
  58             rpmvercmp (BS.pack a) (BS.pack a) === EQ
  59         , testProperty "ref agrees with Version" $ \a b ->
  60             compare a b === rpmvercmpRef (v2bs a) (v2bs b)
  61         , testProperty "pure agrees with Version" $ \a b ->
  62             compare a b === rpmvercmp (v2bs a) (v2bs b)
  63         ]
  64     , testGroup "Random inputs"
  65         [ testProperty "random" $ \xs ys ->
  66             -- only 7bit numbers, no zero, and non-empty.
  67             let xs' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) xs
  68                 ys' = BS.pack $ unnull $ filter (/= 0) $ map (.&. 0x7f) ys
  69
  70                 -- ref doesn't really work with empty inputs reliably.
  71                 unnull [] = [1]
  72                 unnull zs = zs
  73             in rpmvercmpRef xs' ys' === rpmvercmp xs' ys'
  74         ]
  75     ]
  76   where
  77     example n a b c = testCase (n ++ " " ++ BS8.unpack a ++ " <=> " ++ BS8.unpack b) $ do
  78         let ref = rpmvercmpRef a b
  79         let pur = rpmvercmp a b
  80         assertEqual "ref" c ref
  81         assertEqual "pure" c pur
  82
  83 -------------------------------------------------------------------------------
  84 -- Version arbitrary
  85 -------------------------------------------------------------------------------
  86
  87 newtype V = V Version
  88   deriving (Show, Eq, Ord)
  89
  90 unV :: V -> Version
  91 unV (V x) = x
  92
  93 instance Arbitrary V where
  94     arbitrary = fmap (V . mkVersion_) arbitrary
  95
  96     shrink = map V . filter (/= version0) . map mkVersion_ . shrink . versionNumbers . unV
  97
  98 mkVersion_ :: [Int] -> Version
  99 mkVersion_ [] = version0
 100 mkVersion_ xs = mkVersion (map abs xs)
 101
 102 v2bs :: V -> BS.ByteString
 103 v2bs (V x) = BS8.pack (prettyShow x)