Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-30 19:54:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

further on compression, further yet to go

Browse Source
This commit is contained in:
Keagan McClelland
2022-06-13 17:54:07 -06:00
parent e025d4c263
commit d13ef4a465
2 changed files with 298 additions and 232 deletions
Download Patch File Download Diff File Expand all files Collapse all files

379
src/Lib/Types/Emver.hs
View File

@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
-- | -- |
@@ -71,6 +72,7 @@ import Startlude (
seq, seq,
show, show,
snd, snd,
toS,
($), ($),
($>), ($>),
(&&), (&&),
@@ -84,6 +86,7 @@ import Startlude (
import Control.Monad.Fail (fail) import Control.Monad.Fail (fail)
import Data.Aeson (ToJSONKey) import Data.Aeson (ToJSONKey)
import Data.Attoparsec.Text qualified as Atto import Data.Attoparsec.Text qualified as Atto
import Data.String.Interpolate.IsString (i)
import Data.Text qualified as T import Data.Text qualified as T
import GHC.Base (Ord (..), error) import GHC.Base (Ord (..), error)
import GHC.Read qualified as GHC ( import GHC.Read qualified as GHC (
@@ -225,6 +228,10 @@ data VersionRange
deriving (Eq) deriving (Eq)
instance IsString VersionRange where
fromString = either error id . Atto.parseOnly parseRange . toS
instance NFData VersionRange where instance NFData VersionRange where
rnf (Conj a b) = rnf a `seq` rnf b rnf (Conj a b) = rnf a `seq` rnf b
rnf (Disj a b) = rnf a `seq` rnf b rnf (Disj a b) = rnf a `seq` rnf b
@@ -254,180 +261,210 @@ reduce :: VersionRange -> VersionRange
reduce Any = Any reduce Any = Any
reduce None = None reduce None = None
reduce vr@(Anchor _ _) = vr reduce vr@(Anchor _ _) = vr
-- conj units reduce orig@(Conj x y) = case (reduce x, reduce y) of
reduce (Conj Any vr) = vr -- conj units
reduce (Conj vr Any) = vr (Any, vr) -> reduce vr
-- conj annihilators (vr, Any) -> reduce vr
reduce (Conj None _) = None -- conj annihilators
reduce (Conj _ None) = None (None, _) -> None
-- disj annihilators (_, None) -> None
reduce (Disj Any _) = Any -- primitive conjunction reduction
reduce (Disj _ Any) = Any (a@(Anchor op pt), b@(Anchor op' pt')) -> case compare pt pt' of
-- disj units -- conj commutes so we can make normalization order the points
reduce (Disj None vr) = vr GT -> reduce (Conj b a)
reduce (Disj vr None) = vr -- trivial cases where the points are identical
-- primitive conjunction reduction EQ -> case (isRight op, isRight op == isRight op', primOrd op == primOrd op') of
reduce x@(Conj a@(Anchor op pt) b@(Anchor op' pt')) = case compare pt pt' of -- the theorems found here will elucidate what is going on
-- conj commutes so we can make normalization order the points -- https://faculty.uml.edu/klevasseur/ads/s-laws-of-set-theory.html
GT -> reduce (Conj b a) -- conj idempodent law: these sets are identical
-- trivial cases where the points are identical (_, True, True) -> a
EQ -> case (isRight op, isRight op == isRight op', primOrd op == primOrd op') of -- conj complement law: these sets are opposites
-- the theorems found here will elucidate what is going on (_, False, True) -> None
-- https://faculty.uml.edu/klevasseur/ads/s-laws-of-set-theory.html -- inequality incompatibility: these sets do not overlap
-- conj idempodent law: these sets are identical (True, True, False) -> None
(_, True, True) -> a -- conj absorption law (left): the left set is more specific
-- conj complement law: these sets are opposites (True, False, False) -> a
(_, False, True) -> None -- conj absorption law (right): the right set is more specific
-- inequality incompatibility: these sets do not overlap (False, False, False) -> b
(True, True, False) -> None -- all that is left is to intersect these sets. In every one of these cases the intersection can be expressed
-- conj absorption law (right): the right set is more specific -- as exactly the ordering that is not mentioned by the other two.
(False, True, False) -> b (False, True, False) -> Anchor (Right $ complement (primOrd op) (primOrd op')) pt
-- conj absorption law (left): the left set is more specific -- pattern reduction, throughout you will see the following notation (primarily for visualization purposes)
(True, False, False) -> a -- o: this means 'eq'
-- all that is left is to intersect these sets. In every one of these cases the intersection can be expressed -- >: this means 'lt' or 'lte'
-- as exactly the ordering that is not mentioned by the other two. -- <: this means 'gt' or 'gte'
(False, False, False) -> Anchor (Right $ complement (primOrd op) (primOrd op')) pt -- x: this means 'neq'
-- pattern reduction, throughout you will see the following notation (primarily for visualization purposes) -- you may find this notation a bit odd, after all the less than and greater than signs seem backwards, you can see
-- o: this means 'eq' -- it more clearly by viewing them as area dividers. the wide part of the angle represents this concept of 'faces'.
-- >: this means 'lt' or 'lte' -- By this analogy, > faces left, < faces right, x faces both left and right, and o faces neither left nor right
-- <: this means 'gt' or 'gte' -- it turns out that we only care about the inner two components: the right facing component of the lesser point,
-- x: this means 'neq' -- and the left facing component of the greater point. Why is left as an exercise to the reader.
-- you may find this notation a bit odd, after all the less than and greater than signs seem backwards, you can see LT -> case (fr op, fl op') of
-- it more clearly by viewing them as area dividers. the wide part of the angle represents this concept of 'faces'. -- Annihilator patterns: oo, ><, o<, >o
-- By this analogy, > faces left, < faces right, x faces both left and right, and o faces neither left nor right (False, False) -> None
-- it turns out that we only care about the inner two components: the right facing component of the lesser point, -- Left specific patterns: ox, o>, >x, >>
-- and the left facing component of the greater point. Why is left as an exercise to the reader. (False, True) -> a
LT -> case (fr op, fl op') of -- Right specific patterns: xo, <o, x<, <<
-- Annihilator patterns: oo, ><, o<, >o (True, False) -> b
(False, False) -> None -- Irreducible patterns: <>, <x, x>, xx
-- Left specific patterns: ox, o>, >x, >> (True, True) -> orig
(False, True) -> a
-- Right specific patterns: xo, <o, x<, <<
(True, False) -> b
-- Irreducible patterns: <>, <x, x>, xx
(True, True) -> x
-- primitive disjunction reduction
reduce x@(Disj a@(Anchor op pt) b@(Anchor op' pt')) = case compare pt pt' of
GT -> reduce (Disj b a)
EQ -> case (isRight op, isRight op == isRight op', primOrd op == primOrd op') of
-- idempotence
(_, True, True) -> a
-- complement
(_, False, True) -> Any
-- union these sets
(True, True, False) -> Anchor (Left $ complement (primOrd op) (primOrd op')) pt
-- disj absorption left: the left set is more general
(False, False, False) -> a
-- disj absorption right: the right set is more general
(True, False, False) -> b
-- inequality hypercompatibility: these sets are universal
(False, True, False) -> Any
LT -> case (fr op, fl op') of
-- Annihilator patterns: <>, <x, x>, xx
(True, True) -> Any
-- Left general patterns: x<, xo, <o, <<
(True, False) -> a
-- Right general patterns: >x, ox, o>, >>
(False, True) -> b
-- Irreducible patterns: >< >o o< oo
(False, False) -> x
reduce (Conj x y) = case (reduce x, reduce y) of
(a@(Anchor opa pta), Conj b@(Anchor opb ptb) c@(Anchor opc ptc)) -> (a@(Anchor opa pta), Conj b@(Anchor opb ptb) c@(Anchor opc ptc)) ->
case (compare pta ptb, compare pta ptc) of case (compare pta ptb, compare pta ptc) of
-- impossible because all anchors of equal versions reduce
(GT, GT) ->
-- here we are to the right of an irreducible conj
_
(LT, LT) ->
-- here we are to the left of an irreducible conj
_
(GT, LT) ->
-- here we are in the middle of an irreducible conj
_
-- eq patterns reduce so prioritize conj'ing those -- eq patterns reduce so prioritize conj'ing those
(EQ, LT) -> conj (conj a b) c (EQ, LT) -> conj (conj a b) c
(GT, EQ) -> conj b (conj a c) (GT, EQ) -> conj b (conj a c)
(_, GT) -> error "bug in anchor order normalization" -- here we are to the right of an irreducible conj, so we try to reduce with the right side
(LT, _) -> error "bug in anchor order normalization" (GT, GT) -> case conj c a of
(EQ, EQ) -> error "bug in equal anchor version reduction" -- cascade if successful
_ -> _ cca@(Anchor _ _) -> conj b cca
-- left distribute -- otherwise we move xs out right
reduce (Conj a (Disj p q)) = disj (conj a p) (conj a q) -- we know for sure at this point that the opc is x
-- right distribute _ -> case (fl opb, fr opa) of
reduce (Conj (Disj p q) b) = disj (conj b p) (conj b q) (True, True) -> Conj b (Conj c a) -- xxx: x (xx)
reduce x@(Conj a@(Conj _ _) b@(Anchor _ _)) = conj b a (True, False) -> Conj a (Conj b c) -- xx>: > (xx)
reduce x@(Conj a@(Anchor _ _) b@(Conj _ _)) = x (False, True) -> Conj b (Conj c a) -- <xx: < (xx)
reduce x@(Conj a@(Anchor op pt) b@(Conj p q)) = case (p, q) of (False, False) -> Conj (Conj b a) c -- <x>: (<>) x
((Anchor opP ptP), (Anchor opQ ptQ)) -> -- here we are to the left of an irreducible conj, so we try to reduce the left side
if ptP >= ptQ (LT, LT) -> case conj a b of
then bail -- cascade if successful
else case (opP, opQ) of cab@(Anchor _ _) -> conj cab c
-- diamonds <> -- otherwise we move xs out right
(Right GT, Right LT) -> -- we know for sure that opb is x
if _ -> case (fl opa, fr opc) of
| (op == lt || op == leq || op == eq) && pt <= ptP -> None (True, True) -> Conj a (Conj b c) -- xxx: x (xx)
| (op == gt || op == geq || op == neq) && pt <= ptP -> b (True, False) -> Conj c (Conj a b) -- xx>: > (xx)
| (op == lt || op == leq || op == neq) && pt >= ptQ -> b (False, True) -> Conj a (Conj b c) -- <xx: < (xx)
| (op == gt || op == geq || op == eq) && pt >= ptQ -> None (False, False) -> Conj (Conj a c) b -- <x>: (<>) x
| (op == lt || op == leq) -> Conj p a -- here we are in the middle of an irreducible conj
| (op == gt || op == geq) -> Conj a q (GT, LT)
| op == eq -> a -- <x> <xx xx> xxx all irreducible
| op == neq -> Conj b a | opa == neq -> conj b (conj a c)
| otherwise -> x -- if there is a remaining left face component it will reduce with the right side
(Left LT, Right LT) -> | fl opa -> conj b (conj a c)
if -- corollary
| (op == lt || op == leq || op == eq) && pt < ptP -> None | fr opa -> conj (conj b a) c
| (op == gt || op == geq || op == neq) && pt < ptP -> b -- only remaining case is eq, which subsumes both sides
| op == lt && pt == ptP -> None | otherwise -> a
| op == leq && pt == ptP -> Anchor (Right EQ) pt -- impossible because all anchors of equal versions reduce
| op == eq && pt == ptP -> a (EQ, EQ) -> error [i|bug in equal anchor version reduction: #{orig} -> #{a}, #{b}, #{c}|]
| op == gt && pt == ptP -> Conj a q -- ordinarily we reorder things so the lesser point is on the left
| op == geq && pt == ptP -> b -- the only exception to this is the accumulation of x's on the right
| op == neq && pt == ptP -> Conj (Anchor (Right GT) pt) q -- so these cases should be impossible
| (op == geq || op == neq) && pt == ptP -> b _
| (op == lt || op == leq || op == neq) && pt >= ptQ -> b | opb == neq && opc == neq -> orig
| (op == gt || op == geq || op == eq) && pt >= ptQ -> None | otherwise -> error $ [i|bug in anchor order normalization: #{orig} -> #{a}, #{b}, #{c}|]
| (op == lt || op == leq) -> Conj p a (x'@(Conj (Anchor _ _) (Anchor _ _)), y'@(Anchor _ _)) -> conj y' x'
| (op == gt || op == geq) -> Conj a q -- distribute right
| op == eq -> a (x', Disj p q) -> disj (conj x' p) (conj x' q)
| op == neq -> Conj b a -- distribute left
| otherwise -> x (Disj p q, y') -> disj (conj p y') (conj q y')
(Right GT, Left GT) -> -- insert anchor into accumulation tree
if (a@(Anchor opa pta), Conj b@(Anchor opb ptb) at@(Conj atl atr)) -> error "TODO manage accumulation trees"
| (op == lt || op == leq || op == eq) && pt <= ptP -> None -- reconcile free anchor with essential anchors in accumulation tree
| (op == gt || op == geq || op == neq) && pt <= ptP -> b (a@(Anchor opa _), Conj (Conj b@(Anchor _ _) c@(Anchor _ _)) r) -> case (fl opa, fr opa) of
| (op == gt || op == geq || op == eq) && pt > ptQ -> None (True, True) -> Conj (Conj b c) (conj a r)
| (op == lt || op == leq || op == neq) && pt > ptQ -> b (True, False) -> Conj (Conj b (conj a c)) r
| op == lt && pt == ptQ -> Conj p a (False, True) -> Conj (Conj (conj b a) c) r
| op == leq && pt == ptQ -> b (False, False) -> a
| op == eq && pt == ptQ -> a (x'@(Conj (Conj _ _) (Anchor _ _)), y'@(Anchor _ _)) -> conj y' x'
| op == gt && pt == ptQ -> None (Conj a@(Anchor _ _) b@(Anchor _ _), y'@(Conj _ _)) -> conj a (conj b y')
| op == geq && pt == ptQ -> Anchor (Right EQ) pt (x', y') -> error [i|missing conj case: #{orig} -> #{x'}, #{y'}|]
| op == neq && pt == ptQ -> Conj p (Anchor lt pt) reduce orig@(Disj x y) = case (reduce x, reduce y) of
| (op == gt || op == geq) -> Conj a q -- disj annihilators
| (op == lt || op == leq) -> Conj p a (Any, _) -> Any
| op == eq -> a (_, Any) -> Any
| op == neq -> Conj b a -- disj units
| otherwise -> x (None, vr) -> reduce vr
(Left LT, Left GT) -> (vr, None) -> reduce vr
if -- primitive disj reduction
| (op == lt || op == leq || op == eq) && pt < ptP -> None (a@(Anchor op pt), b@(Anchor op' pt')) -> case compare pt pt' of
| (op == gt || op == geq || op == neq) && pt < ptP -> b GT -> reduce (Disj b a)
| otherwise -> x EQ -> case (isRight op, isRight op == isRight op', primOrd op == primOrd op') of
-- fish left <x -- idempotence
(Right GT, Left EQ) -> x (_, True, True) -> a
(Left LT, Left EQ) -> x -- complement
-- fish right x> (_, False, True) -> Any
(Left EQ, Right LT) -> x -- union these sets
(Left EQ, Left GT) -> x (True, True, False) -> Anchor (Left $ complement (primOrd op) (primOrd op')) pt
-- dead eyes xx -- disj absorption left: the left set is more general
(Left EQ, Left EQ) -> x (False, False, False) -> a
-- all other states are unstable for conj -- disj absorption right: the right set is more general
_ -> bail (True, False, False) -> b
_ -> x -- inequality hypercompatibility: these sets are universal
where (False, True, False) -> Any
bail = reduce (Conj a (reduce b)) LT -> case (fr op, fl op') of
reduce rest = rest -- Annihilator patterns: <>, <x, x>, xx
(True, True) -> Any
-- Left general patterns: x<, xo, <o, <<
(True, False) -> a
-- Right general patterns: >x, ox, o>, >>
(False, True) -> b
-- Irreducible patterns: >< >o o< oo
(False, False) -> x
(a@(Anchor opa pta), Disj b@(Anchor opb ptb) c@(Anchor opc ptc)) -> case (compare pta ptb, compare pta ptc) of
-- eq patterns reduce so prioritize disj'ing those
(EQ, LT) -> disj (disj a b) c
(GT, EQ) -> disj b (disj a c)
-- here we are to the right of an irreducible conj, so we try to reduce with the right side
(GT, GT) -> case disj c a of
-- cascade if successful
dca@(Anchor _ _) -> disj b dca
-- otherwise we move o's out right
-- we know for sure at this point that the opc is o
_ -> case (fl opb, fr opa) of
(True, True) -> Disj (Disj b a) c -- >o<: (><) o
(True, False) -> Disj b (Disj c a) -- >oo: > (oo)
(False, True) -> Disj a (Disj b c) -- oo<: < (oo)
(False, False) -> Disj b (Disj c a) -- ooo: o (oo)
-- here we are to the left of an irreducible conj, so we try to reduce the left side
(LT, LT) -> case disj a b of
-- -- cascade if successful
dab@(Anchor _ _) -> disj dab c
-- otherwise we move xs out right
-- we know for sure that opb is o
_ -> case (fl opa, fr opc) of
(True, True) -> Disj (Disj a c) b -- >o<: (><) o
(True, False) -> Disj a (Disj b c) -- >oo: > (oo)
(False, True) -> Disj c (Disj a b) -- oo<: < (oo)
(False, False) -> Disj a (Disj b c) -- ooo: o (oo)
-- here we are in the middle of an irreducible conj
(GT, LT)
-- >o< >oo oo< ooo all irreducible
| opa == eq -> disj b (disj a c)
-- if there is a remaining left face component it will reduce with the left side
| fl opa -> disj (disj b a) c
-- corollary
| fr opa -> disj b (disj a c)
-- only remaining case is neq, which subsumes both sides
| otherwise -> a
-- impossible because all anchors of equal versions reduce
(EQ, EQ) -> error [i|bug in equal anchor version reduction: #{orig} -> #{a}, #{b}, #{c}|]
-- ordinarily we reorder things so the lesser point is on the left
-- the only exception to this is the accumulation of x's on the right
-- so these cases should be impossible
_
| opb == eq && opc == eq -> orig
| otherwise -> error $ [i|bug in anchor order normalization: #{orig} -> #{a}, #{b}, #{c}|]
(x'@(Disj (Anchor _ _) (Anchor _ _)), y'@(Anchor _ _)) -> disj y' x'
(a@(Anchor opa pta), y'@(Conj b@(Anchor opb ptb) c@(Anchor opc ptc))) ->
case (compare pta ptb, compare pta ptc) of
(GT, GT) -> if fl opa then a else Disj y' a
(LT, LT) -> if fr opa then a else Disj a y'
(GT, LT) -> case (fl opa, fr opa) of
(True, True) -> Any
(True, False) -> c
(False, True) -> b
(False, False) -> y'
(EQ, EQ) -> error [i|bug in equal anchor version reduction: #{orig} -> #{a}, #{b}, #{c}|]
(EQ, _) -> error "TODO1"
(_, EQ) -> error "TODO2"
(LT, GT) -> error [i|bug in anchor order normalization: #{orig} -> #{a}, #{b}, #{c}|]
(x'@(Conj _ _), y'@(Anchor _ _)) -> disj y' x'
(Conj _ _, Conj _ _) -> error "Disj (Conj _ _) (Conj _ _)"
(Conj _ _, _) -> error "Disj (Conj _ _) _"
(_, Conj _ _) -> error "Disj _ (Conj _ _)"
(Disj _ _, Disj _ _) -> error "Disj (Disj _ _) (Disj _ _)"
(x', y') -> error [i|missing disj case: #{orig} -> #{x'}, #{y'}|]
exactly :: Version -> VersionRange exactly :: Version -> VersionRange
@@ -460,14 +497,14 @@ paren = mappend "(" . flip mappend ")"
newtype AnyRange = AnyRange {unAnyRange :: VersionRange} newtype AnyRange = AnyRange {unAnyRange :: VersionRange}
instance Semigroup AnyRange where instance Semigroup AnyRange where
(<>) = AnyRange <<$>> disj `on` unAnyRange (<>) = AnyRange <<$>> Disj `on` unAnyRange
instance Monoid AnyRange where instance Monoid AnyRange where
mempty = AnyRange None mempty = AnyRange None
newtype AllRange = AllRange {unAllRange :: VersionRange} newtype AllRange = AllRange {unAllRange :: VersionRange}
instance Semigroup AllRange where instance Semigroup AllRange where
(<>) = AllRange <<$>> conj `on` unAllRange (<>) = AllRange <<$>> Conj `on` unAllRange
instance Monoid AllRange where instance Monoid AllRange where
mempty = AllRange Any mempty = AllRange Any

151
test/Lib/Types/EmverProp.hs
View File

@@ -1,15 +1,19 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Lib.Types.EmverProp where module Lib.Types.EmverProp where
import Startlude hiding ( Any import Startlude hiding (
, reduce 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 :: MonadGen m => m Version
versionGen = do versionGen = do
@@ -19,118 +23,137 @@ versionGen = do
d <- word (linear 0 30) d <- word (linear 0 30)
pure $ Version (a, b, c, d) pure $ Version (a, b, c, d)
rangeGen :: MonadGen m => m VersionRange rangeGen :: MonadGen m => m VersionRange
rangeGen = choice [pure None, pure Any, anchorGen, disjGen, conjGen] rangeGen = choice [pure None, pure Any, anchorGen, disjGen, conjGen]
anchorGen :: MonadGen m => m VersionRange anchorGen :: MonadGen m => m VersionRange
anchorGen = do anchorGen = do
c <- element [LT, EQ, GT] c <- element [LT, EQ, GT]
f <- element [Left, Right] f <- element [Left, Right]
Anchor (f c) <$> versionGen Anchor (f c) <$> versionGen
conjGen :: MonadGen m => m VersionRange conjGen :: MonadGen m => m VersionRange
conjGen = liftA2 Conj rangeGen rangeGen conjGen = liftA2 Conj rangeGen rangeGen
disjGen :: MonadGen m => m VersionRange disjGen :: MonadGen m => m VersionRange
disjGen = liftA2 Disj rangeGen rangeGen disjGen = liftA2 Disj rangeGen rangeGen
prop_conjAssoc :: Property prop_conjAssoc :: Property
prop_conjAssoc = property $ do prop_conjAssoc = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
c <- forAll rangeGen c <- forAll rangeGen
obs <- forAll versionGen 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
prop_conjCommut = property $ do prop_conjCommut = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
obs <- forAll versionGen 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
prop_disjAssoc = property $ do prop_disjAssoc = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
c <- forAll rangeGen c <- forAll rangeGen
obs <- forAll versionGen 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
prop_disjCommut = property $ do prop_disjCommut = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
obs <- forAll versionGen 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
prop_anyIdentConj = property $ do prop_anyIdentConj = property $ do
a <- forAll rangeGen a <- forAll rangeGen
obs <- forAll versionGen obs <- forAll versionGen
obs <|| conj Any a === obs <|| a obs <|| Conj Any a === obs <|| a
prop_noneIdentDisj :: Property prop_noneIdentDisj :: Property
prop_noneIdentDisj = property $ do prop_noneIdentDisj = property $ do
a <- forAll rangeGen a <- forAll rangeGen
obs <- forAll versionGen obs <- forAll versionGen
obs <|| disj None a === obs <|| a obs <|| Disj None a === obs <|| a
prop_noneAnnihilatesConj :: Property prop_noneAnnihilatesConj :: Property
prop_noneAnnihilatesConj = property $ do prop_noneAnnihilatesConj = property $ do
a <- forAll rangeGen a <- forAll rangeGen
obs <- forAll versionGen obs <- forAll versionGen
obs <|| conj None a === obs <|| None obs <|| Conj None a === obs <|| None
prop_anyAnnihilatesDisj :: Property prop_anyAnnihilatesDisj :: Property
prop_anyAnnihilatesDisj = property $ do prop_anyAnnihilatesDisj = property $ do
a <- forAll rangeGen a <- forAll rangeGen
obs <- forAll versionGen obs <- forAll versionGen
obs <|| disj Any a === obs <|| Any obs <|| Disj Any a === obs <|| Any
prop_conjDistributesOverDisj :: Property prop_conjDistributesOverDisj :: Property
prop_conjDistributesOverDisj = property $ do prop_conjDistributesOverDisj = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
c <- forAll rangeGen c <- forAll rangeGen
obs <- forAll versionGen 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
prop_disjDistributesOverConj = property $ do prop_disjDistributesOverConj = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
c <- forAll rangeGen c <- forAll rangeGen
obs <- forAll versionGen 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
prop_anyAcceptsAny = property $ do prop_anyAcceptsAny = property $ do
obs <- forAll versionGen obs <- forAll versionGen
assert $ obs <|| Any assert $ obs <|| Any
prop_noneAcceptsNone :: Property prop_noneAcceptsNone :: Property
prop_noneAcceptsNone = property $ do prop_noneAcceptsNone = property $ do
obs <- forAll versionGen obs <- forAll versionGen
assert . not $ obs <|| None assert . not $ obs <|| None
prop_conjBoth :: Property prop_conjBoth :: Property
prop_conjBoth = property $ do prop_conjBoth = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
obs <- forAll versionGen 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
prop_disjEither = property $ do prop_disjEither = property $ do
a <- forAll rangeGen a <- forAll rangeGen
b <- forAll rangeGen b <- forAll rangeGen
obs <- forAll versionGen obs <- forAll versionGen
(obs <|| disj a b) === (obs <|| a || obs <|| b) (obs <|| Disj a b) === (obs <|| a || obs <|| b)
prop_rangeParseRoundTrip :: Property prop_rangeParseRoundTrip :: Property
prop_rangeParseRoundTrip = withShrinks 0 . property $ do prop_rangeParseRoundTrip = withShrinks 0 . property $ do
a <- forAll rangeGen a <- forAll rangeGen
obs <- forAll versionGen obs <- forAll versionGen
-- we do not use 'tripping' here since 'tripping' requires equality of representation -- we do not use 'tripping' here since 'tripping' requires equality of representation
-- we only want to check equality up to OBSERVATION -- 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)) annotateShow (Atto.parseOnly parseRange (show a))
(satisfies obs <$> Atto.parseOnly parseRange (show a)) === Right (satisfies obs a) (satisfies obs <$> Atto.parseOnly parseRange (show a)) === Right (satisfies obs a)
prop_anchorLeftIsNegatedRight :: Property prop_anchorLeftIsNegatedRight :: Property
prop_anchorLeftIsNegatedRight = property $ do prop_anchorLeftIsNegatedRight = property $ do
a <- forAll anchorGen a <- forAll anchorGen
neg <- case a of neg <- case a of
Anchor (Right o) v -> pure $ Anchor (Left o) v Anchor (Right o) v -> pure $ Anchor (Left o) v
Anchor (Left o) v -> pure $ Anchor (Right o) v Anchor (Left o) v -> pure $ Anchor (Right o) v
_ -> Test.discard _ -> Test.discard
obs <- forAll versionGen obs <- forAll versionGen
obs <|| a /== obs <|| neg obs <|| a /== obs <|| neg
prop_reduceConjAnchor :: Property prop_reduceConjAnchor :: Property
prop_reduceConjAnchor = property $ do prop_reduceConjAnchor = property $ do
a <- forAll anchorGen a <- forAll anchorGen
b <- forAll anchorGen b <- forAll anchorGen
obs <- forAll versionGen 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
prop_reduceDisjAnchor = property $ do prop_reduceDisjAnchor = property $ do
a <- forAll anchorGen a <- forAll anchorGen
b <- forAll anchorGen b <- forAll anchorGen
obs <- forAll versionGen 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 :: Property
prop_reduceIdentity = withTests 1000 $ property $ do prop_reduceIdentity = withTests 2000 . withDiscards 90 $
-- a <- forAll rangeGen property $ do
a <- forAll conjGen -- a <- forAll rangeGen
obs <- forAll versionGen a <- forAll conjGen
let b = reduce a obs <- forAll versionGen
unless (b /= a) Test.discard b <- liftIO $ pure (reduce a) `catch` \e -> throwIO (e :: ErrorCall)
obs <|| a === obs <|| b unless (b /= a) Test.discard
obs <|| a === obs <|| b
tests :: IO Bool tests :: IO Bool
tests = checkParallel $ $$discover tests = checkParallel $ $$discover