mirror of
https://github.com/Start9Labs/registry.git
synced 2026-04-02 04:53:07 +00:00
further on compression, further yet to go
This commit is contained in:
Keagan McClelland
@@ -1,15 +1,19 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Lib.Types.EmverProp where
|
||||
|
||||
import Startlude hiding ( Any
|
||||
, reduce
|
||||
)
|
||||
import Startlude hiding (
|
||||
Any,
|
||||
reduce,
|
||||
)
|
||||
|
||||
import Data.Attoparsec.Text qualified as Atto
|
||||
import Hedgehog as Test
|
||||
import Hedgehog.Gen as Gen
|
||||
import Hedgehog.Range
|
||||
import Lib.Types.Emver
|
||||
import UnliftIO qualified
|
||||
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import Hedgehog as Test
|
||||
import Hedgehog.Gen as Gen
|
||||
import Hedgehog.Range
|
||||
import Lib.Types.Emver
|
||||
|
||||
versionGen :: MonadGen m => m Version
|
||||
versionGen = do
|
||||
@@ -19,118 +23,137 @@ versionGen = do
|
||||
d <- word (linear 0 30)
|
||||
pure $ Version (a, b, c, d)
|
||||
|
||||
|
||||
rangeGen :: MonadGen m => m VersionRange
|
||||
rangeGen = choice [pure None, pure Any, anchorGen, disjGen, conjGen]
|
||||
|
||||
|
||||
anchorGen :: MonadGen m => m VersionRange
|
||||
anchorGen = do
|
||||
c <- element [LT, EQ, GT]
|
||||
f <- element [Left, Right]
|
||||
Anchor (f c) <$> versionGen
|
||||
|
||||
|
||||
conjGen :: MonadGen m => m VersionRange
|
||||
conjGen = liftA2 Conj rangeGen rangeGen
|
||||
|
||||
|
||||
disjGen :: MonadGen m => m VersionRange
|
||||
disjGen = liftA2 Disj rangeGen rangeGen
|
||||
|
||||
|
||||
prop_conjAssoc :: Property
|
||||
prop_conjAssoc = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
(obs <|| conj a (conj b c)) === (obs <|| conj (conj a b) c)
|
||||
(obs <|| Conj a (Conj b c)) === (obs <|| Conj (Conj a b) c)
|
||||
|
||||
|
||||
prop_conjCommut :: Property
|
||||
prop_conjCommut = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
(obs <|| conj a b) === (obs <|| conj b a)
|
||||
(obs <|| Conj a b) === (obs <|| Conj b a)
|
||||
|
||||
|
||||
prop_disjAssoc :: Property
|
||||
prop_disjAssoc = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
(obs <|| disj a (disj b c)) === (obs <|| disj (disj a b) c)
|
||||
(obs <|| Disj a (Disj b c)) === (obs <|| Disj (Disj a b) c)
|
||||
|
||||
|
||||
prop_disjCommut :: Property
|
||||
prop_disjCommut = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
(obs <|| disj a b) === (obs <|| disj b a)
|
||||
(obs <|| Disj a b) === (obs <|| Disj b a)
|
||||
|
||||
|
||||
prop_anyIdentConj :: Property
|
||||
prop_anyIdentConj = property $ do
|
||||
a <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| conj Any a === obs <|| a
|
||||
obs <|| Conj Any a === obs <|| a
|
||||
|
||||
|
||||
prop_noneIdentDisj :: Property
|
||||
prop_noneIdentDisj = property $ do
|
||||
a <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| disj None a === obs <|| a
|
||||
obs <|| Disj None a === obs <|| a
|
||||
|
||||
|
||||
prop_noneAnnihilatesConj :: Property
|
||||
prop_noneAnnihilatesConj = property $ do
|
||||
a <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| conj None a === obs <|| None
|
||||
obs <|| Conj None a === obs <|| None
|
||||
|
||||
|
||||
prop_anyAnnihilatesDisj :: Property
|
||||
prop_anyAnnihilatesDisj = property $ do
|
||||
a <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| disj Any a === obs <|| Any
|
||||
obs <|| Disj Any a === obs <|| Any
|
||||
|
||||
|
||||
prop_conjDistributesOverDisj :: Property
|
||||
prop_conjDistributesOverDisj = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| conj a (disj b c) === obs <|| disj (conj a b) (conj a c)
|
||||
obs <|| Conj a (Disj b c) === obs <|| Disj (Conj a b) (Conj a c)
|
||||
|
||||
|
||||
prop_disjDistributesOverConj :: Property
|
||||
prop_disjDistributesOverConj = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
c <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| disj a (conj b c) === obs <|| conj (disj a b) (disj a c)
|
||||
obs <|| Disj a (Conj b c) === obs <|| Conj (Disj a b) (Disj a c)
|
||||
|
||||
|
||||
prop_anyAcceptsAny :: Property
|
||||
prop_anyAcceptsAny = property $ do
|
||||
obs <- forAll versionGen
|
||||
assert $ obs <|| Any
|
||||
|
||||
|
||||
prop_noneAcceptsNone :: Property
|
||||
prop_noneAcceptsNone = property $ do
|
||||
obs <- forAll versionGen
|
||||
assert . not $ obs <|| None
|
||||
|
||||
|
||||
prop_conjBoth :: Property
|
||||
prop_conjBoth = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
(obs <|| conj a b) === (obs <|| a && obs <|| b)
|
||||
(obs <|| Conj a b) === (obs <|| a && obs <|| b)
|
||||
|
||||
|
||||
prop_disjEither :: Property
|
||||
prop_disjEither = property $ do
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
b <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
(obs <|| disj a b) === (obs <|| a || obs <|| b)
|
||||
(obs <|| Disj a b) === (obs <|| a || obs <|| b)
|
||||
|
||||
|
||||
prop_rangeParseRoundTrip :: Property
|
||||
prop_rangeParseRoundTrip = withShrinks 0 . property $ do
|
||||
a <- forAll rangeGen
|
||||
a <- forAll rangeGen
|
||||
obs <- forAll versionGen
|
||||
-- we do not use 'tripping' here since 'tripping' requires equality of representation
|
||||
-- we only want to check equality up to OBSERVATION
|
||||
@@ -138,38 +161,44 @@ prop_rangeParseRoundTrip = withShrinks 0 . property $ do
|
||||
annotateShow (Atto.parseOnly parseRange (show a))
|
||||
(satisfies obs <$> Atto.parseOnly parseRange (show a)) === Right (satisfies obs a)
|
||||
|
||||
|
||||
prop_anchorLeftIsNegatedRight :: Property
|
||||
prop_anchorLeftIsNegatedRight = property $ do
|
||||
a <- forAll anchorGen
|
||||
a <- forAll anchorGen
|
||||
neg <- case a of
|
||||
Anchor (Right o) v -> pure $ Anchor (Left o) v
|
||||
Anchor (Left o) v -> pure $ Anchor (Right o) v
|
||||
_ -> Test.discard
|
||||
Anchor (Left o) v -> pure $ Anchor (Right o) v
|
||||
_ -> Test.discard
|
||||
obs <- forAll versionGen
|
||||
obs <|| a /== obs <|| neg
|
||||
|
||||
|
||||
prop_reduceConjAnchor :: Property
|
||||
prop_reduceConjAnchor = property $ do
|
||||
a <- forAll anchorGen
|
||||
b <- forAll anchorGen
|
||||
a <- forAll anchorGen
|
||||
b <- forAll anchorGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| reduce (conj a b) === obs <|| conj a b
|
||||
obs <|| reduce (Conj a b) === obs <|| Conj a b
|
||||
|
||||
|
||||
prop_reduceDisjAnchor :: Property
|
||||
prop_reduceDisjAnchor = property $ do
|
||||
a <- forAll anchorGen
|
||||
b <- forAll anchorGen
|
||||
a <- forAll anchorGen
|
||||
b <- forAll anchorGen
|
||||
obs <- forAll versionGen
|
||||
obs <|| reduce (disj a b) === obs <|| disj a b
|
||||
obs <|| reduce (Disj a b) === obs <|| Disj a b
|
||||
|
||||
|
||||
prop_reduceIdentity :: Property
|
||||
prop_reduceIdentity = withTests 1000 $ property $ do
|
||||
-- a <- forAll rangeGen
|
||||
a <- forAll conjGen
|
||||
obs <- forAll versionGen
|
||||
let b = reduce a
|
||||
unless (b /= a) Test.discard
|
||||
obs <|| a === obs <|| b
|
||||
prop_reduceIdentity = withTests 2000 . withDiscards 90 $
|
||||
property $ do
|
||||
-- a <- forAll rangeGen
|
||||
a <- forAll conjGen
|
||||
obs <- forAll versionGen
|
||||
b <- liftIO $ pure (reduce a) `catch` \e -> throwIO (e :: ErrorCall)
|
||||
unless (b /= a) Test.discard
|
||||
obs <|| a === obs <|| b
|
||||
|
||||
|
||||
tests :: IO Bool
|
||||
tests = checkParallel $ $$discover
|
||||
|
||||
Reference in New Issue
Block a user