module Test.Framework.Improving (
(:~>)(..), bimapImproving, improvingLast, consumeImproving,
ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO,
timeoutImprovingIO, maybeTimeoutImprovingIO
) where
import Control.Concurrent
import Control.Monad
import Control.Applicative as App
import System.Timeout
data i :~> f = Finished f
| Improving i (i :~> f)
instance Functor ((:~>) i) where
fmap :: (a -> b) -> (i :~> a) -> i :~> b
fmap f :: a -> b
f (Finished x :: a
x) = b -> i :~> b
forall i f. f -> i :~> f
Finished (a -> b
f a
x)
fmap f :: a -> b
f (Improving x :: i
x i :: i :~> a
i) = i -> (i :~> b) -> i :~> b
forall i f. i -> (i :~> f) -> i :~> f
Improving i
x ((a -> b) -> (i :~> a) -> i :~> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f i :~> a
i)
bimapImproving :: (a -> c) -> (b -> d) -> (a :~> b) -> (c :~> d)
bimapImproving :: (a -> c) -> (b -> d) -> (a :~> b) -> c :~> d
bimapImproving _ g :: b -> d
g (Finished b :: b
b) = d -> c :~> d
forall i f. f -> i :~> f
Finished (b -> d
g b
b)
bimapImproving f :: a -> c
f g :: b -> d
g (Improving a :: a
a improving :: a :~> b
improving) = c -> (c :~> d) -> c :~> d
forall i f. i -> (i :~> f) -> i :~> f
Improving (a -> c
f a
a) ((a -> c) -> (b -> d) -> (a :~> b) -> c :~> d
forall a c b d. (a -> c) -> (b -> d) -> (a :~> b) -> c :~> d
bimapImproving a -> c
f b -> d
g a :~> b
improving)
improvingLast :: (a :~> b) -> b
improvingLast :: (a :~> b) -> b
improvingLast (Finished r :: b
r) = b
r
improvingLast (Improving _ rest :: a :~> b
rest) = (a :~> b) -> b
forall a b. (a :~> b) -> b
improvingLast a :~> b
rest
consumeImproving :: (a :~> b) -> [(a :~> b)]
consumeImproving :: (a :~> b) -> [a :~> b]
consumeImproving improving :: a :~> b
improving@(Finished _) = [a :~> b
improving]
consumeImproving improving :: a :~> b
improving@(Improving _ rest :: a :~> b
rest) = a :~> b
improving (a :~> b) -> [a :~> b] -> [a :~> b]
forall a. a -> [a] -> [a]
: (a :~> b) -> [a :~> b]
forall a b. (a :~> b) -> [a :~> b]
consumeImproving a :~> b
rest
newtype ImprovingIO i f a = IIO { ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO :: Chan (Either i f) -> IO a }
instance Functor (ImprovingIO i f) where
fmap :: (a -> b) -> ImprovingIO i f a -> ImprovingIO i f b
fmap = (a -> b) -> ImprovingIO i f a -> ImprovingIO i f b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative (ImprovingIO i f) where
pure :: a -> ImprovingIO i f a
pure x :: a
x = (Chan (Either i f) -> IO a) -> ImprovingIO i f a
forall i f a. (Chan (Either i f) -> IO a) -> ImprovingIO i f a
IIO (IO a -> Chan (Either i f) -> IO a
forall a b. a -> b -> a
const (IO a -> Chan (Either i f) -> IO a)
-> IO a -> Chan (Either i f) -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
<*> :: ImprovingIO i f (a -> b) -> ImprovingIO i f a -> ImprovingIO i f b
(<*>) = ImprovingIO i f (a -> b) -> ImprovingIO i f a -> ImprovingIO i f b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (ImprovingIO i f) where
return :: a -> ImprovingIO i f a
return = a -> ImprovingIO i f a
forall (f :: * -> *) a. Applicative f => a -> f a
App.pure
ma :: ImprovingIO i f a
ma >>= :: ImprovingIO i f a -> (a -> ImprovingIO i f b) -> ImprovingIO i f b
>>= f :: a -> ImprovingIO i f b
f = (Chan (Either i f) -> IO b) -> ImprovingIO i f b
forall i f a. (Chan (Either i f) -> IO a) -> ImprovingIO i f a
IIO ((Chan (Either i f) -> IO b) -> ImprovingIO i f b)
-> (Chan (Either i f) -> IO b) -> ImprovingIO i f b
forall a b. (a -> b) -> a -> b
$ \chan :: Chan (Either i f)
chan -> do
a
a <- ImprovingIO i f a -> Chan (Either i f) -> IO a
forall i f a. ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO ImprovingIO i f a
ma Chan (Either i f)
chan
ImprovingIO i f b -> Chan (Either i f) -> IO b
forall i f a. ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO (a -> ImprovingIO i f b
f a
a) Chan (Either i f)
chan
yieldImprovement :: i -> ImprovingIO i f ()
yieldImprovement :: i -> ImprovingIO i f ()
yieldImprovement improvement :: i
improvement = (Chan (Either i f) -> IO ()) -> ImprovingIO i f ()
forall i f a. (Chan (Either i f) -> IO a) -> ImprovingIO i f a
IIO ((Chan (Either i f) -> IO ()) -> ImprovingIO i f ())
-> (Chan (Either i f) -> IO ()) -> ImprovingIO i f ()
forall a b. (a -> b) -> a -> b
$ \chan :: Chan (Either i f)
chan -> do
IO ()
yield
Chan (Either i f) -> Either i f -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either i f)
chan (i -> Either i f
forall a b. a -> Either a b
Left i
improvement)
tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a)
tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a)
tunnelImprovingIO = (Chan (Either i f) -> IO (ImprovingIO i f a -> IO a))
-> ImprovingIO i f (ImprovingIO i f a -> IO a)
forall i f a. (Chan (Either i f) -> IO a) -> ImprovingIO i f a
IIO ((Chan (Either i f) -> IO (ImprovingIO i f a -> IO a))
-> ImprovingIO i f (ImprovingIO i f a -> IO a))
-> (Chan (Either i f) -> IO (ImprovingIO i f a -> IO a))
-> ImprovingIO i f (ImprovingIO i f a -> IO a)
forall a b. (a -> b) -> a -> b
$ \chan :: Chan (Either i f)
chan -> (ImprovingIO i f a -> IO a) -> IO (ImprovingIO i f a -> IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ImprovingIO i f a -> IO a) -> IO (ImprovingIO i f a -> IO a))
-> (ImprovingIO i f a -> IO a) -> IO (ImprovingIO i f a -> IO a)
forall a b. (a -> b) -> a -> b
$ \iio :: ImprovingIO i f a
iio -> ImprovingIO i f a -> Chan (Either i f) -> IO a
forall i f a. ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO ImprovingIO i f a
iio Chan (Either i f)
chan
runImprovingIO :: ImprovingIO i f f -> IO (i :~> f, IO ())
runImprovingIO :: ImprovingIO i f f -> IO (i :~> f, IO ())
runImprovingIO iio :: ImprovingIO i f f
iio = do
Chan (Either i f)
chan <- IO (Chan (Either i f))
forall a. IO (Chan a)
newChan
let action :: IO ()
action = do
f
result <- ImprovingIO i f f -> Chan (Either i f) -> IO f
forall i f a. ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO ImprovingIO i f f
iio Chan (Either i f)
chan
Chan (Either i f) -> Either i f -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Either i f)
chan (f -> Either i f
forall a b. b -> Either a b
Right f
result)
[Either i f]
improving_value <- Chan (Either i f) -> IO [Either i f]
forall a. Chan a -> IO [a]
getChanContents Chan (Either i f)
chan
(i :~> f, IO ()) -> IO (i :~> f, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either i f] -> i :~> f
forall i f. [Either i f] -> i :~> f
reifyListToImproving [Either i f]
improving_value, IO ()
action)
reifyListToImproving :: [Either i f] -> (i :~> f)
reifyListToImproving :: [Either i f] -> i :~> f
reifyListToImproving (Left improvement :: i
improvement:rest :: [Either i f]
rest) = i -> (i :~> f) -> i :~> f
forall i f. i -> (i :~> f) -> i :~> f
Improving i
improvement ([Either i f] -> i :~> f
forall i f. [Either i f] -> i :~> f
reifyListToImproving [Either i f]
rest)
reifyListToImproving (Right final :: f
final:_) = f -> i :~> f
forall i f. f -> i :~> f
Finished f
final
reifyListToImproving [] = [Char] -> i :~> f
forall a. HasCallStack => [Char] -> a
error "reifyListToImproving: list finished before a final value arrived"
liftIO :: IO a -> ImprovingIO i f a
liftIO :: IO a -> ImprovingIO i f a
liftIO io :: IO a
io = (Chan (Either i f) -> IO a) -> ImprovingIO i f a
forall i f a. (Chan (Either i f) -> IO a) -> ImprovingIO i f a
IIO ((Chan (Either i f) -> IO a) -> ImprovingIO i f a)
-> (Chan (Either i f) -> IO a) -> ImprovingIO i f a
forall a b. (a -> b) -> a -> b
$ IO a -> Chan (Either i f) -> IO a
forall a b. a -> b -> a
const IO a
io
timeoutImprovingIO :: Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
timeoutImprovingIO :: Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
timeoutImprovingIO microseconds :: Int
microseconds iio :: ImprovingIO i f a
iio = (Chan (Either i f) -> IO (Maybe a)) -> ImprovingIO i f (Maybe a)
forall i f a. (Chan (Either i f) -> IO a) -> ImprovingIO i f a
IIO ((Chan (Either i f) -> IO (Maybe a)) -> ImprovingIO i f (Maybe a))
-> (Chan (Either i f) -> IO (Maybe a)) -> ImprovingIO i f (Maybe a)
forall a b. (a -> b) -> a -> b
$ \chan :: Chan (Either i f)
chan -> Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
microseconds (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ImprovingIO i f a -> Chan (Either i f) -> IO a
forall i f a. ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO ImprovingIO i f a
iio Chan (Either i f)
chan
maybeTimeoutImprovingIO :: Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO :: Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO Nothing = (a -> Maybe a) -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
maybeTimeoutImprovingIO (Just microseconds :: Int
microseconds) = Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
forall i f a. Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
timeoutImprovingIO Int
microseconds