{-# LANGUAGE DerivingStrategies, FunctionalDependencies, AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables #-}

module Test.Credit
  (
  -- * Common time-complexity functions
    Size, logstar, log2, linear
  -- * Tree shapes for testing
  , Strategy(..), genTree
  -- * Testing data structures on trees of operations
  , DataStructure(..), runTree, checkCredits, runTreeMemory, checkCreditsMemory
  ) where

import Data.Either
import Control.Monad.State
import Data.Tree
import Test.QuickCheck
import Prettyprinter
import Prettyprinter.Render.String

import Control.Monad.Credit.Base
import Control.Monad.Credit.CreditM

path :: Arbitrary a => Int -> Tree a -> Gen (Tree a)
path :: forall a. Arbitrary a => Int -> Tree a -> Gen (Tree a)
path Int
0 Tree a
end = Tree a -> Gen (Tree a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree a
end
path Int
n Tree a
end = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node (a -> [Tree a] -> Tree a) -> Gen a -> Gen ([Tree a] -> Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary Gen ([Tree a] -> Tree a) -> Gen [Tree a] -> Gen (Tree a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Tree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
:[]) (Tree a -> [Tree a]) -> Gen (Tree a) -> Gen [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Tree a -> Gen (Tree a)
forall a. Arbitrary a => Int -> Tree a -> Gen (Tree a)
path (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Tree a
end)

path' :: Arbitrary a => Int -> Gen (Tree a)
path' :: forall a. Arbitrary a => Int -> Gen (Tree a)
path' Int
n = Int -> Tree a -> Gen (Tree a)
forall a. Arbitrary a => Int -> Tree a -> Gen (Tree a)
path Int
n (Tree a -> Gen (Tree a)) -> Gen (Tree a) -> Gen (Tree a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node (a -> [Tree a] -> Tree a) -> Gen a -> Gen ([Tree a] -> Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary Gen ([Tree a] -> Tree a) -> Gen [Tree a] -> Gen (Tree a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Tree a] -> Gen [Tree a]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

bloom :: Arbitrary a => Gen (Tree a)
bloom :: forall a. Arbitrary a => Gen (Tree a)
bloom = (Int -> Gen (Tree a)) -> Gen (Tree a)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (Tree a)) -> Gen (Tree a))
-> (Int -> Gen (Tree a)) -> Gen (Tree a)
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
  Int
m <- (Int, Int) -> Gen Int
chooseInt (Int
0, Int
n)
  Int
k <- (Int, Int) -> Gen Int
chooseInt (Int
0, Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
  [Tree a]
ts <- (Int -> Gen (Tree a)) -> [Int] -> Gen [Tree a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
_ -> Int -> Gen (Tree a)
forall a. Arbitrary a => Int -> Gen (Tree a)
path' (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
k)) [Int
1..Int
k]
  Int -> Tree a -> Gen (Tree a)
forall a. Arbitrary a => Int -> Tree a -> Gen (Tree a)
path (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) (Tree a -> Gen (Tree a)) -> Gen (Tree a) -> Gen (Tree a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node (a -> [Tree a] -> Tree a) -> Gen a -> Gen ([Tree a] -> Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary Gen ([Tree a] -> Tree a) -> Gen [Tree a] -> Gen (Tree a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Tree a] -> Gen [Tree a]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tree a]
ts

pennant :: Arbitrary a => Gen (Tree a)
pennant :: forall a. Arbitrary a => Gen (Tree a)
pennant = (Int -> Gen (Tree a)) -> Gen (Tree a)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (Tree a)
forall a. Arbitrary a => Int -> Gen (Tree a)
go
  where
    go :: Int -> Gen (Tree a)
go Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = Int -> Gen (Tree a)
forall a. Arbitrary a => Int -> Gen (Tree a)
path' Int
0
    go Int
n = do
      Int
k <- (Int, Int) -> Gen Int
chooseInt (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3, Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3))
      [Tree a]
ts <- (Integer -> Gen (Tree a)) -> [Integer] -> Gen [Tree a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Integer
_ -> Int -> Gen (Tree a)
go ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)) [Integer
1..Integer
2]
      Int -> Tree a -> Gen (Tree a)
forall a. Arbitrary a => Int -> Tree a -> Gen (Tree a)
path Int
k (Tree a -> Gen (Tree a)) -> Gen (Tree a) -> Gen (Tree a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node (a -> [Tree a] -> Tree a) -> Gen a -> Gen ([Tree a] -> Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary Gen ([Tree a] -> Tree a) -> Gen [Tree a] -> Gen (Tree a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Tree a] -> Gen [Tree a]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tree a]
ts

newtype SeqTree a = SeqTree { forall a. SeqTree a -> Tree a
fromSeqTree :: Tree a }
  deriving (SeqTree a -> SeqTree a -> Bool
(SeqTree a -> SeqTree a -> Bool)
-> (SeqTree a -> SeqTree a -> Bool) -> Eq (SeqTree a)
forall a. Eq a => SeqTree a -> SeqTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => SeqTree a -> SeqTree a -> Bool
== :: SeqTree a -> SeqTree a -> Bool
$c/= :: forall a. Eq a => SeqTree a -> SeqTree a -> Bool
/= :: SeqTree a -> SeqTree a -> Bool
Eq, Eq (SeqTree a)
Eq (SeqTree a) =>
(SeqTree a -> SeqTree a -> Ordering)
-> (SeqTree a -> SeqTree a -> Bool)
-> (SeqTree a -> SeqTree a -> Bool)
-> (SeqTree a -> SeqTree a -> Bool)
-> (SeqTree a -> SeqTree a -> Bool)
-> (SeqTree a -> SeqTree a -> SeqTree a)
-> (SeqTree a -> SeqTree a -> SeqTree a)
-> Ord (SeqTree a)
SeqTree a -> SeqTree a -> Bool
SeqTree a -> SeqTree a -> Ordering
SeqTree a -> SeqTree a -> SeqTree a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (SeqTree a)
forall a. Ord a => SeqTree a -> SeqTree a -> Bool
forall a. Ord a => SeqTree a -> SeqTree a -> Ordering
forall a. Ord a => SeqTree a -> SeqTree a -> SeqTree a
$ccompare :: forall a. Ord a => SeqTree a -> SeqTree a -> Ordering
compare :: SeqTree a -> SeqTree a -> Ordering
$c< :: forall a. Ord a => SeqTree a -> SeqTree a -> Bool
< :: SeqTree a -> SeqTree a -> Bool
$c<= :: forall a. Ord a => SeqTree a -> SeqTree a -> Bool
<= :: SeqTree a -> SeqTree a -> Bool
$c> :: forall a. Ord a => SeqTree a -> SeqTree a -> Bool
> :: SeqTree a -> SeqTree a -> Bool
$c>= :: forall a. Ord a => SeqTree a -> SeqTree a -> Bool
>= :: SeqTree a -> SeqTree a -> Bool
$cmax :: forall a. Ord a => SeqTree a -> SeqTree a -> SeqTree a
max :: SeqTree a -> SeqTree a -> SeqTree a
$cmin :: forall a. Ord a => SeqTree a -> SeqTree a -> SeqTree a
min :: SeqTree a -> SeqTree a -> SeqTree a
Ord, Int -> SeqTree a -> ShowS
[SeqTree a] -> ShowS
SeqTree a -> String
(Int -> SeqTree a -> ShowS)
-> (SeqTree a -> String)
-> ([SeqTree a] -> ShowS)
-> Show (SeqTree a)
forall a. Show a => Int -> SeqTree a -> ShowS
forall a. Show a => [SeqTree a] -> ShowS
forall a. Show a => SeqTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> SeqTree a -> ShowS
showsPrec :: Int -> SeqTree a -> ShowS
$cshow :: forall a. Show a => SeqTree a -> String
show :: SeqTree a -> String
$cshowList :: forall a. Show a => [SeqTree a] -> ShowS
showList :: [SeqTree a] -> ShowS
Show)

instance Arbitrary a => Arbitrary (SeqTree a) where
  arbitrary :: Gen (SeqTree a)
arbitrary = (Int -> Gen (SeqTree a)) -> Gen (SeqTree a)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (SeqTree a)) -> Gen (SeqTree a))
-> (Int -> Gen (SeqTree a)) -> Gen (SeqTree a)
forall a b. (a -> b) -> a -> b
$ \Int
n -> Tree a -> SeqTree a
forall a. Tree a -> SeqTree a
SeqTree (Tree a -> SeqTree a) -> Gen (Tree a) -> Gen (SeqTree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (Tree a)
forall a. Arbitrary a => Int -> Gen (Tree a)
path' Int
n

newtype BloomTree a = BloomTree { forall a. BloomTree a -> Tree a
fromBloomTree :: Tree a }
  deriving (BloomTree a -> BloomTree a -> Bool
(BloomTree a -> BloomTree a -> Bool)
-> (BloomTree a -> BloomTree a -> Bool) -> Eq (BloomTree a)
forall a. Eq a => BloomTree a -> BloomTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => BloomTree a -> BloomTree a -> Bool
== :: BloomTree a -> BloomTree a -> Bool
$c/= :: forall a. Eq a => BloomTree a -> BloomTree a -> Bool
/= :: BloomTree a -> BloomTree a -> Bool
Eq, Eq (BloomTree a)
Eq (BloomTree a) =>
(BloomTree a -> BloomTree a -> Ordering)
-> (BloomTree a -> BloomTree a -> Bool)
-> (BloomTree a -> BloomTree a -> Bool)
-> (BloomTree a -> BloomTree a -> Bool)
-> (BloomTree a -> BloomTree a -> Bool)
-> (BloomTree a -> BloomTree a -> BloomTree a)
-> (BloomTree a -> BloomTree a -> BloomTree a)
-> Ord (BloomTree a)
BloomTree a -> BloomTree a -> Bool
BloomTree a -> BloomTree a -> Ordering
BloomTree a -> BloomTree a -> BloomTree a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (BloomTree a)
forall a. Ord a => BloomTree a -> BloomTree a -> Bool
forall a. Ord a => BloomTree a -> BloomTree a -> Ordering
forall a. Ord a => BloomTree a -> BloomTree a -> BloomTree a
$ccompare :: forall a. Ord a => BloomTree a -> BloomTree a -> Ordering
compare :: BloomTree a -> BloomTree a -> Ordering
$c< :: forall a. Ord a => BloomTree a -> BloomTree a -> Bool
< :: BloomTree a -> BloomTree a -> Bool
$c<= :: forall a. Ord a => BloomTree a -> BloomTree a -> Bool
<= :: BloomTree a -> BloomTree a -> Bool
$c> :: forall a. Ord a => BloomTree a -> BloomTree a -> Bool
> :: BloomTree a -> BloomTree a -> Bool
$c>= :: forall a. Ord a => BloomTree a -> BloomTree a -> Bool
>= :: BloomTree a -> BloomTree a -> Bool
$cmax :: forall a. Ord a => BloomTree a -> BloomTree a -> BloomTree a
max :: BloomTree a -> BloomTree a -> BloomTree a
$cmin :: forall a. Ord a => BloomTree a -> BloomTree a -> BloomTree a
min :: BloomTree a -> BloomTree a -> BloomTree a
Ord, Int -> BloomTree a -> ShowS
[BloomTree a] -> ShowS
BloomTree a -> String
(Int -> BloomTree a -> ShowS)
-> (BloomTree a -> String)
-> ([BloomTree a] -> ShowS)
-> Show (BloomTree a)
forall a. Show a => Int -> BloomTree a -> ShowS
forall a. Show a => [BloomTree a] -> ShowS
forall a. Show a => BloomTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> BloomTree a -> ShowS
showsPrec :: Int -> BloomTree a -> ShowS
$cshow :: forall a. Show a => BloomTree a -> String
show :: BloomTree a -> String
$cshowList :: forall a. Show a => [BloomTree a] -> ShowS
showList :: [BloomTree a] -> ShowS
Show)

instance Arbitrary a => Arbitrary (BloomTree a) where
  arbitrary :: Gen (BloomTree a)
arbitrary = Tree a -> BloomTree a
forall a. Tree a -> BloomTree a
BloomTree (Tree a -> BloomTree a) -> Gen (Tree a) -> Gen (BloomTree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Tree a)
forall a. Arbitrary a => Gen (Tree a)
bloom

newtype PennantTree a = PennantTree { forall a. PennantTree a -> Tree a
fromPennantTree :: Tree a }
  deriving (PennantTree a -> PennantTree a -> Bool
(PennantTree a -> PennantTree a -> Bool)
-> (PennantTree a -> PennantTree a -> Bool) -> Eq (PennantTree a)
forall a. Eq a => PennantTree a -> PennantTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PennantTree a -> PennantTree a -> Bool
== :: PennantTree a -> PennantTree a -> Bool
$c/= :: forall a. Eq a => PennantTree a -> PennantTree a -> Bool
/= :: PennantTree a -> PennantTree a -> Bool
Eq, Eq (PennantTree a)
Eq (PennantTree a) =>
(PennantTree a -> PennantTree a -> Ordering)
-> (PennantTree a -> PennantTree a -> Bool)
-> (PennantTree a -> PennantTree a -> Bool)
-> (PennantTree a -> PennantTree a -> Bool)
-> (PennantTree a -> PennantTree a -> Bool)
-> (PennantTree a -> PennantTree a -> PennantTree a)
-> (PennantTree a -> PennantTree a -> PennantTree a)
-> Ord (PennantTree a)
PennantTree a -> PennantTree a -> Bool
PennantTree a -> PennantTree a -> Ordering
PennantTree a -> PennantTree a -> PennantTree a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PennantTree a)
forall a. Ord a => PennantTree a -> PennantTree a -> Bool
forall a. Ord a => PennantTree a -> PennantTree a -> Ordering
forall a. Ord a => PennantTree a -> PennantTree a -> PennantTree a
$ccompare :: forall a. Ord a => PennantTree a -> PennantTree a -> Ordering
compare :: PennantTree a -> PennantTree a -> Ordering
$c< :: forall a. Ord a => PennantTree a -> PennantTree a -> Bool
< :: PennantTree a -> PennantTree a -> Bool
$c<= :: forall a. Ord a => PennantTree a -> PennantTree a -> Bool
<= :: PennantTree a -> PennantTree a -> Bool
$c> :: forall a. Ord a => PennantTree a -> PennantTree a -> Bool
> :: PennantTree a -> PennantTree a -> Bool
$c>= :: forall a. Ord a => PennantTree a -> PennantTree a -> Bool
>= :: PennantTree a -> PennantTree a -> Bool
$cmax :: forall a. Ord a => PennantTree a -> PennantTree a -> PennantTree a
max :: PennantTree a -> PennantTree a -> PennantTree a
$cmin :: forall a. Ord a => PennantTree a -> PennantTree a -> PennantTree a
min :: PennantTree a -> PennantTree a -> PennantTree a
Ord, Int -> PennantTree a -> ShowS
[PennantTree a] -> ShowS
PennantTree a -> String
(Int -> PennantTree a -> ShowS)
-> (PennantTree a -> String)
-> ([PennantTree a] -> ShowS)
-> Show (PennantTree a)
forall a. Show a => Int -> PennantTree a -> ShowS
forall a. Show a => [PennantTree a] -> ShowS
forall a. Show a => PennantTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PennantTree a -> ShowS
showsPrec :: Int -> PennantTree a -> ShowS
$cshow :: forall a. Show a => PennantTree a -> String
show :: PennantTree a -> String
$cshowList :: forall a. Show a => [PennantTree a] -> ShowS
showList :: [PennantTree a] -> ShowS
Show)

instance Arbitrary a => Arbitrary (PennantTree a) where
  arbitrary :: Gen (PennantTree a)
arbitrary = Tree a -> PennantTree a
forall a. Tree a -> PennantTree a
PennantTree (Tree a -> PennantTree a) -> Gen (Tree a) -> Gen (PennantTree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Tree a)
forall a. Arbitrary a => Gen (Tree a)
pennant

newtype PrsTree a = PrsTree { forall a. PrsTree a -> Tree a
fromPrsTree :: Tree a }
  deriving (PrsTree a -> PrsTree a -> Bool
(PrsTree a -> PrsTree a -> Bool)
-> (PrsTree a -> PrsTree a -> Bool) -> Eq (PrsTree a)
forall a. Eq a => PrsTree a -> PrsTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PrsTree a -> PrsTree a -> Bool
== :: PrsTree a -> PrsTree a -> Bool
$c/= :: forall a. Eq a => PrsTree a -> PrsTree a -> Bool
/= :: PrsTree a -> PrsTree a -> Bool
Eq, Eq (PrsTree a)
Eq (PrsTree a) =>
(PrsTree a -> PrsTree a -> Ordering)
-> (PrsTree a -> PrsTree a -> Bool)
-> (PrsTree a -> PrsTree a -> Bool)
-> (PrsTree a -> PrsTree a -> Bool)
-> (PrsTree a -> PrsTree a -> Bool)
-> (PrsTree a -> PrsTree a -> PrsTree a)
-> (PrsTree a -> PrsTree a -> PrsTree a)
-> Ord (PrsTree a)
PrsTree a -> PrsTree a -> Bool
PrsTree a -> PrsTree a -> Ordering
PrsTree a -> PrsTree a -> PrsTree a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PrsTree a)
forall a. Ord a => PrsTree a -> PrsTree a -> Bool
forall a. Ord a => PrsTree a -> PrsTree a -> Ordering
forall a. Ord a => PrsTree a -> PrsTree a -> PrsTree a
$ccompare :: forall a. Ord a => PrsTree a -> PrsTree a -> Ordering
compare :: PrsTree a -> PrsTree a -> Ordering
$c< :: forall a. Ord a => PrsTree a -> PrsTree a -> Bool
< :: PrsTree a -> PrsTree a -> Bool
$c<= :: forall a. Ord a => PrsTree a -> PrsTree a -> Bool
<= :: PrsTree a -> PrsTree a -> Bool
$c> :: forall a. Ord a => PrsTree a -> PrsTree a -> Bool
> :: PrsTree a -> PrsTree a -> Bool
$c>= :: forall a. Ord a => PrsTree a -> PrsTree a -> Bool
>= :: PrsTree a -> PrsTree a -> Bool
$cmax :: forall a. Ord a => PrsTree a -> PrsTree a -> PrsTree a
max :: PrsTree a -> PrsTree a -> PrsTree a
$cmin :: forall a. Ord a => PrsTree a -> PrsTree a -> PrsTree a
min :: PrsTree a -> PrsTree a -> PrsTree a
Ord, Int -> PrsTree a -> ShowS
[PrsTree a] -> ShowS
PrsTree a -> String
(Int -> PrsTree a -> ShowS)
-> (PrsTree a -> String)
-> ([PrsTree a] -> ShowS)
-> Show (PrsTree a)
forall a. Show a => Int -> PrsTree a -> ShowS
forall a. Show a => [PrsTree a] -> ShowS
forall a. Show a => PrsTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PrsTree a -> ShowS
showsPrec :: Int -> PrsTree a -> ShowS
$cshow :: forall a. Show a => PrsTree a -> String
show :: PrsTree a -> String
$cshowList :: forall a. Show a => [PrsTree a] -> ShowS
showList :: [PrsTree a] -> ShowS
Show)

instance Arbitrary a => Arbitrary (PrsTree a) where
  arbitrary :: Gen (PrsTree a)
arbitrary = Tree a -> PrsTree a
forall a. Tree a -> PrsTree a
PrsTree (Tree a -> PrsTree a) -> Gen (Tree a) -> Gen (PrsTree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Tree a)
forall a. Arbitrary a => Gen a
arbitrary

data Strategy = Path | Bloom | Pennant | Random
  deriving (Strategy -> Strategy -> Bool
(Strategy -> Strategy -> Bool)
-> (Strategy -> Strategy -> Bool) -> Eq Strategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Strategy -> Strategy -> Bool
== :: Strategy -> Strategy -> Bool
$c/= :: Strategy -> Strategy -> Bool
/= :: Strategy -> Strategy -> Bool
Eq, Eq Strategy
Eq Strategy =>
(Strategy -> Strategy -> Ordering)
-> (Strategy -> Strategy -> Bool)
-> (Strategy -> Strategy -> Bool)
-> (Strategy -> Strategy -> Bool)
-> (Strategy -> Strategy -> Bool)
-> (Strategy -> Strategy -> Strategy)
-> (Strategy -> Strategy -> Strategy)
-> Ord Strategy
Strategy -> Strategy -> Bool
Strategy -> Strategy -> Ordering
Strategy -> Strategy -> Strategy
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Strategy -> Strategy -> Ordering
compare :: Strategy -> Strategy -> Ordering
$c< :: Strategy -> Strategy -> Bool
< :: Strategy -> Strategy -> Bool
$c<= :: Strategy -> Strategy -> Bool
<= :: Strategy -> Strategy -> Bool
$c> :: Strategy -> Strategy -> Bool
> :: Strategy -> Strategy -> Bool
$c>= :: Strategy -> Strategy -> Bool
>= :: Strategy -> Strategy -> Bool
$cmax :: Strategy -> Strategy -> Strategy
max :: Strategy -> Strategy -> Strategy
$cmin :: Strategy -> Strategy -> Strategy
min :: Strategy -> Strategy -> Strategy
Ord, Int -> Strategy -> ShowS
[Strategy] -> ShowS
Strategy -> String
(Int -> Strategy -> ShowS)
-> (Strategy -> String) -> ([Strategy] -> ShowS) -> Show Strategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Strategy -> ShowS
showsPrec :: Int -> Strategy -> ShowS
$cshow :: Strategy -> String
show :: Strategy -> String
$cshowList :: [Strategy] -> ShowS
showList :: [Strategy] -> ShowS
Show)

genTree :: Arbitrary op => Strategy -> Gen (Tree op)
genTree :: forall op. Arbitrary op => Strategy -> Gen (Tree op)
genTree Strategy
Path = SeqTree op -> Tree op
forall a. SeqTree a -> Tree a
fromSeqTree (SeqTree op -> Tree op) -> Gen (SeqTree op) -> Gen (Tree op)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SeqTree op)
forall a. Arbitrary a => Gen a
arbitrary
genTree Strategy
Bloom = BloomTree op -> Tree op
forall a. BloomTree a -> Tree a
fromBloomTree (BloomTree op -> Tree op) -> Gen (BloomTree op) -> Gen (Tree op)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BloomTree op)
forall a. Arbitrary a => Gen a
arbitrary
genTree Strategy
Pennant = PennantTree op -> Tree op
forall a. PennantTree a -> Tree a
fromPennantTree (PennantTree op -> Tree op)
-> Gen (PennantTree op) -> Gen (Tree op)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (PennantTree op)
forall a. Arbitrary a => Gen a
arbitrary
genTree Strategy
Random = PrsTree op -> Tree op
forall a. PrsTree a -> Tree a
fromPrsTree (PrsTree op -> Tree op) -> Gen (PrsTree op) -> Gen (Tree op)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (PrsTree op)
forall a. Arbitrary a => Gen a
arbitrary

newtype Size = Size Int
  deriving (Size -> Size -> Bool
(Size -> Size -> Bool) -> (Size -> Size -> Bool) -> Eq Size
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Size -> Size -> Bool
== :: Size -> Size -> Bool
$c/= :: Size -> Size -> Bool
/= :: Size -> Size -> Bool
Eq, Eq Size
Eq Size =>
(Size -> Size -> Ordering)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Bool)
-> (Size -> Size -> Size)
-> (Size -> Size -> Size)
-> Ord Size
Size -> Size -> Bool
Size -> Size -> Ordering
Size -> Size -> Size
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Size -> Size -> Ordering
compare :: Size -> Size -> Ordering
$c< :: Size -> Size -> Bool
< :: Size -> Size -> Bool
$c<= :: Size -> Size -> Bool
<= :: Size -> Size -> Bool
$c> :: Size -> Size -> Bool
> :: Size -> Size -> Bool
$c>= :: Size -> Size -> Bool
>= :: Size -> Size -> Bool
$cmax :: Size -> Size -> Size
max :: Size -> Size -> Size
$cmin :: Size -> Size -> Size
min :: Size -> Size -> Size
Ord, Int -> Size -> ShowS
[Size] -> ShowS
Size -> String
(Int -> Size -> ShowS)
-> (Size -> String) -> ([Size] -> ShowS) -> Show Size
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Size -> ShowS
showsPrec :: Int -> Size -> ShowS
$cshow :: Size -> String
show :: Size -> String
$cshowList :: [Size] -> ShowS
showList :: [Size] -> ShowS
Show)
  deriving newtype (Integer -> Size
Size -> Size
Size -> Size -> Size
(Size -> Size -> Size)
-> (Size -> Size -> Size)
-> (Size -> Size -> Size)
-> (Size -> Size)
-> (Size -> Size)
-> (Size -> Size)
-> (Integer -> Size)
-> Num Size
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Size -> Size -> Size
+ :: Size -> Size -> Size
$c- :: Size -> Size -> Size
- :: Size -> Size -> Size
$c* :: Size -> Size -> Size
* :: Size -> Size -> Size
$cnegate :: Size -> Size
negate :: Size -> Size
$cabs :: Size -> Size
abs :: Size -> Size
$csignum :: Size -> Size
signum :: Size -> Size
$cfromInteger :: Integer -> Size
fromInteger :: Integer -> Size
Num, Int -> Size
Size -> Int
Size -> [Size]
Size -> Size
Size -> Size -> [Size]
Size -> Size -> Size -> [Size]
(Size -> Size)
-> (Size -> Size)
-> (Int -> Size)
-> (Size -> Int)
-> (Size -> [Size])
-> (Size -> Size -> [Size])
-> (Size -> Size -> [Size])
-> (Size -> Size -> Size -> [Size])
-> Enum Size
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Size -> Size
succ :: Size -> Size
$cpred :: Size -> Size
pred :: Size -> Size
$ctoEnum :: Int -> Size
toEnum :: Int -> Size
$cfromEnum :: Size -> Int
fromEnum :: Size -> Int
$cenumFrom :: Size -> [Size]
enumFrom :: Size -> [Size]
$cenumFromThen :: Size -> Size -> [Size]
enumFromThen :: Size -> Size -> [Size]
$cenumFromTo :: Size -> Size -> [Size]
enumFromTo :: Size -> Size -> [Size]
$cenumFromThenTo :: Size -> Size -> Size -> [Size]
enumFromThenTo :: Size -> Size -> Size -> [Size]
Enum, Num Size
Ord Size
(Num Size, Ord Size) => (Size -> Rational) -> Real Size
Size -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: Size -> Rational
toRational :: Size -> Rational
Real, Enum Size
Real Size
(Real Size, Enum Size) =>
(Size -> Size -> Size)
-> (Size -> Size -> Size)
-> (Size -> Size -> Size)
-> (Size -> Size -> Size)
-> (Size -> Size -> (Size, Size))
-> (Size -> Size -> (Size, Size))
-> (Size -> Integer)
-> Integral Size
Size -> Integer
Size -> Size -> (Size, Size)
Size -> Size -> Size
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: Size -> Size -> Size
quot :: Size -> Size -> Size
$crem :: Size -> Size -> Size
rem :: Size -> Size -> Size
$cdiv :: Size -> Size -> Size
div :: Size -> Size -> Size
$cmod :: Size -> Size -> Size
mod :: Size -> Size -> Size
$cquotRem :: Size -> Size -> (Size, Size)
quotRem :: Size -> Size -> (Size, Size)
$cdivMod :: Size -> Size -> (Size, Size)
divMod :: Size -> Size -> (Size, Size)
$ctoInteger :: Size -> Integer
toInteger :: Size -> Integer
Integral, (forall ann. Size -> Doc ann)
-> (forall ann. [Size] -> Doc ann) -> Pretty Size
forall ann. [Size] -> Doc ann
forall ann. Size -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Size -> Doc ann
pretty :: forall ann. Size -> Doc ann
$cprettyList :: forall ann. [Size] -> Doc ann
prettyList :: forall ann. [Size] -> Doc ann
Pretty)

instance Monad m => MemoryCell m Size where
  prettyCell :: Size -> m Memory
prettyCell (Size Int
i) = Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell (Int -> String
forall a. Show a => a -> String
show Int
i) []

logstar :: Size -> Credit
logstar :: Size -> Credit
logstar (Size Int
n) = Integer -> Credit
forall a. Num a => Integer -> a
fromInteger (Integer -> Credit) -> Integer -> Credit
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> Integer
forall {t} {t}. (Integral t, Num t) => t -> t -> t
go Int
n Integer
0
  where
    go :: t -> t -> t
go t
n t
acc | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
2 = t
acc
    go t
n t
acc = t -> t -> t
go (t -> t -> t
forall {t} {t}. (Integral t, Num t) => t -> t -> t
log2 t
n t
0) (t
acc t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

    log2 :: t -> t -> t
log2 t
n t
acc | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
2 = t
acc
    log2 t
n t
acc = t -> t -> t
log2 (t
n t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
2) (t
acc t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

log2 :: Size -> Credit
log2 :: Size -> Credit
log2 (Size Int
n) = Integer -> Credit
forall a. Num a => Integer -> a
fromInteger (Integer -> Credit) -> Integer -> Credit
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> Integer
forall {t} {t}. (Integral t, Num t) => t -> t -> t
go Int
n Integer
0
  where
    go :: t -> t -> t
go t
n t
acc | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
2 = t
acc
    go t
n t
acc = t -> t -> t
go (t
n t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
2) (t
acc t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

linear :: Size -> Credit
linear :: Size -> Credit
linear (Size Int
n) = Integer -> Credit
forall a. Num a => Integer -> a
fromInteger (Integer -> Credit) -> Integer -> Credit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n

class (Arbitrary op, Show op) => DataStructure t op | t -> op where
  create :: forall m. MonadInherit m => t m
  action :: forall m. MonadInherit m => t m -> op -> (Credit, m (t m))

runTree :: forall t op. DataStructure t op => Tree op -> Either Error ()
runTree :: forall (t :: (* -> *) -> *) op.
DataStructure t op =>
Tree op -> Either Error ()
runTree Tree op
tree = Credit -> (forall s. CreditM s ()) -> Either Error ()
forall a. Credit -> (forall s. CreditM s a) -> Either Error a
runCreditM Credit
0 (t (CreditM s) -> Tree op -> CreditM s ()
forall s (t :: (* -> *) -> *) op.
DataStructure t op =>
t (CreditM s) -> Tree op -> CreditM s ()
go (forall (t :: (* -> *) -> *) op (m :: * -> *).
(DataStructure t op, MonadInherit m) =>
t m
create @t) Tree op
tree)
  where
    go :: forall s t op. DataStructure t op => t (CreditM s) -> Tree op -> CreditM s ()
    go :: forall s (t :: (* -> *) -> *) op.
DataStructure t op =>
t (CreditM s) -> Tree op -> CreditM s ()
go t (CreditT s Identity)
a (Node op
op [Tree op]
ts) = do
      let (Credit
cr, CreditM s (t (CreditT s Identity))
f) = t (CreditT s Identity)
-> op -> (Credit, CreditM s (t (CreditT s Identity)))
forall (m :: * -> *).
MonadInherit m =>
t m -> op -> (Credit, m (t m))
forall (t :: (* -> *) -> *) op (m :: * -> *).
(DataStructure t op, MonadInherit m) =>
t m -> op -> (Credit, m (t m))
action t (CreditT s Identity)
a op
op
      Credit -> CreditM s ()
forall (m :: * -> *) s. Monad m => Credit -> CreditT s m ()
resetCurrentThunk Credit
cr
      t (CreditT s Identity)
a' <- CreditM s (t (CreditT s Identity))
f
      (Tree op -> CreditM s ()) -> [Tree op] -> CreditM s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (t (CreditT s Identity) -> Tree op -> CreditM s ()
forall s (t :: (* -> *) -> *) op.
DataStructure t op =>
t (CreditM s) -> Tree op -> CreditM s ()
go t (CreditT s Identity)
a') [Tree op]
ts

isPersistent :: Tree a -> Bool
isPersistent :: forall a. Tree a -> Bool
isPersistent (Node a
_ [Tree a]
ts) = [Tree a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| (Tree a -> Bool) -> [Tree a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Tree a -> Bool
forall a. Tree a -> Bool
isPersistent [Tree a]
ts

-- | Evaluate the queue operations using the given strategy on the given queue
-- Reports only if evaluation succeeded.
checkCredits :: forall t op. DataStructure t op => Strategy -> Property
checkCredits :: forall (t :: (* -> *) -> *) op.
DataStructure t op =>
Strategy -> Property
checkCredits Strategy
strat =
  Gen (Tree op)
-> (Tree op -> [Tree op]) -> (Tree op -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Strategy -> Gen (Tree op)
forall op. Arbitrary op => Strategy -> Gen (Tree op)
genTree Strategy
strat) Tree op -> [Tree op]
forall a. Arbitrary a => a -> [a]
shrink ((Tree op -> Property) -> Property)
-> (Tree op -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tree op
t ->
    Bool -> String -> Bool -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (Tree op -> Bool
forall a. Tree a -> Bool
isPersistent Tree op
t) String
"persistent" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
      Either Error () -> Bool
forall a b. Either a b -> Bool
isRight (Either Error () -> Bool) -> Either Error () -> Bool
forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> *) op.
DataStructure t op =>
Tree op -> Either Error ()
runTree @t Tree op
t

data RoseZipper a = Root | Branch a [Tree a] (RoseZipper a)
  deriving (RoseZipper a -> RoseZipper a -> Bool
(RoseZipper a -> RoseZipper a -> Bool)
-> (RoseZipper a -> RoseZipper a -> Bool) -> Eq (RoseZipper a)
forall a. Eq a => RoseZipper a -> RoseZipper a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => RoseZipper a -> RoseZipper a -> Bool
== :: RoseZipper a -> RoseZipper a -> Bool
$c/= :: forall a. Eq a => RoseZipper a -> RoseZipper a -> Bool
/= :: RoseZipper a -> RoseZipper a -> Bool
Eq, Eq (RoseZipper a)
Eq (RoseZipper a) =>
(RoseZipper a -> RoseZipper a -> Ordering)
-> (RoseZipper a -> RoseZipper a -> Bool)
-> (RoseZipper a -> RoseZipper a -> Bool)
-> (RoseZipper a -> RoseZipper a -> Bool)
-> (RoseZipper a -> RoseZipper a -> Bool)
-> (RoseZipper a -> RoseZipper a -> RoseZipper a)
-> (RoseZipper a -> RoseZipper a -> RoseZipper a)
-> Ord (RoseZipper a)
RoseZipper a -> RoseZipper a -> Bool
RoseZipper a -> RoseZipper a -> Ordering
RoseZipper a -> RoseZipper a -> RoseZipper a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (RoseZipper a)
forall a. Ord a => RoseZipper a -> RoseZipper a -> Bool
forall a. Ord a => RoseZipper a -> RoseZipper a -> Ordering
forall a. Ord a => RoseZipper a -> RoseZipper a -> RoseZipper a
$ccompare :: forall a. Ord a => RoseZipper a -> RoseZipper a -> Ordering
compare :: RoseZipper a -> RoseZipper a -> Ordering
$c< :: forall a. Ord a => RoseZipper a -> RoseZipper a -> Bool
< :: RoseZipper a -> RoseZipper a -> Bool
$c<= :: forall a. Ord a => RoseZipper a -> RoseZipper a -> Bool
<= :: RoseZipper a -> RoseZipper a -> Bool
$c> :: forall a. Ord a => RoseZipper a -> RoseZipper a -> Bool
> :: RoseZipper a -> RoseZipper a -> Bool
$c>= :: forall a. Ord a => RoseZipper a -> RoseZipper a -> Bool
>= :: RoseZipper a -> RoseZipper a -> Bool
$cmax :: forall a. Ord a => RoseZipper a -> RoseZipper a -> RoseZipper a
max :: RoseZipper a -> RoseZipper a -> RoseZipper a
$cmin :: forall a. Ord a => RoseZipper a -> RoseZipper a -> RoseZipper a
min :: RoseZipper a -> RoseZipper a -> RoseZipper a
Ord, Int -> RoseZipper a -> ShowS
[RoseZipper a] -> ShowS
RoseZipper a -> String
(Int -> RoseZipper a -> ShowS)
-> (RoseZipper a -> String)
-> ([RoseZipper a] -> ShowS)
-> Show (RoseZipper a)
forall a. Show a => Int -> RoseZipper a -> ShowS
forall a. Show a => [RoseZipper a] -> ShowS
forall a. Show a => RoseZipper a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> RoseZipper a -> ShowS
showsPrec :: Int -> RoseZipper a -> ShowS
$cshow :: forall a. Show a => RoseZipper a -> String
show :: RoseZipper a -> String
$cshowList :: forall a. Show a => [RoseZipper a] -> ShowS
showList :: [RoseZipper a] -> ShowS
Show)

up :: RoseZipper a -> RoseZipper a
up :: forall a. RoseZipper a -> RoseZipper a
up (Branch a
x [Tree a]
ls (Branch a
y [Tree a]
rs RoseZipper a
z)) = a -> [Tree a] -> RoseZipper a -> RoseZipper a
forall a. a -> [Tree a] -> RoseZipper a -> RoseZipper a
Branch a
y (a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
x ([Tree a] -> [Tree a]
forall a. [a] -> [a]
reverse [Tree a]
ls) Tree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
: [Tree a]
rs) RoseZipper a
z
up RoseZipper a
z = RoseZipper a
z

extend :: String -> RoseZipper String -> RoseZipper String
extend :: String -> RoseZipper String -> RoseZipper String
extend String
s (Branch String
x [Tree String]
ls RoseZipper String
z) = String -> [Tree String] -> RoseZipper String -> RoseZipper String
forall a. a -> [Tree a] -> RoseZipper a -> RoseZipper a
Branch (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s) [Tree String]
ls RoseZipper String
z
extend String
_ RoseZipper String
Root = RoseZipper String
forall a. RoseZipper a
Root

extract :: RoseZipper a -> Tree a
extract :: forall a. RoseZipper a -> Tree a
extract (Branch a
x [Tree a]
ls RoseZipper a
Root) = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
x ([Tree a] -> [Tree a]
forall a. [a] -> [a]
reverse [Tree a]
ls)
extract RoseZipper a
z = RoseZipper a -> Tree a
forall a. RoseZipper a -> Tree a
extract (RoseZipper a -> RoseZipper a
forall a. RoseZipper a -> RoseZipper a
up RoseZipper a
z)

flattenTree :: Tree a -> Tree a
flattenTree :: forall a. Tree a -> Tree a
flattenTree Tree a
t = case Tree a -> Maybe [a]
forall {a}. Tree a -> Maybe [a]
go Tree a
t of
  Just (a
x:[a]
xs) -> a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
x ((a -> Tree a) -> [a] -> [Tree a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
x []) [a]
xs)
  Maybe [a]
_ -> Tree a
t
  where
    go :: Tree a -> Maybe [a]
go (Node a
x []) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
x]
    go (Node a
x [Tree a
t]) = (a
x :) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree a -> Maybe [a]
go Tree a
t
    go (Node a
_ [Tree a]
_) = Maybe [a]
forall a. Maybe a
Nothing

showState :: (Either Error (), RoseZipper String) -> String
showState :: (Either Error (), RoseZipper String) -> String
showState (Left Error
e, RoseZipper String
t) = Tree String -> String
drawTree (Tree String -> String) -> Tree String -> String
forall a b. (a -> b) -> a -> b
$ Tree String -> Tree String
forall a. Tree a -> Tree a
flattenTree (Tree String -> Tree String) -> Tree String -> Tree String
forall a b. (a -> b) -> a -> b
$ RoseZipper String -> Tree String
forall a. RoseZipper a -> Tree a
extract (RoseZipper String -> Tree String)
-> RoseZipper String -> Tree String
forall a b. (a -> b) -> a -> b
$ String -> RoseZipper String -> RoseZipper String
extend (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Error -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Error -> Doc ann
pretty Error
e) RoseZipper String
t
showState (Right (), RoseZipper String
t) = Tree String -> String
drawTree (Tree String -> String) -> Tree String -> String
forall a b. (a -> b) -> a -> b
$ Tree String -> Tree String
forall a. Tree a -> Tree a
flattenTree (Tree String -> Tree String) -> Tree String -> Tree String
forall a b. (a -> b) -> a -> b
$ RoseZipper String -> Tree String
forall a. RoseZipper a -> Tree a
extract RoseZipper String
t

type M s = CreditT s (State (RoseZipper String))

runTreeMemory :: forall t op. (MemoryStructure t, DataStructure t op) => Tree op -> String
runTreeMemory :: forall (t :: (* -> *) -> *) op.
(MemoryStructure t, DataStructure t op) =>
Tree op -> String
runTreeMemory Tree op
tree = (Either Error (), RoseZipper String) -> String
showState ((Either Error (), RoseZipper String) -> String)
-> (Either Error (), RoseZipper String) -> String
forall a b. (a -> b) -> a -> b
$ State (RoseZipper String) (Either Error ())
-> RoseZipper String -> (Either Error (), RoseZipper String)
forall s a. State s a -> s -> (a, s)
runState (Credit
-> (forall s. CreditT s (StateT (RoseZipper String) Identity) ())
-> State (RoseZipper String) (Either Error ())
forall (m :: * -> *) a.
Monad m =>
Credit -> (forall s. CreditT s m a) -> m (Either Error a)
runCreditT Credit
0 (t (M s) -> Tree op -> M s ()
forall s (t :: (* -> *) -> *) op.
(MemoryStructure t, DataStructure t op) =>
t (M s) -> Tree op -> M s ()
go (forall (t :: (* -> *) -> *) op (m :: * -> *).
(DataStructure t op, MonadInherit m) =>
t m
create @t) Tree op
tree)) RoseZipper String
forall a. RoseZipper a
Root
  where
    go :: forall s t op. (MemoryStructure t, DataStructure t op) => t (M s) -> Tree op -> M s ()
    go :: forall s (t :: (* -> *) -> *) op.
(MemoryStructure t, DataStructure t op) =>
t (M s) -> Tree op -> M s ()
go t (CreditT s (StateT (RoseZipper String) Identity))
a (Node op
op [Tree op]
ts) = do
      let (Credit
cr, M s (t (CreditT s (StateT (RoseZipper String) Identity)))
f) = t (CreditT s (StateT (RoseZipper String) Identity))
-> op
-> (Credit,
    M s (t (CreditT s (StateT (RoseZipper String) Identity))))
forall (m :: * -> *).
MonadInherit m =>
t m -> op -> (Credit, m (t m))
forall (t :: (* -> *) -> *) op (m :: * -> *).
(DataStructure t op, MonadInherit m) =>
t m -> op -> (Credit, m (t m))
action t (CreditT s (StateT (RoseZipper String) Identity))
a op
op
      Credit -> M s ()
forall (m :: * -> *) s. Monad m => Credit -> CreditT s m ()
resetCurrentThunk Credit
cr
      State (RoseZipper String) () -> M s ()
forall (m :: * -> *) a. Monad m => m a -> CreditT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State (RoseZipper String) () -> M s ())
-> State (RoseZipper String) () -> M s ()
forall a b. (a -> b) -> a -> b
$ (RoseZipper String -> RoseZipper String)
-> State (RoseZipper String) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (String -> [Tree String] -> RoseZipper String -> RoseZipper String
forall a. a -> [Tree a] -> RoseZipper a -> RoseZipper a
Branch (op -> String
forall a. Show a => a -> String
show op
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") []) 
      t (CreditT s (StateT (RoseZipper String) Identity))
a' <- M s (t (CreditT s (StateT (RoseZipper String) Identity)))
f
      Memory
mem <- t (CreditT s (StateT (RoseZipper String) Identity))
-> CreditT s (StateT (RoseZipper String) Identity) Memory
forall (m :: * -> *). MonadMemory m => t m -> m Memory
forall (t :: (* -> *) -> *) (m :: * -> *).
(MemoryStructure t, MonadMemory m) =>
t m -> m Memory
prettyStructure t (CreditT s (StateT (RoseZipper String) Identity))
a'
      let s :: String
s = SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream Any -> String) -> SimpleDocStream Any -> String
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (LayoutOptions
defaultLayoutOptions { layoutPageWidth = Unbounded }) (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$ Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc Any -> Doc Any) -> Doc Any -> Doc Any
forall a b. (a -> b) -> a -> b
$ Memory -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Memory -> Doc ann
pretty (Memory -> Doc Any) -> Memory -> Doc Any
forall a b. (a -> b) -> a -> b
$ Memory
mem
      State (RoseZipper String) () -> M s ()
forall (m :: * -> *) a. Monad m => m a -> CreditT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State (RoseZipper String) () -> M s ())
-> State (RoseZipper String) () -> M s ()
forall a b. (a -> b) -> a -> b
$ (RoseZipper String -> RoseZipper String)
-> State (RoseZipper String) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (String -> RoseZipper String -> RoseZipper String
extend String
s)
      (Tree op -> M s ()) -> [Tree op] -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (t (CreditT s (StateT (RoseZipper String) Identity))
-> Tree op -> M s ()
forall s (t :: (* -> *) -> *) op.
(MemoryStructure t, DataStructure t op) =>
t (M s) -> Tree op -> M s ()
go t (CreditT s (StateT (RoseZipper String) Identity))
a') [Tree op]
ts
      State (RoseZipper String) () -> M s ()
forall (m :: * -> *) a. Monad m => m a -> CreditT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State (RoseZipper String) () -> M s ())
-> State (RoseZipper String) () -> M s ()
forall a b. (a -> b) -> a -> b
$ (RoseZipper String -> RoseZipper String)
-> State (RoseZipper String) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' RoseZipper String -> RoseZipper String
forall a. RoseZipper a -> RoseZipper a
up

-- | Evaluate the queue operations using the given strategy on the given queue
-- Reports only if evaluation succeeded.
checkCreditsMemory :: forall t op. (MemoryStructure t, DataStructure t op) => Strategy -> Property
checkCreditsMemory :: forall (t :: (* -> *) -> *) op.
(MemoryStructure t, DataStructure t op) =>
Strategy -> Property
checkCreditsMemory Strategy
strat =
  Gen (Tree op)
-> (Tree op -> [Tree op])
-> (Tree op -> String)
-> (Tree op -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow (Strategy -> Gen (Tree op)
forall op. Arbitrary op => Strategy -> Gen (Tree op)
genTree Strategy
strat) Tree op -> [Tree op]
forall a. Arbitrary a => a -> [a]
shrink (\Tree op
t -> forall (t :: (* -> *) -> *) op.
(MemoryStructure t, DataStructure t op) =>
Tree op -> String
runTreeMemory @t Tree op
t) ((Tree op -> Property) -> Property)
-> (Tree op -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tree op
t ->
    Bool -> String -> Bool -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify (Tree op -> Bool
forall a. Tree a -> Bool
isPersistent Tree op
t) String
"persistent" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
      Either Error () -> Bool
forall a b. Either a b -> Bool
isRight (Either Error () -> Bool) -> Either Error () -> Bool
forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> *) op.
DataStructure t op =>
Tree op -> Either Error ()
runTree @t Tree op
t