    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 <- 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
                        unIIO (f a) 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 <- IO (Chan (Either i f))
    forall a. IO (Chan a)
    newChan
        let action = do
            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
            writeChan chan (Right result)
        improving_value <- getChanContents chan
        return (reifyListToImproving improving_value, 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