Cabal-tests/tests/UnitTests/Distribution/Version.hs

   1 {-# OPTIONS_GHC -fno-warn-incomplete-patterns
   2                 -fno-warn-deprecations
   3                 -fno-warn-unused-binds #-} --FIXME
   4 module UnitTests.Distribution.Version (versionTests) where
   5
   6 import Distribution.Compat.Prelude.Internal
   7 import Prelude ()
   8
   9 import Distribution.Parsec                      (simpleParsec)
  10 import Distribution.Pretty
  11 import Distribution.Types.VersionRange.Internal
  12 import Distribution.Utils.Generic
  13 import Distribution.Version
  14
  15
  16 import Data.Maybe                      (fromJust)
  17 import Data.Typeable                   (typeOf)
  18 import Test.QuickCheck                 (Arbitrary (..), NonEmptyList (..), NonNegative (..), Property, Testable, counterexample, property, (===), (==>), vectorOf, sized, choose, arbitrarySizedNatural)
  19 import Test.QuickCheck.Instances.Cabal ()
  20 import Test.Tasty                      (TestTree)
  21 import Test.Tasty.QuickCheck           (testProperty)
  22
  23 import qualified Distribution.Types.VersionInterval        as New
  24 import qualified Distribution.Types.VersionInterval.Legacy as Old
  25 import qualified Text.PrettyPrint                          as Disp
  26
  27 versionTests :: [TestTree]
  28 versionTests =
  29     -- test 'Version' type
  30     [ tp "versionNumbers . mkVersion = id @[NonNegative Int]"  prop_VersionId
  31     , tp "versionNumbers . mkVersion = id @Base.Version"       prop_VersionId2
  32     , tp "(==) = (==) `on` versionNumbers"                     prop_VersionEq
  33     , tp "(==) = (==) `on` mkVersion"                          prop_VersionEq2
  34     , tp "compare = compare `on` versionNumbers"               prop_VersionOrd
  35     , tp "compare = compare `on` mkVersion"                    prop_VersionOrd2
  36
  37     , tp "readMaybe . show = Just"                             prop_ShowRead
  38     , tp "read example"                                        prop_ShowRead_example
  39
  40     , tp "parsec . prettyShow involutive"                      prop_parsec_disp_inv
  41
  42     , tp "normaliseVersionRange involutive"                    prop_normalise_inv
  43     , tp "normaliseVersionRange equivalent"                    prop_normalise_equiv
  44     , tp "normaliseVersionRange caretequiv"                    prop_normalise_caret_equiv
  45     , tp "normaliseVersionRange model"                         prop_normalise_model
  46
  47     , tp "simplifyVersionRange involutive"                     prop_simplify_inv
  48     , tp "simplifyVersionRange equivalent"                     prop_simplify_equiv
  49     -- , tp "simplifyVersionRange caretequiv"                     prop_simplify_caret_equiv
  50
  51     , tp "simpleParsec . prettyShow = Just" prop_parse_disp
  52     ]
  53
  54     ++
  55     zipWith
  56     (\n (rep, p) -> testProperty ("Range Property " ++ show n ++ " (" ++ show rep ++ ")") p)
  57     [1::Int ..]
  58       -- properties to validate the test framework
  59     [ typProperty prop_nonNull
  60     , typProperty prop_gen_intervals1
  61     , typProperty prop_gen_intervals2
  62
  63     , typProperty prop_anyVersion
  64     , typProperty prop_noVersion
  65     , typProperty prop_thisVersion
  66     , typProperty prop_notThisVersion
  67     , typProperty prop_laterVersion
  68     , typProperty prop_orLaterVersion
  69     , typProperty prop_earlierVersion
  70     , typProperty prop_orEarlierVersion
  71     , typProperty prop_unionVersionRanges
  72     , typProperty prop_intersectVersionRanges
  73     , typProperty prop_withinVersion
  74     , typProperty prop_foldVersionRange
  75
  76       -- converting between version ranges and version intervals
  77     , typProperty prop_to_from_intervals
  78     ]
  79   where
  80     tp :: Testable p => String -> p -> TestTree
  81     tp = testProperty
  82
  83     typProperty p = (typeOf p, property p)
  84
  85 -------------------------------------------------------------------------------
  86 -- Arbitrary for inputs of mkVersion
  87 -------------------------------------------------------------------------------
  88
  89 newtype VersionArb = VersionArb [Int]
  90                    deriving (Eq,Ord,Show)
  91
  92 -- | 'Version' instance as used by QC 2.9
  93 instance Arbitrary VersionArb where
  94   arbitrary = sized $ \n ->
  95     do k <- choose (0, log2 n)
  96        xs <- vectorOf (k+1) arbitrarySizedNatural
  97        return (VersionArb xs)
  98     where
  99       log2 :: Int -> Int
 100       log2 n | n <= 1 = 0
 101              | otherwise = 1 + log2 (n `div` 2)
 102
 103   shrink (VersionArb xs) =
 104     [ VersionArb xs'
 105     | xs' <- shrink xs
 106     , length xs' > 0
 107     , all (>=0) xs'
 108     ]
 109
 110 ---------------------
 111 -- Version properties
 112 --
 113
 114 prop_VersionId :: [NonNegative Int] -> Bool
 115 prop_VersionId lst0 =
 116     (versionNumbers . mkVersion) lst == lst
 117   where
 118     lst = map getNonNegative lst0
 119
 120 prop_VersionId2 :: VersionArb -> Bool
 121 prop_VersionId2 (VersionArb lst) =
 122     (versionNumbers . mkVersion) lst == lst
 123
 124 prop_VersionEq :: Version -> Version -> Bool
 125 prop_VersionEq v1 v2 = (==) v1 v2 == ((==) `on` versionNumbers) v1 v2
 126
 127 prop_VersionEq2 :: VersionArb -> VersionArb -> Bool
 128 prop_VersionEq2 (VersionArb v1) (VersionArb v2) =
 129     (==) v1 v2 == ((==) `on` mkVersion) v1 v2
 130
 131 prop_VersionOrd :: Version -> Version -> Bool
 132 prop_VersionOrd v1 v2 =
 133     compare v1 v2 == (compare `on` versionNumbers) v1 v2
 134
 135 prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool
 136 prop_VersionOrd2 (VersionArb v1) (VersionArb v2) =
 137     (==) v1 v2 == ((==) `on` mkVersion) v1 v2
 138
 139 prop_ShowRead :: Version -> Property
 140 prop_ShowRead v = Just v === readMaybe (show v)
 141
 142 prop_ShowRead_example :: Bool
 143 prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]"
 144
 145 ---------------------------
 146 -- VersionRange properties
 147 --
 148
 149 prop_normalise_inv :: VersionRange -> Property
 150 prop_normalise_inv vr = normaliseVersionRange vr === normaliseVersionRange (normaliseVersionRange vr)
 151
 152 prop_normalise_equiv :: VersionRange -> Version -> Property
 153 prop_normalise_equiv vr =
 154     prop_equivalentVersionRange vr (normaliseVersionRange vr)
 155
 156 prop_normalise_caret_equiv :: VersionRange -> Version -> Property
 157 prop_normalise_caret_equiv vr = prop_equivalentVersionRange
 158     (transformCaretUpper vr)
 159     (transformCaretUpper (normaliseVersionRange vr))
 160
 161 prop_normalise_model :: VersionRange -> Property
 162 prop_normalise_model vr =
 163     oldNormaliseVersionRange vr' === newNormaliseVersionRange vr'
 164   where
 165     vr' = transformCaret vr
 166
 167     oldNormaliseVersionRange :: VersionRange -> VersionRange
 168     oldNormaliseVersionRange = Old.fromVersionIntervals . Old.toVersionIntervals
 169
 170     newNormaliseVersionRange :: VersionRange -> VersionRange
 171     newNormaliseVersionRange = New.normaliseVersionRange2
 172
 173 prop_simplify_inv :: VersionRange -> Property
 174 prop_simplify_inv vr =
 175     simplifyVersionRange vr === simplifyVersionRange (simplifyVersionRange vr)
 176
 177 prop_simplify_equiv :: VersionRange -> Version -> Property
 178 prop_simplify_equiv vr v =
 179     counterexample (show vr') $ prop_equivalentVersionRange vr vr' v
 180   where
 181     vr' = simplifyVersionRange vr
 182
 183 -- TODO: Doesn't hold yet
 184 -- prop_simplify_caret_equiv :: VersionRange -> Version -> Property
 185 -- prop_simplify_caret_equiv vr = prop_equivalentVersionRange
 186 --     (transformCaretUpper vr)
 187 --     (transformCaretUpper (simplifyVersionRange vr))
 188
 189 prop_nonNull :: Version -> Bool
 190 prop_nonNull = (/= nullVersion)
 191
 192 prop_anyVersion :: Version -> Bool
 193 prop_anyVersion v' =
 194   withinRange v' anyVersion
 195
 196 prop_noVersion :: Version -> Bool
 197 prop_noVersion v' =
 198   withinRange v' noVersion == False
 199
 200 prop_thisVersion :: Version -> Version -> Bool
 201 prop_thisVersion v v' =
 202      withinRange v' (thisVersion v)
 203   == (v' == v)
 204
 205 prop_notThisVersion :: Version -> Version -> Bool
 206 prop_notThisVersion v v' =
 207      withinRange v' (notThisVersion v)
 208   == (v' /= v)
 209
 210 prop_laterVersion :: Version -> Version -> Bool
 211 prop_laterVersion v v' =
 212      withinRange v' (laterVersion v)
 213   == (v' > v)
 214
 215 prop_orLaterVersion :: Version -> Version -> Bool
 216 prop_orLaterVersion v v' =
 217      withinRange v' (orLaterVersion v)
 218   == (v' >= v)
 219
 220 prop_earlierVersion :: Version -> Version -> Bool
 221 prop_earlierVersion v v' =
 222      withinRange v' (earlierVersion v)
 223   == (v' < v)
 224
 225 prop_orEarlierVersion :: Version -> Version -> Bool
 226 prop_orEarlierVersion v v' =
 227      withinRange v' (orEarlierVersion v)
 228   == (v' <= v)
 229
 230 prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
 231 prop_unionVersionRanges vr1 vr2 v' =
 232      withinRange v' (unionVersionRanges vr1 vr2)
 233   == (withinRange v' vr1 || withinRange v' vr2)
 234
 235 prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
 236 prop_intersectVersionRanges vr1 vr2 v' =
 237      withinRange v' (intersectVersionRanges vr1 vr2)
 238   == (withinRange v' vr1 && withinRange v' vr2)
 239
 240 prop_withinVersion :: Version -> Version -> Property
 241 prop_withinVersion v v' =
 242     withinRange v' (withinVersion v)
 243     ===
 244     (v' >= v && v' < upper v)
 245   where
 246     upper = alterVersion $ \numbers -> case unsnoc numbers of
 247       Nothing      -> []
 248       Just (xs, x) -> xs ++ [x + 1]
 249
 250 prop_foldVersionRange :: VersionRange -> Property
 251 prop_foldVersionRange range =
 252      expandVR range
 253   === foldVersionRange anyVersion thisVersion
 254                       laterVersion earlierVersion
 255                       unionVersionRanges intersectVersionRanges
 256                       range
 257   where
 258     expandVR (MajorBoundVersion v) =
 259         intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (majorUpperBound v))
 260     expandVR (OrEarlierVersion v) =
 261         unionVersionRanges (thisVersion v) (earlierVersion v)
 262     expandVR (OrLaterVersion v) =
 263         unionVersionRanges (thisVersion v) (laterVersion v)
 264     expandVR (UnionVersionRanges     v1 v2) =
 265       UnionVersionRanges (expandVR v1) (expandVR v2)
 266     expandVR (IntersectVersionRanges v1 v2) =
 267       IntersectVersionRanges (expandVR v1) (expandVR v2)
 268     expandVR v = v
 269
 270     upper = alterVersion $ \numbers -> case unsnoc numbers of
 271       Nothing      -> []
 272       Just (xs, x) -> xs ++ [x + 1]
 273
 274 prop_isAnyVersion1 :: VersionRange -> Version -> Property
 275 prop_isAnyVersion1 range version =
 276   isAnyVersion range ==> withinRange version range
 277
 278 prop_isAnyVersion2 :: VersionRange -> Property
 279 prop_isAnyVersion2 range =
 280   isAnyVersion range ==>
 281     foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)
 282                           (\_ _ -> False) (\_ _ -> False)
 283       (simplifyVersionRange range)
 284
 285 prop_isNoVersion :: VersionRange -> Version -> Property
 286 prop_isNoVersion range version =
 287   isNoVersion range ==> not (withinRange version range)
 288
 289 prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property
 290 prop_isSpecificVersion1 range (NonEmpty versions) =
 291   isJust version && not (null versions') ==>
 292     allEqual (fromJust version) versions'
 293   where
 294     version       = isSpecificVersion range
 295     versions'     = filter (`withinRange` range) versions
 296     allEqual x xs = and (zipWith (==) (x:xs) xs)
 297
 298 prop_isSpecificVersion2 :: VersionRange -> Property
 299 prop_isSpecificVersion2 range =
 300   isJust version ==>
 301     foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)
 302                      (\_ _ -> Nothing) (\_ _ -> Nothing)
 303       (simplifyVersionRange range)
 304     == version
 305
 306   where
 307     version = isSpecificVersion range
 308
 309 -- | Check that our VersionIntervals' arbitrary instance generates intervals
 310 -- that satisfies the invariant.
 311 --
 312 prop_gen_intervals1 :: VersionIntervals -> Property
 313 prop_gen_intervals1 = property . New.invariantVersionIntervals
 314
 315 -- | Check that constructing our intervals type and converting it to a
 316 -- 'VersionRange' and then into the true intervals type gives us back
 317 -- the exact same sequence of intervals. This tells us that our arbitrary
 318 -- instance for 'VersionIntervals'' is ok.
 319 --
 320 prop_gen_intervals2 :: VersionIntervals -> Property
 321 prop_gen_intervals2 intervals =
 322     toVersionIntervals (fromVersionIntervals intervals) === intervals
 323 --
 324 -- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on
 325 -- 'VersionIntervals'.
 326 --
 327 prop_to_from_intervals :: VersionIntervals -> Bool
 328 prop_to_from_intervals intervals =
 329   toVersionIntervals (fromVersionIntervals intervals) == intervals
 330
 331 --------------------------------
 332 -- equivalentVersionRange helper
 333
 334 prop_equivalentVersionRange
 335     :: VersionRange  -> VersionRange -> Version -> Property
 336 prop_equivalentVersionRange range range' version =
 337     withinRange version range === withinRange version range'
 338
 339 --------------------------------
 340 -- Parsing and pretty printing
 341 --
 342 prop_parsec_disp_inv :: VersionRange -> Property
 343 prop_parsec_disp_inv vr =
 344     parseDisp vr === (parseDisp vr >>= parseDisp)
 345   where
 346     parseDisp = simpleParsec . prettyShow
 347
 348 prop_parse_disp :: VersionRange -> Property
 349 prop_parse_disp vr = counterexample (show (prettyShow vr')) $
 350     fmap s (simpleParsec (prettyShow vr')) === Just vr'
 351   where
 352     -- we have to strip parens, because arbitrary 'VersionRange' may have
 353     -- too little parens constructors.
 354     s = stripParensVersionRange
 355     vr' = s vr
 356
 357 prop_parse_disp1 :: VersionRange -> Bool
 358 prop_parse_disp1 vr =
 359     simpleParsec (prettyShow vr) == Just (normaliseVersionRange vr)
 360
 361 prop_parse_disp2 :: VersionRange -> Property
 362 prop_parse_disp2 vr =
 363   let b = fmap (prettyShow :: VersionRange -> String) (simpleParsec (prettyShow vr))
 364       a = Just (prettyShow vr)
 365   in
 366    counterexample ("Expected: " ++ show a) $
 367    counterexample ("But got: " ++ show b) $
 368    b == a
 369
 370 prop_parse_disp3 :: VersionRange -> Property
 371 prop_parse_disp3 vr =
 372   let a = Just (prettyShow vr)
 373       b = fmap displayRaw (simpleParsec (prettyShow vr))
 374   in
 375    counterexample ("Expected: " ++ show a) $
 376    counterexample ("But got: " ++ show b) $
 377    b == a
 378
 379 prop_parse_disp4 :: VersionRange -> Property
 380 prop_parse_disp4 vr =
 381   let a = Just vr
 382       b = (simpleParsec (prettyShow vr))
 383   in
 384    counterexample ("Expected: " ++ show a) $
 385    counterexample ("But got: " ++ show b) $
 386    b == a
 387
 388 prop_parse_disp5 :: VersionRange -> Property
 389 prop_parse_disp5 vr =
 390   let a = Just vr
 391       b = simpleParsec (displayRaw vr)
 392   in
 393    counterexample ("Expected: " ++ show a) $
 394    counterexample ("But got: " ++ show b) $
 395    b == a
 396
 397 displayRaw :: VersionRange -> String
 398 displayRaw =
 399    Disp.render
 400  . cataVersionRange alg . normaliseVersionRange
 401   where
 402
 403     -- precedence:
 404     -- All the same as the usual pretty printer, except for the parens
 405     alg (ThisVersionF v)                = Disp.text "==" <<>> pretty v
 406     alg (LaterVersionF v)               = Disp.char '>'  <<>> pretty v
 407     alg (EarlierVersionF v)             = Disp.char '<'  <<>> pretty v
 408     alg (OrLaterVersionF v)             = Disp.text ">=" <<>> pretty v
 409     alg (OrEarlierVersionF v)           = Disp.text "<=" <<>> pretty v
 410     alg (MajorBoundVersionF v)          = Disp.text "^>=" <<>> pretty v
 411     alg (UnionVersionRangesF r1 r2)     = r1 <+> Disp.text "||" <+> r2
 412     alg (IntersectVersionRangesF r1 r2) = r1 <+> Disp.text "&&" <+> r2
 413
 414     dispWild v =
 415            Disp.hcat (Disp.punctuate (Disp.char '.')
 416                                      (map Disp.int (versionNumbers v)))
 417         <<>> Disp.text ".*"