module Test.Framework.Improving (
        (:~>)(..), bimapImproving, improvingLast, consumeImproving,
        ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO,
        timeoutImprovingIO, maybeTimeoutImprovingIO
    ) where

import Control.Concurrent
    ( yield, getChanContents, newChan, writeChan, Chan )
import Control.Monad (ap, liftM)

import System.Timeout ( timeout )


data i :~> f = Finished f
             | Improving i (i :~> f)

instance Functor ((:~>) i) where
    fmap :: forall a b. (a -> b) -> (i :~> a) -> i :~> b
fmap a -> b
f (Finished a
x)    = b -> i :~> b
forall i f. f -> i :~> f
Finished (a -> b
f a
x)
    fmap a -> b
f (Improving i
x 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 a b. (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 :: forall a c b d. (a -> c) -> (b -> d) -> (a :~> b) -> c :~> d
bimapImproving a -> c
_ b -> d
g (Finished b
b)            = d -> c :~> d
forall i f. f -> i :~> f
Finished (b -> d
g b
b)
bimapImproving a -> c
f b -> d
g (Improving a
a 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 :: forall a b. (a :~> b) -> b
improvingLast (Finished b
r)       = b
r
improvingLast (Improving a
_ a :~> b
rest) = (a :~> b) -> b
forall a b. (a :~> b) -> b
improvingLast a :~> b
rest

consumeImproving :: (a :~> b) -> [(a :~> b)]
consumeImproving :: forall a b. (a :~> b) -> [a :~> b]
consumeImproving improving :: a :~> b
improving@(Finished b
_)       = [a :~> b
improving]
consumeImproving improving :: a :~> b
improving@(Improving a
_ 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 { forall i f a. ImprovingIO i f a -> Chan (Either i f) -> IO a
unIIO :: Chan (Either i f) -> IO a }

instance Functor (ImprovingIO i f) where
    fmap :: forall a b. (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 :: forall a. a -> ImprovingIO i f a
pure 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
    <*> :: forall a b.
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 :: forall a. a -> ImprovingIO i f a
return = a -> ImprovingIO i f a
forall a. a -> ImprovingIO i f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ImprovingIO i f a
ma >>= :: forall a b.
ImprovingIO i f a -> (a -> ImprovingIO i f b) -> ImprovingIO i f b
>>= 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 (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 :: forall i f. i -> ImprovingIO i f ()
yieldImprovement 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 (Either i f)
chan -> do
    -- Whenever we yield an improvement, take the opportunity to yield the thread as well.
    -- The idea here is to introduce frequent yields in users so that if e.g. they get killed
    -- by the timeout code then they know about it reasonably promptly.
    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)

-- NB: could have a more general type but it would be impredicative
tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a)
tunnelImprovingIO :: forall i f a. 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 (Either i f)
chan -> (ImprovingIO i f a -> IO a) -> IO (ImprovingIO i f a -> IO a)
forall a. 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
$ \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 :: forall i f. ImprovingIO i f f -> IO (i :~> f, IO ())
runImprovingIO 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 a. a -> IO a
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 :: forall i f. [Either i f] -> i :~> f
reifyListToImproving (Left i
improvement:[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 f
final:[Either i f]
_)         = f -> i :~> f
forall i f. f -> i :~> f
Finished f
final
reifyListToImproving []                      = [Char] -> i :~> f
forall a. HasCallStack => [Char] -> a
error [Char]
"reifyListToImproving: list finished before a final value arrived"

liftIO :: IO a -> ImprovingIO i f a
liftIO :: forall a i f. IO a -> ImprovingIO i f a
liftIO 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

-- | Given a number of microseconds and an improving IO action, run that improving IO action only
-- for at most the given period before giving up. See also 'System.Timeout.timeout'.
timeoutImprovingIO :: Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
timeoutImprovingIO :: forall i f a. Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
timeoutImprovingIO Int
microseconds 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 (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

-- | As 'timeoutImprovingIO', but don't bother applying a timeout to the action if @Nothing@ is given
-- as the number of microseconds to apply the time out for.
maybeTimeoutImprovingIO :: Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO :: forall i f a.
Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO Maybe Int
Nothing             = (a -> Maybe a) -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
forall a b. (a -> b) -> ImprovingIO i f a -> ImprovingIO i f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
maybeTimeoutImprovingIO (Just 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