module ScheduledMergesTest (tests) where

import           Control.Exception
import           Control.Monad (replicateM_, when)
import           Control.Monad.ST
import           Control.Tracer (Tracer (Tracer))
import qualified Control.Tracer as Tracer
import           Data.Foldable (find, traverse_)
import           Data.Maybe (fromJust)
import           Data.STRef
import           Text.Printf (printf)

import           ScheduledMerges as LSM

import qualified Test.QuickCheck as QC
import           Test.QuickCheck (Arbitrary (arbitrary, shrink), Property)
import           Test.QuickCheck.Exception (isDiscard)
import           Test.Tasty
import           Test.Tasty.HUnit (HasCallStack, testCase)
import           Test.Tasty.QuickCheck (QuickCheckMaxSize (..),
                     QuickCheckTests (..), testProperty, (=/=), (===))

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Unit and property tests"
    [ String -> Assertion -> TestTree
testCase String
"test_regression_empty_run" Assertion
test_regression_empty_run
    , String -> Assertion -> TestTree
testCase String
"test_merge_again_with_incoming" Assertion
test_merge_again_with_incoming
    , String -> ([[(Key, Op)]] -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"prop_union" [[(Key, Op)]] -> Property
prop_union
    , String -> [TestTree] -> TestTree
testGroup String
"T"
        [ QuickCheckTests -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Int -> QuickCheckTests
QuickCheckTests Int
1000) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$  -- super quick, run more
            String -> (T -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Arbitrary satisfies invariant" T -> Property
prop_arbitrarySatisfiesInvariant
        , QuickCheckMaxSize -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Int -> QuickCheckMaxSize
QuickCheckMaxSize Int
60) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$  -- many shrinks for huge trees
            String -> (T -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"Shrinking satisfies invariant" T -> Property
prop_shrinkSatisfiesInvariant
        ]
    , String -> (T -> InfiniteList SmallCredit -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"prop_MergingTree" T -> InfiniteList SmallCredit -> Property
prop_MergingTree
    ]

-- | Results in an empty run on level 2.
test_regression_empty_run :: IO ()
test_regression_empty_run :: Assertion
test_regression_empty_run =
    (Tracer (ST RealWorld) Event -> Assertion) -> Assertion
forall a. (Tracer (ST RealWorld) Event -> IO a) -> IO a
runWithTracer ((Tracer (ST RealWorld) Event -> Assertion) -> Assertion)
-> (Tracer (ST RealWorld) Event -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \Tracer (ST RealWorld) Event
tracer -> do
      ST RealWorld () -> Assertion
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld () -> Assertion) -> ST RealWorld () -> Assertion
forall a b. (a -> b) -> a -> b
$ do
        LSM RealWorld
lsm <- ST RealWorld (LSM RealWorld)
forall s. ST s (LSM s)
LSM.new
        let ins :: Int -> ST RealWorld ()
ins Int
k = Tracer (ST RealWorld) Event
-> LSM RealWorld -> Key -> Value -> Maybe Blob -> ST RealWorld ()
forall s.
Tracer (ST s) Event
-> LSM s -> Key -> Value -> Maybe Blob -> ST s ()
LSM.insert Tracer (ST RealWorld) Event
tracer LSM RealWorld
lsm (Int -> Key
K Int
k) (Int -> Value
V Int
0) Maybe Blob
forall a. Maybe a
Nothing
        let del :: Int -> ST RealWorld ()
del Int
k = Tracer (ST RealWorld) Event
-> LSM RealWorld -> Key -> ST RealWorld ()
forall s. Tracer (ST s) Event -> LSM s -> Key -> ST s ()
LSM.delete Tracer (ST RealWorld) Event
tracer LSM RealWorld
lsm (Int -> Key
K Int
k)
        -- run 1
        Int -> ST RealWorld ()
ins Int
0
        Int -> ST RealWorld ()
ins Int
1
        Int -> ST RealWorld ()
ins Int
2
        Int -> ST RealWorld ()
ins Int
3
        -- run 2
        Int -> ST RealWorld ()
ins Int
0
        Int -> ST RealWorld ()
ins Int
1
        Int -> ST RealWorld ()
ins Int
2
        Int -> ST RealWorld ()
ins Int
3
        -- run 3
        Int -> ST RealWorld ()
ins Int
0
        Int -> ST RealWorld ()
ins Int
1
        Int -> ST RealWorld ()
ins Int
2
        Int -> ST RealWorld ()
ins Int
3
        -- run 4, deletes all previous elements
        Int -> ST RealWorld ()
del Int
0
        Int -> ST RealWorld ()
del Int
1
        Int -> ST RealWorld ()
del Int
2
        Int -> ST RealWorld ()
del Int
3

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4,Int
4,Int
4,Int
4])
          ]

        -- run 5, results in last level merge of run 1-4
        Int -> ST RealWorld ()
ins Int
0
        Int -> ST RealWorld ()
ins Int
1
        Int -> ST RealWorld ()
ins Int
2
        Int -> ST RealWorld ()
ins Int
3

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4])
          , ([Int
4,Int
4,Int
4,Int
4], [])
          ]

        -- finish merge
        LSM RealWorld -> NominalCredit -> ST RealWorld ()
forall s. LSM s -> NominalCredit -> ST s ()
LSM.supplyMergeCredits LSM RealWorld
lsm (Int -> NominalCredit
NominalCredit Int
16)

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4])
          , ([], [Int
0])
          ]

        -- insert more data, so the empty run becomes input to a merge
        (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
101..Int
112]

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4,Int
4,Int
4,Int
4])  -- about to trigger a new last level merge
          , ([], [Int
0])
          ]

        (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
113..Int
116]

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4])
          , ([Int
4,Int
4,Int
4,Int
4], [])  -- merge started, empty run has been dropped
          ]

-- | Covers the case where a run ends up too small for a level, so it gets
-- merged again with the next incoming runs.
-- That 5-way merge gets completed by supplying credits That merge gets
-- completed by supplying credits and then becomes part of another merge.
test_merge_again_with_incoming :: IO ()
test_merge_again_with_incoming :: Assertion
test_merge_again_with_incoming =
    (Tracer (ST RealWorld) Event -> Assertion) -> Assertion
forall a. (Tracer (ST RealWorld) Event -> IO a) -> IO a
runWithTracer ((Tracer (ST RealWorld) Event -> Assertion) -> Assertion)
-> (Tracer (ST RealWorld) Event -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \Tracer (ST RealWorld) Event
tracer -> do
      ST RealWorld () -> Assertion
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld () -> Assertion) -> ST RealWorld () -> Assertion
forall a b. (a -> b) -> a -> b
$ do
        LSM RealWorld
lsm <- ST RealWorld (LSM RealWorld)
forall s. ST s (LSM s)
LSM.new
        let ins :: Int -> ST RealWorld ()
ins Int
k = Tracer (ST RealWorld) Event
-> LSM RealWorld -> Key -> Value -> Maybe Blob -> ST RealWorld ()
forall s.
Tracer (ST s) Event
-> LSM s -> Key -> Value -> Maybe Blob -> ST s ()
LSM.insert Tracer (ST RealWorld) Event
tracer LSM RealWorld
lsm (Int -> Key
K Int
k) (Int -> Value
V Int
0) Maybe Blob
forall a. Maybe a
Nothing
        -- get something to 3rd level (so 2nd level is not levelling)
        -- (needs 5 runs to go to level 2 so the resulting run becomes too big)
        (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
101..Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
+(Int
5Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
16)]

        -- also get a very small run (4 elements) to 2nd level by re-using keys
        Int -> ST RealWorld () -> ST RealWorld ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
4 (ST RealWorld () -> ST RealWorld ())
-> ST RealWorld () -> ST RealWorld ()
forall a b. (a -> b) -> a -> b
$
          (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
201..Int
200Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4]

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4,Int
4,Int
4,Int
4])     -- these runs share keys, will compact down to 4
          , ([Int
4,Int
4,Int
4,Int
4,Int
64], [])  -- this run will end up in level 3
          ]

        -- get another run to 2nd level, which the small run can be merged with
        (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
301..Int
300Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
16]

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4,Int
4,Int
4,Int
4])
          , ([Int
4,Int
4,Int
4,Int
4], [])
          , ([], [Int
80])
          ]

        -- add just one more run so the 5-way merge on 2nd level gets created
        (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
401..Int
400Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4]

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4])
          , ([Int
4,Int
4,Int
4,Int
4,Int
4], [])
          , ([], [Int
80])
          ]

        -- complete the merge (20 entries, but credits get scaled up by 1.25)
        LSM RealWorld -> NominalCredit -> ST RealWorld ()
forall s. LSM s -> NominalCredit -> ST s ()
LSM.supplyMergeCredits LSM RealWorld
lsm (Int -> NominalCredit
NominalCredit Int
16)

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4])
          , ([], [Int
20])
          , ([], [Int
80])
          ]

        -- get 3 more runs to 2nd level, so the 5-way merge completes
        -- and becomes part of a new merge.
        -- (actually 4, as runs only move once a fifth run arrives...)
        (Int -> ST RealWorld ()) -> [Int] -> ST RealWorld ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> ST RealWorld ()
ins [Int
501..Int
500Int -> Int -> Int
forall a. Num a => a -> a -> a
+(Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
16)]

        LSM RealWorld -> Int -> [([Int], [Int])] -> ST RealWorld ()
forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM RealWorld
lsm
          Int
0
          [ ([], [Int
4])
          , ([Int
4,Int
4,Int
4,Int
4], [])
          , ([Int
16,Int
16,Int
16,Int
20,Int
80], [])
          ]

-------------------------------------------------------------------------------
-- properties
--

-- | Supplying enough credits for the remaining debt completes the union merge.
prop_union :: [[(LSM.Key, LSM.Op)]] -> Property
prop_union :: [[(Key, Op)]] -> Property
prop_union [[(Key, Op)]]
kopss = [[(Key, Op)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([(Key, Op)] -> Bool) -> [[(Key, Op)]] -> [[(Key, Op)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([(Key, Op)] -> Bool) -> [(Key, Op)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Op)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[(Key, Op)]]
kopss) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
QC.==>
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
QC.ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ (Tracer (ST RealWorld) Event -> IO Property) -> IO Property
forall a. (Tracer (ST RealWorld) Event -> IO a) -> IO a
runWithTracer ((Tracer (ST RealWorld) Event -> IO Property) -> IO Property)
-> (Tracer (ST RealWorld) Event -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \Tracer (ST RealWorld) Event
tr ->
      ST RealWorld Property -> IO Property
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld Property -> IO Property)
-> ST RealWorld Property -> IO Property
forall a b. (a -> b) -> a -> b
$ do
        [LSM RealWorld]
ts <- ([(Key, Op)] -> ST RealWorld (LSM RealWorld))
-> [[(Key, Op)]] -> ST RealWorld [LSM RealWorld]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Tracer (ST RealWorld) Event
-> [(Key, Op)] -> ST RealWorld (LSM RealWorld)
forall s. Tracer (ST s) Event -> [(Key, Op)] -> ST s (LSM s)
mkTable Tracer (ST RealWorld) Event
tr) [[(Key, Op)]]
kopss
        LSM RealWorld
t <- [LSM RealWorld] -> ST RealWorld (LSM RealWorld)
forall s. [LSM s] -> ST s (LSM s)
LSM.unions [LSM RealWorld]
ts

        debt :: UnionDebt
debt@(UnionDebt Int
x) <- LSM RealWorld -> ST RealWorld UnionDebt
forall s. LSM s -> ST s UnionDebt
LSM.remainingUnionDebt LSM RealWorld
t
        UnionCredits
_ <- LSM RealWorld -> UnionCredits -> ST RealWorld UnionCredits
forall s. LSM s -> UnionCredits -> ST s UnionCredits
LSM.supplyUnionCredits LSM RealWorld
t (Int -> UnionCredits
UnionCredits Int
x)
        UnionDebt
debt' <- LSM RealWorld -> ST RealWorld UnionDebt
forall s. LSM s -> ST s UnionDebt
LSM.remainingUnionDebt LSM RealWorld
t

        Representation
rep <- LSM RealWorld -> ST RealWorld Representation
forall s. LSM s -> ST s Representation
dumpRepresentation LSM RealWorld
t
        Property -> ST RealWorld Property
forall a. a -> ST RealWorld a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> ST RealWorld Property)
-> Property -> ST RealWorld Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
QC.counterexample ((UnionDebt, UnionDebt) -> String
forall a. Show a => a -> String
show (UnionDebt
debt, UnionDebt
debt')) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
QC.conjoin
          [ UnionDebt
debt UnionDebt -> UnionDebt -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=/= Int -> UnionDebt
UnionDebt Int
0
          , UnionDebt
debt' UnionDebt -> UnionDebt -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> UnionDebt
UnionDebt Int
0
          , (MTree Int -> Bool) -> Representation -> Property
hasUnionWith MTree Int -> Bool
forall {r}. MTree r -> Bool
isCompleted Representation
rep
          ]
  where
    isCompleted :: MTree r -> Bool
isCompleted = \case
        MLeaf{} -> Bool
True
        MNode{} -> Bool
False

mkTable :: Tracer (ST s) Event -> [(LSM.Key, LSM.Op)] -> ST s (LSM s)
mkTable :: forall s. Tracer (ST s) Event -> [(Key, Op)] -> ST s (LSM s)
mkTable Tracer (ST s) Event
tr [(Key, Op)]
ks = do
    LSM s
t <- ST s (LSM s)
forall s. ST s (LSM s)
LSM.new
    Tracer (ST s) Event -> LSM s -> [(Key, Op)] -> ST s ()
forall s. Tracer (ST s) Event -> LSM s -> [(Key, Op)] -> ST s ()
LSM.updates Tracer (ST s) Event
tr LSM s
t [(Key, Op)]
ks
    LSM s -> ST s (LSM s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return LSM s
t

-------------------------------------------------------------------------------
-- tests for MergingTree
--

prop_MergingTree :: T -> QC.InfiniteList SmallCredit -> Property
prop_MergingTree :: T -> InfiniteList SmallCredit -> Property
prop_MergingTree TCompleted{} InfiniteList SmallCredit
_ = Property
forall a. a
QC.discard
prop_MergingTree (TOngoing MCompleted{}) InfiniteList SmallCredit
_ = Property
forall a. a
QC.discard
prop_MergingTree T
t InfiniteList SmallCredit
credits =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
QC.ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ (Tracer (ST RealWorld) Event -> IO Property) -> IO Property
forall a. (Tracer (ST RealWorld) Event -> IO a) -> IO a
runWithTracer ((Tracer (ST RealWorld) Event -> IO Property) -> IO Property)
-> (Tracer (ST RealWorld) Event -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \Tracer (ST RealWorld) Event
_tr ->
      ST RealWorld Property -> IO Property
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld Property -> IO Property)
-> ST RealWorld Property -> IO Property
forall a b. (a -> b) -> a -> b
$ do
        MergingTree RealWorld
tree <- T -> ST RealWorld (MergingTree RealWorld)
forall s. T -> ST s (MergingTree s)
fromT T
t
        Either String ()
res <- MergingTree RealWorld
-> [SmallCredit] -> ST RealWorld (Either String ())
forall s. MergingTree s -> [SmallCredit] -> ST s (Either String ())
go MergingTree RealWorld
tree (InfiniteList SmallCredit -> [SmallCredit]
forall a. InfiniteList a -> [a]
QC.getInfiniteList InfiniteList SmallCredit
credits)
        Property -> ST RealWorld Property
forall a. a -> ST RealWorld a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> ST RealWorld Property)
-> Property -> ST RealWorld Property
forall a b. (a -> b) -> a -> b
$
          Either String ()
res Either String () -> Either String () -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== () -> Either String ()
forall a b. b -> Either a b
Right ()
  where
    -- keep supplying until there is an error or the tree merge is completed
    go :: MergingTree s -> [SmallCredit] -> ST s (Either String ())
    go :: forall s. MergingTree s -> [SmallCredit] -> ST s (Either String ())
go MergingTree s
tree (SmallCredit Int
c : [SmallCredit]
cs) = do
        Int
c' <- Int -> MergingTree s -> ST s Int
forall s. Int -> MergingTree s -> ST s Int
LSM.supplyCreditsMergingTree Int
c MergingTree s
tree
        Invariant s () -> ST s (Either String ())
forall s a. Invariant s a -> ST s (Either String a)
evalInvariant (MergingTree s -> Invariant s ()
forall s. MergingTree s -> Invariant s ()
treeInvariant MergingTree s
tree) ST s (Either String ())
-> (Either String () -> ST s (Either String ()))
-> ST s (Either String ())
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left String
e   -> Either String () -> ST s (Either String ())
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ()
forall a b. a -> Either a b
Left String
e)
          Right () -> if Int
c' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Either String () -> ST s (Either String ())
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either String ()
forall a b. b -> Either a b
Right ())
                                else MergingTree s -> [SmallCredit] -> ST s (Either String ())
forall s. MergingTree s -> [SmallCredit] -> ST s (Either String ())
go MergingTree s
tree [SmallCredit]
cs
    go MergingTree s
_ [] = String -> ST s (Either String ())
forall a. HasCallStack => String -> a
error String
"infinite list is finite"

newtype SmallCredit = SmallCredit Credit
  deriving stock Int -> SmallCredit -> ShowS
[SmallCredit] -> ShowS
SmallCredit -> String
(Int -> SmallCredit -> ShowS)
-> (SmallCredit -> String)
-> ([SmallCredit] -> ShowS)
-> Show SmallCredit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SmallCredit -> ShowS
showsPrec :: Int -> SmallCredit -> ShowS
$cshow :: SmallCredit -> String
show :: SmallCredit -> String
$cshowList :: [SmallCredit] -> ShowS
showList :: [SmallCredit] -> ShowS
Show

instance Arbitrary SmallCredit where
  arbitrary :: Gen SmallCredit
arbitrary = Int -> SmallCredit
SmallCredit (Int -> SmallCredit) -> Gen Int -> Gen SmallCredit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
QC.chooseInt (Int
1, Int
10)
  shrink :: SmallCredit -> [SmallCredit]
shrink (SmallCredit Int
c) = [Int -> SmallCredit
SmallCredit Int
c' | Int
c' <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
c, Int
c' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]

-- simplified non-ST version of MergingTree
data T = TCompleted Run
       | TOngoing (M TreeMergeType)
       | TPendingLevel [P] (Maybe T)  -- not both empty!
       | TPendingUnion [T]  -- at least 2 children
  deriving stock Int -> T -> ShowS
[T] -> ShowS
T -> String
(Int -> T -> ShowS) -> (T -> String) -> ([T] -> ShowS) -> Show T
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> T -> ShowS
showsPrec :: Int -> T -> ShowS
$cshow :: T -> String
show :: T -> String
$cshowList :: [T] -> ShowS
showList :: [T] -> ShowS
Show

-- simplified non-ST version of PreExistingRun
data P = PRun Run
       | PMergingRun (M LevelMergeType)
  deriving stock Int -> P -> ShowS
[P] -> ShowS
P -> String
(Int -> P -> ShowS) -> (P -> String) -> ([P] -> ShowS) -> Show P
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> P -> ShowS
showsPrec :: Int -> P -> ShowS
$cshow :: P -> String
show :: P -> String
$cshowList :: [P] -> ShowS
showList :: [P] -> ShowS
Show

-- simplified non-ST version of MergingRun
data M t = MCompleted t MergeDebt Run
         | MOngoing
             t
             MergeDebt  -- debt bounded by input sizes
             MergeCredit
             [NonEmptyRun]  -- at least 2 inputs
  deriving stock Int -> M t -> ShowS
[M t] -> ShowS
M t -> String
(Int -> M t -> ShowS)
-> (M t -> String) -> ([M t] -> ShowS) -> Show (M t)
forall t. Show t => Int -> M t -> ShowS
forall t. Show t => [M t] -> ShowS
forall t. Show t => M t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall t. Show t => Int -> M t -> ShowS
showsPrec :: Int -> M t -> ShowS
$cshow :: forall t. Show t => M t -> String
show :: M t -> String
$cshowList :: forall t. Show t => [M t] -> ShowS
showList :: [M t] -> ShowS
Show

newtype NonEmptyRun = NonEmptyRun { NonEmptyRun -> Run
getNonEmptyRun :: Run }
  deriving stock Int -> NonEmptyRun -> ShowS
[NonEmptyRun] -> ShowS
NonEmptyRun -> String
(Int -> NonEmptyRun -> ShowS)
-> (NonEmptyRun -> String)
-> ([NonEmptyRun] -> ShowS)
-> Show NonEmptyRun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonEmptyRun -> ShowS
showsPrec :: Int -> NonEmptyRun -> ShowS
$cshow :: NonEmptyRun -> String
show :: NonEmptyRun -> String
$cshowList :: [NonEmptyRun] -> ShowS
showList :: [NonEmptyRun] -> ShowS
Show

invariantT :: T -> Either String ()
invariantT :: T -> Either String ()
invariantT T
t = (forall s. ST s (Either String ())) -> Either String ()
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either String ())) -> Either String ())
-> (forall s. ST s (Either String ())) -> Either String ()
forall a b. (a -> b) -> a -> b
$ do
    MergingTree s
tree <- T -> ST s (MergingTree s)
forall s. T -> ST s (MergingTree s)
fromT T
t
    Invariant s () -> ST s (Either String ())
forall s a. Invariant s a -> ST s (Either String a)
evalInvariant (MergingTree s -> Invariant s ()
forall s. MergingTree s -> Invariant s ()
treeInvariant MergingTree s
tree)

-- | Size is the number of T and P constructors.
sizeT :: T -> Int
sizeT :: T -> Int
sizeT (TCompleted Run
_)        = Int
1
sizeT (TOngoing M TreeMergeType
_)          = Int
1
sizeT (TPendingLevel [P]
ps Maybe T
mt) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((P -> Int) -> [P] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap P -> Int
sizeP [P]
ps) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (T -> Int) -> Maybe T -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 T -> Int
sizeT Maybe T
mt
sizeT (TPendingUnion [T]
ts)    = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((T -> Int) -> [T] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T -> Int
sizeT [T]
ts)

sizeP :: P -> Int
sizeP :: P -> Int
sizeP (PRun Run
_)        = Int
1
sizeP (PMergingRun M LevelMergeType
_) = Int
1

-- | Depth is the longest path through the tree from the root to a leaf using T
-- and P constructors.
depthT :: T -> Int
depthT :: T -> Int
depthT (TCompleted Run
_) = Int
0
depthT (TOngoing M TreeMergeType
_) = Int
0
depthT (TPendingLevel [P]
ps Maybe T
mt) =
    let depthPs :: Int
depthPs = case [P]
ps of
          [] -> Int
0
          [P]
_  -> [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((P -> Int) -> [P] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap P -> Int
depthP [P]
ps)
        depthMt :: Int
depthMt = Int -> (T -> Int) -> Maybe T -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 T -> Int
depthT Maybe T
mt
    in Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
depthPs Int
depthMt
depthT (TPendingUnion [T]
ts) = case [T]
ts of
    [] -> Int
0
    [T]
_  -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((T -> Int) -> [T] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T -> Int
depthT [T]
ts)

depthP :: P -> Int
depthP :: P -> Int
depthP (PRun Run
_)        = Int
0
depthP (PMergingRun M LevelMergeType
_) = Int
0

fromT :: T -> ST s (MergingTree s)
fromT :: forall s. T -> ST s (MergingTree s)
fromT T
t = do
    MergingTreeState s
state <- case T
t of
      TCompleted Run
r -> MergingTreeState s -> ST s (MergingTreeState s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Run -> MergingTreeState s
forall s. Run -> MergingTreeState s
CompletedTreeMerge Run
r)
      TOngoing M TreeMergeType
mr  -> MergingRun TreeMergeType s -> MergingTreeState s
forall s. MergingRun TreeMergeType s -> MergingTreeState s
OngoingTreeMerge (MergingRun TreeMergeType s -> MergingTreeState s)
-> ST s (MergingRun TreeMergeType s) -> ST s (MergingTreeState s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M TreeMergeType -> ST s (MergingRun TreeMergeType s)
forall t s. IsMergeType t => M t -> ST s (MergingRun t s)
fromM M TreeMergeType
mr
      TPendingLevel [P]
ps Maybe T
mt ->
        (PendingMerge s -> MergingTreeState s)
-> ST s (PendingMerge s) -> ST s (MergingTreeState s)
forall a b. (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PendingMerge s -> MergingTreeState s
forall s. PendingMerge s -> MergingTreeState s
PendingTreeMerge (ST s (PendingMerge s) -> ST s (MergingTreeState s))
-> ST s (PendingMerge s) -> ST s (MergingTreeState s)
forall a b. (a -> b) -> a -> b
$
          [PreExistingRun s] -> Maybe (MergingTree s) -> PendingMerge s
forall s.
[PreExistingRun s] -> Maybe (MergingTree s) -> PendingMerge s
PendingLevelMerge ([PreExistingRun s] -> Maybe (MergingTree s) -> PendingMerge s)
-> ST s [PreExistingRun s]
-> ST s (Maybe (MergingTree s) -> PendingMerge s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P -> ST s (PreExistingRun s)) -> [P] -> ST s [PreExistingRun s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse P -> ST s (PreExistingRun s)
forall s. P -> ST s (PreExistingRun s)
fromP [P]
ps ST s (Maybe (MergingTree s) -> PendingMerge s)
-> ST s (Maybe (MergingTree s)) -> ST s (PendingMerge s)
forall a b. ST s (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (T -> ST s (MergingTree s))
-> Maybe T -> ST s (Maybe (MergingTree s))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse T -> ST s (MergingTree s)
forall s. T -> ST s (MergingTree s)
fromT Maybe T
mt
      TPendingUnion [T]
ts -> do
        (PendingMerge s -> MergingTreeState s)
-> ST s (PendingMerge s) -> ST s (MergingTreeState s)
forall a b. (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PendingMerge s -> MergingTreeState s
forall s. PendingMerge s -> MergingTreeState s
PendingTreeMerge (ST s (PendingMerge s) -> ST s (MergingTreeState s))
-> ST s (PendingMerge s) -> ST s (MergingTreeState s)
forall a b. (a -> b) -> a -> b
$ [MergingTree s] -> PendingMerge s
forall s. [MergingTree s] -> PendingMerge s
PendingUnionMerge ([MergingTree s] -> PendingMerge s)
-> ST s [MergingTree s] -> ST s (PendingMerge s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (T -> ST s (MergingTree s)) -> [T] -> ST s [MergingTree s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse T -> ST s (MergingTree s)
forall s. T -> ST s (MergingTree s)
fromT [T]
ts
    STRef s (MergingTreeState s) -> MergingTree s
forall s. STRef s (MergingTreeState s) -> MergingTree s
MergingTree (STRef s (MergingTreeState s) -> MergingTree s)
-> ST s (STRef s (MergingTreeState s)) -> ST s (MergingTree s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergingTreeState s -> ST s (STRef s (MergingTreeState s))
forall a s. a -> ST s (STRef s a)
newSTRef MergingTreeState s
state

fromP :: P -> ST s (PreExistingRun s)
fromP :: forall s. P -> ST s (PreExistingRun s)
fromP (PRun Run
r)        = PreExistingRun s -> ST s (PreExistingRun s)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Run -> PreExistingRun s
forall s. Run -> PreExistingRun s
PreExistingRun Run
r)
fromP (PMergingRun M LevelMergeType
m) = MergingRun LevelMergeType s -> PreExistingRun s
forall s. MergingRun LevelMergeType s -> PreExistingRun s
PreExistingMergingRun (MergingRun LevelMergeType s -> PreExistingRun s)
-> ST s (MergingRun LevelMergeType s) -> ST s (PreExistingRun s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M LevelMergeType -> ST s (MergingRun LevelMergeType s)
forall t s. IsMergeType t => M t -> ST s (MergingRun t s)
fromM M LevelMergeType
m

fromM :: IsMergeType t => M t -> ST s (MergingRun t s)
fromM :: forall t s. IsMergeType t => M t -> ST s (MergingRun t s)
fromM M t
m = do
    let (t
mergeType, MergeDebt
mergeDebt, MergingRunState
state) = case M t
m of
          MCompleted  t
mt MergeDebt
md Run
r  -> (t
mt, MergeDebt
md, Run -> MergingRunState
CompletedMerge Run
r)
          MOngoing t
mt MergeDebt
md MergeCredit
mc [NonEmptyRun]
rs -> (t
mt, MergeDebt
md, MergeCredit -> [Run] -> Run -> MergingRunState
OngoingMerge MergeCredit
mc [Run]
rs' (t -> [Run] -> Run
forall t. IsMergeType t => t -> [Run] -> Run
mergek t
mt [Run]
rs'))
            where rs' :: [Run]
rs' = (NonEmptyRun -> Run) -> [NonEmptyRun] -> [Run]
forall a b. (a -> b) -> [a] -> [b]
map NonEmptyRun -> Run
getNonEmptyRun [NonEmptyRun]
rs
    t -> MergeDebt -> STRef s MergingRunState -> MergingRun t s
forall t s.
t -> MergeDebt -> STRef s MergingRunState -> MergingRun t s
MergingRun t
mergeType MergeDebt
mergeDebt (STRef s MergingRunState -> MergingRun t s)
-> ST s (STRef s MergingRunState) -> ST s (MergingRun t s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergingRunState -> ST s (STRef s MergingRunState)
forall a s. a -> ST s (STRef s a)
newSTRef MergingRunState
state

completeT :: T -> Run
completeT :: T -> Run
completeT (TCompleted Run
r) = Run
r
completeT (TOngoing M TreeMergeType
m)   = M TreeMergeType -> Run
forall t. IsMergeType t => M t -> Run
completeM M TreeMergeType
m
completeT (TPendingLevel [P]
is Maybe T
t) =
    TreeMergeType -> [Run] -> Run
forall t. IsMergeType t => t -> [Run] -> Run
mergek TreeMergeType
MergeLevel ((P -> Run) -> [P] -> [Run]
forall a b. (a -> b) -> [a] -> [b]
map P -> Run
completeP [P]
is [Run] -> [Run] -> [Run]
forall a. Semigroup a => a -> a -> a
<> [Run] -> (T -> [Run]) -> Maybe T -> [Run]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Run -> [Run]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Run -> [Run]) -> (T -> Run) -> T -> [Run]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> Run
completeT) Maybe T
t)
completeT (TPendingUnion [T]
ts) =
    TreeMergeType -> [Run] -> Run
forall t. IsMergeType t => t -> [Run] -> Run
mergek TreeMergeType
MergeUnion ((T -> Run) -> [T] -> [Run]
forall a b. (a -> b) -> [a] -> [b]
map T -> Run
completeT [T]
ts)

completeP :: P -> Run
completeP :: P -> Run
completeP (PRun Run
r)        = Run
r
completeP (PMergingRun M LevelMergeType
m) = M LevelMergeType -> Run
forall t. IsMergeType t => M t -> Run
completeM M LevelMergeType
m

completeM :: IsMergeType t => M t -> Run
completeM :: forall t. IsMergeType t => M t -> Run
completeM (MCompleted t
_ MergeDebt
_ Run
r)   = Run
r
completeM (MOngoing t
mt MergeDebt
_ MergeCredit
_ [NonEmptyRun]
rs) = t -> [Run] -> Run
forall t. IsMergeType t => t -> [Run] -> Run
mergek t
mt ((NonEmptyRun -> Run) -> [NonEmptyRun] -> [Run]
forall a b. (a -> b) -> [a] -> [b]
map NonEmptyRun -> Run
getNonEmptyRun [NonEmptyRun]
rs)

-------------------------------------------------------------------------------
-- Generators
--

instance Arbitrary T where
  arbitrary :: Gen T
arbitrary = (Int -> Gen T) -> Gen T
forall a. (Int -> Gen a) -> Gen a
QC.sized ((Int -> Gen T) -> Gen T) -> (Int -> Gen T) -> Gen T
forall a b. (a -> b) -> a -> b
$ \Int
s -> do
      Int
n <- (Int, Int) -> Gen Int
QC.chooseInt (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
s)
      Int -> Gen T
go Int
n
    where
      -- n is the number of constructors of T and P
      go :: Int -> Gen T
go Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = String -> Gen T
forall a. HasCallStack => String -> a
error (String
"arbitrary T: n == " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n)
      go Int
n | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
          [(Int, Gen T)] -> Gen T
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
            [ (Int
1, Run -> T
TCompleted (Run -> T) -> Gen Run -> Gen T
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Run
forall a. Arbitrary a => Gen a
arbitrary)
            , (Int
1, M TreeMergeType -> T
TOngoing (M TreeMergeType -> T) -> Gen (M TreeMergeType) -> Gen T
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (M TreeMergeType)
forall a. Arbitrary a => Gen a
arbitrary)
            ]
      go Int
n =
          [(Int, Gen T)] -> Gen T
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
            [ (Int
1, do
                -- pending level merge without child
                [P]
preExisting <- Int -> Gen [P]
forall a. Arbitrary a => Int -> Gen [a]
QC.vector (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)  -- 1 for constructor itself
                T -> Gen T
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([P] -> Maybe T -> T
TPendingLevel [P]
preExisting Maybe T
forall a. Maybe a
Nothing))
            , (Int
1, do
                -- pending level merge with child
                Int
numPreExisting <- (Int, Int) -> Gen Int
QC.chooseInt (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
20 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2))
                [P]
preExisting <- Int -> Gen [P]
forall a. Arbitrary a => Int -> Gen [a]
QC.vector Int
numPreExisting
                T
tree <- Int -> Gen T
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numPreExisting Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                T -> Gen T
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([P] -> Maybe T -> T
TPendingLevel [P]
preExisting (T -> Maybe T
forall a. a -> Maybe a
Just T
tree)))
            , (Int
2, do
                -- pending union merge
                [Int]
ns <- [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
QC.shuffle ([Int] -> Gen [Int]) -> Gen [Int] -> Gen [Int]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Gen [Int]
arbitraryPartition2 Int
n
                [T] -> T
TPendingUnion ([T] -> T) -> Gen [T] -> Gen T
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Gen T) -> [Int] -> Gen [T]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Int -> Gen T
go [Int]
ns)
            ]

      -- Split into at least two smaller positive numbers. The input needs to be
      -- greater than or equal to 2.
      arbitraryPartition2 :: Int -> QC.Gen [Int]
      arbitraryPartition2 :: Int -> Gen [Int]
arbitraryPartition2 Int
n = Bool -> Gen [Int] -> Gen [Int]
forall a. HasCallStack => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Gen [Int] -> Gen [Int]) -> Gen [Int] -> Gen [Int]
forall a b. (a -> b) -> a -> b
$ do
          Int
first <- (Int, Int) -> Gen Int
QC.chooseInt (Int
1, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
          (Int
first :) ([Int] -> [Int]) -> Gen [Int] -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Int]
arbitraryPartition (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
first)

      -- Split into smaller positive numbers.
      arbitraryPartition :: Int -> QC.Gen [Int]
      arbitraryPartition :: Int -> Gen [Int]
arbitraryPartition Int
n
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
1 = [Int] -> Gen [Int]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [Int] -> Gen [Int]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
1]
            | Bool
otherwise = do
              Int
first <- (Int, Int) -> Gen Int
QC.chooseInt (Int
1, Int
n)
              (Int
first :) ([Int] -> [Int]) -> Gen [Int] -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Int]
arbitraryPartition (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
first)

  shrink :: T -> [T]
shrink (TCompleted Run
r) =
      [ Run -> T
TCompleted Run
r'
      | Run
r' <- Run -> [Run]
forall a. Arbitrary a => a -> [a]
shrink Run
r
      ]
  shrink tree :: T
tree@(TOngoing M TreeMergeType
m) =
      [ Run -> T
TCompleted (T -> Run
completeT T
tree) ]
   [T] -> [T] -> [T]
forall a. Semigroup a => a -> a -> a
<> [ M TreeMergeType -> T
TOngoing M TreeMergeType
m'
      | M TreeMergeType
m' <- M TreeMergeType -> [M TreeMergeType]
forall a. Arbitrary a => a -> [a]
shrink M TreeMergeType
m
      ]
  shrink tree :: T
tree@(TPendingLevel [P]
ps Maybe T
t) =
      [ Run -> T
TCompleted (T -> Run
completeT T
tree) ]
   [T] -> [T] -> [T]
forall a. Semigroup a => a -> a -> a
<> [ T
t' | Just T
t' <- [Maybe T
t] ]
   [T] -> [T] -> [T]
forall a. Semigroup a => a -> a -> a
<> [ [P] -> Maybe T -> T
TPendingLevel ([P]
ps [P] -> [P] -> [P]
forall a. [a] -> [a] -> [a]
++ [Run -> P
PRun Run
r]) Maybe T
forall a. Maybe a
Nothing  -- move into regular levels
      | Just (TCompleted Run
r) <- [Maybe T
t]
      ]
   [T] -> [T] -> [T]
forall a. Semigroup a => a -> a -> a
<> [ [P] -> Maybe T -> T
TPendingLevel [P]
ps' Maybe T
t'
      | ([P]
ps', Maybe T
t') <- ([P], Maybe T) -> [([P], Maybe T)]
forall a. Arbitrary a => a -> [a]
shrink ([P]
ps, Maybe T
t)
      , [P] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [P]
ps' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Maybe T -> Int
forall a. Maybe a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe T
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      ]
  shrink tree :: T
tree@(TPendingUnion [T]
ts) =
      [ Run -> T
TCompleted (T -> Run
completeT T
tree) ]
   [T] -> [T] -> [T]
forall a. Semigroup a => a -> a -> a
<> [T]
ts
   [T] -> [T] -> [T]
forall a. Semigroup a => a -> a -> a
<> [ [T] -> T
TPendingUnion [T]
ts'
      | [T]
ts' <- [T] -> [[T]]
forall a. Arbitrary a => a -> [a]
shrink [T]
ts
      , [T] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [T]
ts' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      ]

instance Arbitrary P where
  arbitrary :: Gen P
arbitrary = [Gen P] -> Gen P
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof [Run -> P
PRun (Run -> P) -> Gen Run -> Gen P
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Run
forall a. Arbitrary a => Gen a
arbitrary, M LevelMergeType -> P
PMergingRun (M LevelMergeType -> P) -> Gen (M LevelMergeType) -> Gen P
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (M LevelMergeType)
forall a. Arbitrary a => Gen a
arbitrary]
  shrink :: P -> [P]
shrink (PRun Run
r)        = [Run -> P
PRun Run
r' | Run
r' <- Run -> [Run]
forall a. Arbitrary a => a -> [a]
shrink Run
r]
  shrink (PMergingRun M LevelMergeType
m) = [Run -> P
PRun (M LevelMergeType -> Run
forall t. IsMergeType t => M t -> Run
completeM M LevelMergeType
m)]
                        [P] -> [P] -> [P]
forall a. Semigroup a => a -> a -> a
<> [M LevelMergeType -> P
PMergingRun M LevelMergeType
m' | M LevelMergeType
m' <- M LevelMergeType -> [M LevelMergeType]
forall a. Arbitrary a => a -> [a]
shrink M LevelMergeType
m]

instance (Arbitrary t, IsMergeType t) => Arbitrary (M t) where
  arbitrary :: Gen (M t)
arbitrary = [Gen (M t)] -> Gen (M t)
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
      [ do (t
mt, Run
r) <- Gen (t, Run)
forall a. Arbitrary a => Gen a
arbitrary
           let md :: MergeDebt
md = Int -> MergeDebt
MergeDebt (Run -> Int
runSize Run
r)
           M t -> Gen (M t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> MergeDebt -> Run -> M t
forall t. t -> MergeDebt -> Run -> M t
MCompleted t
mt MergeDebt
md Run
r)
      , do t
mt <- Gen t
forall a. Arbitrary a => Gen a
arbitrary
           Int
n  <- (Int, Int) -> Gen Int
QC.chooseInt (Int
2, Int
8)
           [NonEmptyRun]
rs <- Int -> Gen NonEmptyRun -> Gen [NonEmptyRun]
forall a. Int -> Gen a -> Gen [a]
QC.vectorOf Int
n ((Int -> Int) -> Gen NonEmptyRun -> Gen NonEmptyRun
forall a. (Int -> Int) -> Gen a -> Gen a
QC.scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
n) Gen NonEmptyRun
forall a. Arbitrary a => Gen a
arbitrary)
           (MergeDebt
md, MergeCredit
mc) <- [NonEmptyRun] -> Gen (MergeDebt, MergeCredit)
genMergeCreditForRuns [NonEmptyRun]
rs
           M t -> Gen (M t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> MergeDebt -> MergeCredit -> [NonEmptyRun] -> M t
forall t. t -> MergeDebt -> MergeCredit -> [NonEmptyRun] -> M t
MOngoing t
mt MergeDebt
md MergeCredit
mc [NonEmptyRun]
rs)
      ]

  shrink :: M t -> [M t]
shrink (MCompleted t
mt MergeDebt
md Run
r) =
      [ t -> MergeDebt -> Run -> M t
forall t. t -> MergeDebt -> Run -> M t
MCompleted t
mt MergeDebt
md Run
r' | Run
r' <- Run -> [Run]
forall a. Arbitrary a => a -> [a]
shrink Run
r ]
  shrink m :: M t
m@(MOngoing t
mt MergeDebt
md MergeCredit
mc [NonEmptyRun]
rs) =
      [ t -> MergeDebt -> Run -> M t
forall t. t -> MergeDebt -> Run -> M t
MCompleted t
mt MergeDebt
md (M t -> Run
forall t. IsMergeType t => M t -> Run
completeM M t
m) ]
   [M t] -> [M t] -> [M t]
forall a. Semigroup a => a -> a -> a
<> [ t -> MergeDebt -> MergeCredit -> [NonEmptyRun] -> M t
forall t. t -> MergeDebt -> MergeCredit -> [NonEmptyRun] -> M t
MOngoing t
mt MergeDebt
md' MergeCredit
mc' [NonEmptyRun]
rs'
      | [NonEmptyRun]
rs' <- [NonEmptyRun] -> [[NonEmptyRun]]
forall a. Arbitrary a => a -> [a]
shrink [NonEmptyRun]
rs
      , [NonEmptyRun] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NonEmptyRun]
rs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      , (MergeDebt
md', MergeCredit
mc') <- [NonEmptyRun] -> MergeCredit -> [(MergeDebt, MergeCredit)]
shrinkMergeCreditForRuns [NonEmptyRun]
rs' MergeCredit
mc
      ]

-- | The 'MergeDebt' and 'MergeCredit' must maintain a couple invariants:
--
-- * the total debt must be the same as the sum of the input run sizes;
-- * the supplied credit is less than the total merge debt.
--
genMergeCreditForRuns :: [NonEmptyRun] -> QC.Gen (MergeDebt, MergeCredit)
genMergeCreditForRuns :: [NonEmptyRun] -> Gen (MergeDebt, MergeCredit)
genMergeCreditForRuns [NonEmptyRun]
rs = do
      let totalDebt :: Int
totalDebt    = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((NonEmptyRun -> Int) -> [NonEmptyRun] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Run -> Int
forall a. Map Key a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Run -> Int) -> (NonEmptyRun -> Run) -> NonEmptyRun -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyRun -> Run
getNonEmptyRun) [NonEmptyRun]
rs)
      Int
suppliedCredits <- (Int, Int) -> Gen Int
QC.chooseInt (Int
0, Int
totalDebtInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      Int
unspentCredits  <- (Int, Int) -> Gen Int
QC.chooseInt (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
mergeBatchSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
suppliedCredits)
      let spentCredits :: Int
spentCredits = Int
suppliedCredits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
unspentCredits
          md :: MergeDebt
md           = MergeDebt {
                           Int
totalDebt :: Int
totalDebt :: Int
totalDebt
                         }
          mc :: MergeCredit
mc           = MergeCredit {
                            Int
unspentCredits :: Int
unspentCredits :: Int
unspentCredits,
                            Int
spentCredits :: Int
spentCredits :: Int
spentCredits
                         }
      Bool
-> Gen (MergeDebt, MergeCredit) -> Gen (MergeDebt, MergeCredit)
forall a. HasCallStack => Bool -> a -> a
assert (MergeDebt -> MergeCredit -> Bool
mergeDebtInvariant MergeDebt
md MergeCredit
mc) (Gen (MergeDebt, MergeCredit) -> Gen (MergeDebt, MergeCredit))
-> Gen (MergeDebt, MergeCredit) -> Gen (MergeDebt, MergeCredit)
forall a b. (a -> b) -> a -> b
$
        (MergeDebt, MergeCredit) -> Gen (MergeDebt, MergeCredit)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeDebt
md, MergeCredit
mc)

-- | Shrink the 'MergeDebt' and 'MergeCredit' given the old 'MergeCredit' and
-- the already-shrunk runs.
--
-- Thus must maintain invariants, see 'genMergeCreditForDebt'.
--
shrinkMergeCreditForRuns :: [NonEmptyRun]
                         -> MergeCredit -> [(MergeDebt, MergeCredit)]
shrinkMergeCreditForRuns :: [NonEmptyRun] -> MergeCredit -> [(MergeDebt, MergeCredit)]
shrinkMergeCreditForRuns [NonEmptyRun]
rs' MergeCredit {Int
spentCredits :: MergeCredit -> Int
spentCredits :: Int
spentCredits, Int
unspentCredits :: MergeCredit -> Int
unspentCredits :: Int
unspentCredits} =
    [ Bool -> (MergeDebt, MergeCredit) -> (MergeDebt, MergeCredit)
forall a. HasCallStack => Bool -> a -> a
assert (MergeDebt -> MergeCredit -> Bool
mergeDebtInvariant MergeDebt
md' MergeCredit
mc')
      (MergeDebt
md', MergeCredit
mc')
    | let totalDebt' :: Int
totalDebt'    = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((NonEmptyRun -> Int) -> [NonEmptyRun] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Run -> Int
forall a. Map Key a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Run -> Int) -> (NonEmptyRun -> Run) -> NonEmptyRun -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyRun -> Run
getNonEmptyRun) [NonEmptyRun]
rs')
    , Int
suppliedCredits' <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
spentCreditsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
unspentCredits)
                                      (Int
totalDebt'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
    , Int
unspentCredits'  <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
unspentCredits Int
suppliedCredits')
    , let spentCredits' :: Int
spentCredits' = Int
suppliedCredits' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
unspentCredits'
          md' :: MergeDebt
md'           = MergeDebt {
                            totalDebt :: Int
totalDebt      = Int
totalDebt'
                          }
          mc' :: MergeCredit
mc'           = MergeCredit {
                            spentCredits :: Int
spentCredits   = Int
spentCredits',
                            unspentCredits :: Int
unspentCredits = Int
unspentCredits'
                          }
    ]

instance Arbitrary NonEmptyRun where
  arbitrary :: Gen NonEmptyRun
arbitrary = Run -> NonEmptyRun
NonEmptyRun (Run -> NonEmptyRun) -> Gen Run -> Gen NonEmptyRun
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Run
forall a. Arbitrary a => Gen a
arbitrary Gen Run -> (Run -> Bool) -> Gen Run
forall a. Gen a -> (a -> Bool) -> Gen a
`QC.suchThat` (Bool -> Bool
not (Bool -> Bool) -> (Run -> Bool) -> Run -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> Bool
forall a. Map Key a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null))
  shrink :: NonEmptyRun -> [NonEmptyRun]
shrink (NonEmptyRun Run
r) = [Run -> NonEmptyRun
NonEmptyRun Run
r' | Run
r' <- Run -> [Run]
forall a. Arbitrary a => a -> [a]
shrink Run
r, Bool -> Bool
not (Run -> Bool
forall a. Map Key a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Run
r')]

prop_arbitrarySatisfiesInvariant :: T -> Property
prop_arbitrarySatisfiesInvariant :: T -> Property
prop_arbitrarySatisfiesInvariant T
t =
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
QC.tabulate String
"Tree size" [Int -> Int -> String
showPowersOf Int
2 (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ T -> Int
sizeT T
t] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
QC.tabulate String
"Tree depth" [Int -> Int -> String
showPowersOf Int
2 (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ T -> Int
depthT T
t] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      () -> Either String ()
forall a b. b -> Either a b
Right () Either String () -> Either String () -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== T -> Either String ()
invariantT T
t

prop_shrinkSatisfiesInvariant :: T -> Property
prop_shrinkSatisfiesInvariant :: T -> Property
prop_shrinkSatisfiesInvariant T
t =
    Gen [(Int, T)] -> ([(Int, T)] -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
QC.forAll (Int -> T -> Gen [(Int, T)]
forall a. Arbitrary a => Int -> a -> Gen [(Int, a)]
genShrinkTrace Int
4 T
t) (([(Int, T)] -> Property) -> Property)
-> ([(Int, T)] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[(Int, T)]
trace ->
      String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
QC.tabulate String
"Trace length" [Int -> Int -> String
showPowersOf Int
2 (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [(Int, T)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, T)]
trace] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
QC.conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$ (((Int, T) -> Property) -> [(Int, T)] -> [Property])
-> [(Int, T)] -> ((Int, T) -> Property) -> [Property]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, T) -> Property) -> [(Int, T)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, T)]
trace (((Int, T) -> Property) -> [Property])
-> ((Int, T) -> Property) -> [Property]
forall a b. (a -> b) -> a -> b
$ \(Int
numAlternatives, T
t') ->
        String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
QC.tabulate String
"Shrink alternatives" [Int -> Int -> String
showPowersOf Int
2 Int
numAlternatives] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          () -> Either String ()
forall a b. b -> Either a b
Right () Either String () -> Either String () -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== T -> Either String ()
invariantT T
t'

-- | Iterative shrinks, and how many alternatives were possible at each point.
genShrinkTrace :: Arbitrary a => Int -> a -> QC.Gen [(Int, a)]
genShrinkTrace :: forall a. Arbitrary a => Int -> a -> Gen [(Int, a)]
genShrinkTrace !Int
n a
x
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [(Int, a)] -> Gen [(Int, a)]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise =
    case a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
x of
      [] -> [(Int, a)] -> Gen [(Int, a)]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      [a]
xs -> do
        -- like QC.elements, but we want access to the length
        let len :: Int
len = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
        a
x' <- ([a]
xs !!) (Int -> a) -> Gen Int -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
QC.chooseInt (Int
0, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        ((Int
len, a
x') :) ([(Int, a)] -> [(Int, a)]) -> Gen [(Int, a)] -> Gen [(Int, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> a -> Gen [(Int, a)]
forall a. Arbitrary a => Int -> a -> Gen [(Int, a)]
genShrinkTrace (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) a
x'

-------------------------------------------------------------------------------
-- tracing and expectations on LSM shape
--

-- | Provides a tracer and will add the log of traced events to the reported
-- failure.
runWithTracer :: (Tracer (ST RealWorld) Event -> IO a) -> IO a
runWithTracer :: forall a. (Tracer (ST RealWorld) Event -> IO a) -> IO a
runWithTracer Tracer (ST RealWorld) Event -> IO a
action = do
    STRef RealWorld [Event]
events <- ST RealWorld (STRef RealWorld [Event])
-> IO (STRef RealWorld [Event])
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld (STRef RealWorld [Event])
 -> IO (STRef RealWorld [Event]))
-> ST RealWorld (STRef RealWorld [Event])
-> IO (STRef RealWorld [Event])
forall a b. (a -> b) -> a -> b
$ [Event] -> ST RealWorld (STRef RealWorld [Event])
forall a s. a -> ST s (STRef s a)
newSTRef []
    let tracer :: Tracer (ST RealWorld) Event
tracer = TracerA (ST RealWorld) Event () -> Tracer (ST RealWorld) Event
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA (ST RealWorld) Event () -> Tracer (ST RealWorld) Event)
-> TracerA (ST RealWorld) Event () -> Tracer (ST RealWorld) Event
forall a b. (a -> b) -> a -> b
$ (Event -> ST RealWorld ()) -> TracerA (ST RealWorld) Event ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
Tracer.emit ((Event -> ST RealWorld ()) -> TracerA (ST RealWorld) Event ())
-> (Event -> ST RealWorld ()) -> TracerA (ST RealWorld) Event ()
forall a b. (a -> b) -> a -> b
$ \Event
e -> STRef RealWorld [Event] -> ([Event] -> [Event]) -> ST RealWorld ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef RealWorld [Event]
events (Event
e :)
    Tracer (ST RealWorld) Event -> IO a
action Tracer (ST RealWorld) Event
tracer IO a -> (AnException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \AnException
e -> do
      if AnException -> Bool
isDiscard AnException
e  -- don't intercept these
        then AnException -> IO a
forall e a. Exception e => e -> IO a
throwIO AnException
e
        else do
          [Event]
ev <- [Event] -> [Event]
forall a. [a] -> [a]
reverse ([Event] -> [Event]) -> IO [Event] -> IO [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST RealWorld [Event] -> IO [Event]
forall a. ST RealWorld a -> IO a
stToIO (STRef RealWorld [Event] -> ST RealWorld [Event]
forall s a. STRef s a -> ST s a
readSTRef STRef RealWorld [Event]
events)
          TracedException -> IO a
forall e a. Exception e => e -> IO a
throwIO (AnException -> [Event] -> TracedException
Traced AnException
e [Event]
ev)

data TracedException = Traced SomeException [Event]
  deriving stock (Int -> TracedException -> ShowS
[TracedException] -> ShowS
TracedException -> String
(Int -> TracedException -> ShowS)
-> (TracedException -> String)
-> ([TracedException] -> ShowS)
-> Show TracedException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TracedException -> ShowS
showsPrec :: Int -> TracedException -> ShowS
$cshow :: TracedException -> String
show :: TracedException -> String
$cshowList :: [TracedException] -> ShowS
showList :: [TracedException] -> ShowS
Show)

instance Exception TracedException where
  displayException :: TracedException -> String
displayException (Traced AnException
e [Event]
ev) =
    AnException -> String
forall e. Exception e => e -> String
displayException AnException
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ntrace:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((Event -> String) -> [Event] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Event -> String
forall a. Show a => a -> String
show [Event]
ev)

expectShape :: HasCallStack => LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape :: forall s.
HasCallStack =>
LSM s -> Int -> [([Int], [Int])] -> ST s ()
expectShape LSM s
lsm Int
expectedWb [([Int], [Int])]
expectedLevels = do
    let expected :: (Int, [([Int], [Int])], Maybe (MTree Int))
expected = (Int
expectedWb, [([Int], [Int])]
expectedLevels, Maybe (MTree Int)
forall a. Maybe a
Nothing)
    (Int, [([Int], [Int])], Maybe (MTree Int))
shape <- Representation -> (Int, [([Int], [Int])], Maybe (MTree Int))
representationShape (Representation -> (Int, [([Int], [Int])], Maybe (MTree Int)))
-> ST s Representation
-> ST s (Int, [([Int], [Int])], Maybe (MTree Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LSM s -> ST s Representation
forall s. LSM s -> ST s Representation
dumpRepresentation LSM s
lsm
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, [([Int], [Int])], Maybe (MTree Int))
shape (Int, [([Int], [Int])], Maybe (MTree Int))
-> (Int, [([Int], [Int])], Maybe (MTree Int)) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int, [([Int], [Int])], Maybe (MTree Int))
expected) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
      String -> ST s ()
forall a. HasCallStack => String -> a
error (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
"expected shape: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int, [([Int], [Int])], Maybe (MTree Int)) -> String
forall a. Show a => a -> String
show (Int, [([Int], [Int])], Maybe (MTree Int))
expected
        , String
"actual shape:   " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int, [([Int], [Int])], Maybe (MTree Int)) -> String
forall a. Show a => a -> String
show (Int, [([Int], [Int])], Maybe (MTree Int))
shape
        ]

hasUnionWith :: (MTree Int -> Bool) -> Representation -> Property
hasUnionWith :: (MTree Int -> Bool) -> Representation -> Property
hasUnionWith MTree Int -> Bool
p Representation
rep = do
    let (Int
_, [([Int], [Int])]
_, Maybe (MTree Int)
shape) = Representation -> (Int, [([Int], [Int])], Maybe (MTree Int))
representationShape Representation
rep
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
QC.counterexample String
"expected suitable Union" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
QC.counterexample (Maybe (MTree Int) -> String
forall a. Show a => a -> String
show Maybe (MTree Int)
shape) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        case Maybe (MTree Int)
shape of
          Maybe (MTree Int)
Nothing -> Bool
False
          Just MTree Int
t  -> MTree Int -> Bool
p MTree Int
t

-------------------------------------------------------------------------------
-- Printing utils
--

-- | Copied from @lsm-tree:extras.Database.LSMTree.Extras@
showPowersOf :: Int -> Int -> String
showPowersOf :: Int -> Int -> String
showPowersOf Int
factor Int
n
  | Int
factor Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = ShowS
forall a. HasCallStack => String -> a
error String
"showPowersOf: factor must be larger than 1"
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0       = String
"n < 0"
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0      = String
"n == 0"
  | Bool
otherwise   = String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%d <= n < %d" Int
lb Int
ub
  where
    ub :: Int
ub = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust ((Int -> Bool) -> [Int] -> Maybe Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Int
n <) ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
factor) Int
factor))
    lb :: Int
lb = Int
ub Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
factor