cabal-gild-0.2.1.1: source/test-suite/CabalGild/Test/Interval.hs
{-# OPTIONS_GHC -Wno-orphans #-}
module CabalGild.Test.Interval where
import Control.Monad (replicateM)
import Distribution.Parsec (eitherParsec)
import Distribution.Types.Version
( Version,
mkVersion,
validVersion,
versionNumbers,
)
import Distribution.Types.VersionRange
( VersionRange,
VersionRangeF (..),
anyVersion,
earlierVersion,
intersectVersionRanges,
laterVersion,
majorBoundVersion,
notThisVersion,
orEarlierVersion,
orLaterVersion,
projectVersionRange,
thisVersion,
unionVersionRanges,
withinRange,
withinVersion,
)
import Distribution.Version (transformCaretUpper)
import Test.QuickCheck (Arbitrary (..), (===))
import qualified Test.QuickCheck as QC
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Tasty.QuickCheck (testProperty)
import VersionInterval
tests :: TestTree
tests =
testGroup
"version-interval"
[ testGroup
"Validity"
[ testProperty "validVersion" validVersion,
testProperty "validVersionInterval" validVersionInterval,
testProperty "validVersionIntervals" $ \vr ->
let intervals = toVersionIntervals vr
in QC.counterexample (show intervals) $ validVersionIntervals intervals
],
testGroup
"VersionInterval"
[ testProperty "intersect valid" $ \a b ->
let ab = intersectInterval a b
in maybe (QC.property True) (\ab' -> QC.counterexample ("intersection: " ++ show ab') $ validVersionInterval ab') ab,
testProperty "intersect complete" intersectComplete,
testProperty "intersect complete lax" intersectCompleteLax
],
testGroup
"stage1"
[ testProperty "valid" stage1_valid,
testProperty "complete" stage1_complete,
testProperty "complete lax" stage1_complete_lax,
testProperty "valid ex1" $
stage1_valid
(intersectVersionRanges (majorBoundVersion (mkVersion [0])) (thisVersion (mkVersion [1]))),
testProperty "valid ex2" $
stage1_valid
(intersectVersionRanges (majorBoundVersion (mkVersion [0])) (orLaterVersion (mkVersion [1]))),
testProperty "complete ex1" $
stage1_complete
(intersectVersionRanges (majorBoundVersion (mkVersion [0])) (thisVersion (mkVersion [6])))
(mkVersion [6]),
testProperty "complete ex2" $
stage1_complete
(intersectVersionRanges (majorBoundVersion (mkVersion [0])) (orLaterVersion (mkVersion [1]))),
testProperty "complete lax ex2" $
stage1_complete_lax
(intersectVersionRanges (majorBoundVersion (mkVersion [0])) (orLaterVersion (mkVersion [1])))
],
testGroup
"stage2"
[ testProperty "valid" stage2_valid,
testProperty "involutive" stage2_involutive,
testProperty "complete" stage2_complete,
testProperty "complete_lax" stage2_complete_lax
],
testGroup
"stage3"
[ testProperty "valid" stage3_valid,
testProperty "involutive" stage3_involutive,
testProperty "complete" stage3_complete,
testProperty "complete_lax" stage3_complete_lax,
testProperty "complete ex1" $
stage3_complete
[VI (LB (mkVersion [0])) (MB (mkVersion [0])) NoUB, VI (LB (mkVersion [0, 0])) NoMB NoUB]
(mkVersion [0]),
testProperty "complete lax ex1" $
stage3_complete_lax
[VI (LB (mkVersion [0, 0])) (MB (mkVersion [0])) (UB (mkVersion [1])), VI (LB (mkVersion [0, 0, 0])) (MB (mkVersion [1])) (UB (mkVersion [1]))]
(mkVersion [1]),
testProperty "valid ex2" $
stage3_valid
(stage1 id (intersectVersionRanges (majorBoundVersion (mkVersion [0])) (orLaterVersion (mkVersion [1])))),
testProperty "complete ex2" $
stage3_complete
(stage1 id (intersectVersionRanges (majorBoundVersion (mkVersion [0])) (orLaterVersion (mkVersion [1])))),
testProperty "complete lax ex2" $
stage3_complete_lax
(stage1 id (intersectVersionRanges (majorBoundVersion (mkVersion [0])) (orLaterVersion (mkVersion [1])))),
testProperty "valid ex3" $
stage3_valid
[VI (LB (mkVersion [0, 0])) (MB (mkVersion [0])) NoUB, VI (LB (mkVersion [0, 0])) NoMB NoUB]
],
testGroup
"normalise"
[ normaliseExample ">=1 && <2" ">=1 && <2",
normaliseExample "^>=1" "^>=1",
normaliseExample "^>=1 || ^>=2" "^>=1 || ^>=2",
normaliseExample "^>=1.2 || ^>=1.3 || ^>=1.4" "^>=1.2 || ^>=1.3 || ^>=1.4",
normaliseExample "^>=1.2 || ^>=2.0" "^>=1.2 || ^>=2.0",
normaliseExample ">=1.2 && <1.4 || ^>=1.4 || ^>=1.5" "^>=1.2 || ^>=1.3 || ^>=1.4 || ^>=1.5",
normaliseExample ">=1.2 && <2.4 || ^>=2.4 || ^>=2.5" ">=1.2 && <2.5 || ^>=2.5",
normaliseExample "^>=1.2.0.0 || ^>=1.3.0.0 || ^>=1.4.0.0" "^>=1.2.0.0 || ^>=1.3.0.0 || ^>=1.4.0.0",
normaliseExample "==3.1.4" "==3.1.4",
normaliseExample "<3.1.4 || >3.1.4" "<3.1.4 || >=3.1.4.0",
normaliseExample "^>=1.2 && <2.0 || ^>=2.0" "^>=1.2 || ^>=2.0",
normaliseExample "^>=1.2 && <3.0 || ^>=2.0" "^>=1.2 || ^>=2.0",
normaliseExample "^>=1.2 || ^>=2.0 && <3" "^>=1.2 || ^>=2.0",
normaliseExample "(^>=1.2 || ^>=2.0) && <3" "^>=1.2 && <2.0 || ^>=2.0 && <3",
normaliseExample "(>=1.2 || >=2.0) && <3" ">=1.2 && <3",
normaliseExample "<1 || >=1.0" "<1 || >=1.0",
normaliseExample "<=1 || >=1.0" ">=0",
normaliseExample ">0 && <0.0" "<0",
normaliseExample
"^>=1.5.0.1 || ^>=1.6.0.1 || >=1.9 && <1.13"
"^>=1.5.0.1 || ^>=1.6.0.1 || ^>=1.9 || ^>=1.10 || ^>=1.11 ||^>=1.12",
cannotNormaliseExample "^>=0 && >=0.1" IntervalsEmpty,
testProperty "involutive" normaliseInvolutive,
testProperty "complete" normaliseComplete,
testProperty "complete_lax" normaliseCompleteLax,
testProperty "involutive ex1" $
normaliseInvolutive $
intersectVersionRanges (majorBoundVersion (mkVersion [3])) (laterVersion (mkVersion [3]))
]
]
normaliseExample :: String -> String -> TestTree
normaliseExample input expected = testCase input $ do
input' <- either fail return $ eitherParsec input
expected' <- either fail return $ eitherParsec expected
VersionInterval.normaliseVersionRange input' @?= Right expected'
cannotNormaliseExample :: String -> ConversionProblem -> TestTree
cannotNormaliseExample input problem = testCase ("cannot " ++ input) $ do
input' <- either fail return $ eitherParsec input
VersionInterval.normaliseVersionRange input' @?= Left problem
-------------------------------------------------------------------------------
-- Intersect
-------------------------------------------------------------------------------
intersectComplete :: VersionInterval -> VersionInterval -> Version -> QC.Property
intersectComplete a b v =
QC.counterexample ("intersection: " ++ show (ab, inA, inB)) $ (inA && inB) === inAB
where
ab = intersectInterval a b
inA = withinInterval v a
inB = withinInterval v b
inAB = maybe False (withinInterval v) ab
intersectCompleteLax :: VersionInterval -> VersionInterval -> Version -> QC.Property
intersectCompleteLax a b v =
QC.counterexample ("intersection: " ++ show (ab, inA, inB)) $ (inA && inB) === inAB
where
ab = intersectInterval a b
inA = withinIntervalLax v a
inB = withinIntervalLax v b
inAB = maybe False (withinIntervalLax v) ab
-------------------------------------------------------------------------------
-- Stage 1
-------------------------------------------------------------------------------
stage1_valid :: VersionRange -> QC.Property
stage1_valid vr = QC.counterexample ("stage1: " ++ show is) $ QC.property $ all validVersionInterval is
where
is = stage1 id vr
stage1_complete :: VersionRange -> Version -> QC.Property
stage1_complete vr v = QC.counterexample ("stage1: " ++ show is) $ withinRange v vr === any (withinInterval v) is
where
is = stage1 id vr
stage1_complete_lax :: VersionRange -> Version -> QC.Property
stage1_complete_lax vr v = QC.counterexample ("stage1: " ++ show is) $ withinRangeLax v vr === any (withinIntervalLax v) is
where
is = stage1 id vr
-------------------------------------------------------------------------------
-- Stage 2
-------------------------------------------------------------------------------
stage2_valid :: [VersionInterval] -> QC.Property
stage2_valid is' = QC.counterexample ("stage2: " ++ show is) $ QC.property $ all validVersionInterval is
where
is = stage2 is'
stage2_involutive :: [VersionInterval] -> QC.Property
stage2_involutive is' = is1 === is2
where
is1 = stage2 is'
is2 = stage2 is1
stage2_complete :: [VersionInterval] -> Version -> QC.Property
stage2_complete is' v = QC.counterexample ("stage2: " ++ show is) $ any (withinInterval v) is' === any (withinInterval v) is
where
is = stage2 is'
stage2_complete_lax :: [VersionInterval] -> Version -> QC.Property
stage2_complete_lax is' v = QC.counterexample ("stage2: " ++ show is) $ any (withinIntervalLax v) is' === any (withinIntervalLax v) is
where
is = stage2 is'
-------------------------------------------------------------------------------
-- Stage 3
-------------------------------------------------------------------------------
stage3_valid :: [VersionInterval] -> QC.Property
stage3_valid is' = QC.counterexample ("stage3: " ++ show is) $ QC.property $ all validVersionInterval is
where
is = stage3 (stage2 is')
stage3_involutive :: [VersionInterval] -> QC.Property
stage3_involutive is' = is1 === is2
where
is1 = stage3 (stage2 is')
is2 = stage3 is1
stage3_complete :: [VersionInterval] -> Version -> QC.Property
stage3_complete is' v = QC.counterexample ("stage3: " ++ show is) $ any (withinInterval v) is' === any (withinInterval v) is
where
is = stage3 (stage2 is')
stage3_complete_lax :: [VersionInterval] -> Version -> QC.Property
stage3_complete_lax is' v = QC.counterexample ("stage3: " ++ show is) $ any (withinIntervalLax v) is' === any (withinIntervalLax v) is
where
is = stage3 (stage2 is')
-------------------------------------------------------------------------------
-- Normalise
-------------------------------------------------------------------------------
normaliseInvolutive :: VersionRange -> QC.Property
normaliseInvolutive vr = vr1 === vr2
where
vr1 = VersionInterval.normaliseVersionRange vr
vr2 = VersionInterval.normaliseVersionRange =<< vr1
normaliseComplete :: VersionRange -> Version -> QC.Property
normaliseComplete vr v = case VersionInterval.normaliseVersionRange vr of
Left _ -> QC.property True
Right vr' -> QC.counterexample ("normalised: " ++ show vr') $ withinRange v vr === withinRange v vr'
normaliseCompleteLax :: VersionRange -> Version -> QC.Property
normaliseCompleteLax vr v = case VersionInterval.normaliseVersionRange vr of
Left _ -> QC.property True
Right vr' -> QC.counterexample ("normalised: " ++ show vr') $ withinRangeLax v vr === withinRangeLax v vr'
-------------------------------------------------------------------------------
-- Predicates
-------------------------------------------------------------------------------
withinInterval :: Version -> VersionInterval -> Bool
withinInterval v (VI l m u) = viGreater l && viLessM m && viLess u
where
viGreater (LB v') = v >= v'
viLessM NoMB = True
viLessM (MB v') = v < v'
viLess NoUB = True
viLess (UB v') = v < v'
withinIntervalLax :: Version -> VersionInterval -> Bool
withinIntervalLax v (VI l _ u) = viGreater l && viLess u
where
viGreater (LB v') = v >= v'
viLess NoUB = True
viLess (UB v') = v < v'
withinRangeLax :: Version -> VersionRange -> Bool
withinRangeLax v vr = withinRange v (transformCaretUpper vr)
-------------------------------------------------------------------------------
-- QC instances
-------------------------------------------------------------------------------
instance Arbitrary Version where
arbitrary =
QC.oneof
[ mkVersion <$> replicateM d vDigit
| d <- [1 .. 4]
]
where
vDigit :: QC.Gen Int
vDigit = QC.elements [0 .. 9]
shrink v =
[ mkVersion v'
| v' <- shrink (versionNumbers v),
not (null v')
]
instance Arbitrary VersionRange where
arbitrary =
let intToDouble :: Int -> Double
intToDouble = fromIntegral
in QC.sized $ genVersionRange . round . logBase 2 . intToDouble . max 1
shrink vr = case projectVersionRange vr of
LaterVersionF v -> laterVersion <$> shrink v
OrLaterVersionF v -> orLaterVersion <$> shrink v
EarlierVersionF v -> earlierVersion <$> shrink v
OrEarlierVersionF v -> orEarlierVersion <$> shrink v
ThisVersionF v -> thisVersion <$> shrink v
MajorBoundVersionF v -> majorBoundVersion <$> shrink v
UnionVersionRangesF l r -> l : r : fmap (uncurry unionVersionRanges) (shrink (l, r))
IntersectVersionRangesF l r -> l : r : fmap (uncurry intersectVersionRanges) (shrink (l, r))
genVersionRange :: Int -> QC.Gen VersionRange
genVersionRange n
| n <= 1 =
QC.oneof
[ pure anyVersion,
thisVersion <$> arbitrary,
notThisVersion <$> arbitrary,
laterVersion <$> arbitrary,
earlierVersion <$> arbitrary,
orLaterVersion <$> arbitrary,
orEarlierVersion <$> arbitrary,
withinVersion <$> arbitrary,
majorBoundVersion <$> arbitrary
]
| otherwise = do
l <- QC.chooseInt (1, n - 1)
let r = n - l
QC.oneof
[ unionVersionRanges <$> genVersionRange l <*> genVersionRange r,
intersectVersionRanges <$> genVersionRange l <*> genVersionRange r
]
instance Arbitrary VersionInterval where
arbitrary = QC.suchThat (VI <$> arbitrary <*> arbitrary <*> arbitrary) validVersionInterval
shrink (VI l m u) =
[ vi
| (l', m', u') <- shrink (l, m, u),
let vi = VI l' m' u',
validVersionInterval vi
]
instance Arbitrary LB where
arbitrary = LB <$> arbitrary
shrink (LB v) = LB <$> shrink v
instance Arbitrary UB where
arbitrary =
QC.oneof
[ pure NoUB,
UB <$> arbitrary
]
shrink NoUB = []
shrink (UB v) = NoUB : map UB (shrink v)
instance Arbitrary MB where
arbitrary =
QC.oneof
[ pure NoMB,
MB <$> arbitrary
]
shrink NoMB = []
shrink (MB v) = NoMB : map MB (shrink v)