module Control.Wire.Session
(
stepSession,
stepSession_,
stepSessionP,
stepSessionP_,
testWire,
testWireP,
testPrint,
Session(..),
genSession,
clockSession,
counterSession,
frozenSession
)
where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Wire.Types
import Control.Wire.Wire
import Data.Monoid
import Data.Time.Clock
import System.IO
newtype Session m =
Session {
sessionUpdate :: m (Time, Session m)
}
clockSession :: (MonadIO m) => Session m
clockSession =
Session $ do
t0 <- liftIO getCurrentTime
return (0, loop t0)
where
loop t' =
Session $ do
t <- liftIO getCurrentTime
let dt = realToFrac (diffUTCTime t t')
return (dt, loop t)
counterSession ::
(Monad m)
=> Time
-> Session m
counterSession dt =
let s = Session (return (dt, s)) in s
frozenSession :: (Monad m) => Session m
frozenSession = counterSession 0
genSession ::
(Monad m)
=> a
-> (a -> m (Time, a))
-> Session m
genSession s' f =
Session $ do
(t, s) <- f s'
return (t, genSession s f)
stepSession ::
(MonadIO m)
=> Wire e m a b
-> Session m
-> a
-> m (Either e b, Wire e m a b, Session m)
stepSession w' (Session update) x' = do
(dt, s) <- update
(mx, w) <- stepWire w' dt x'
mx `seq` return (mx, w, s)
stepSession_ ::
(MonadIO m)
=> WireM m a b
-> Session m
-> a
-> m (b, WireM m a b, Session m)
stepSession_ w' s' x' = do
(mx, w, s) <- stepSession w' s' x'
let throwM = liftIO . throwIO
emptyErr = toException (userError "empty inhibition signal")
x <- either (throwM . maybe emptyErr id . getLast) return mx
return (x, w, s)
stepSessionP ::
(Monad m)
=> Wire e Identity a b
-> Session m
-> a
-> m (Either e b, Wire e Identity a b, Session m)
stepSessionP w' (Session update) !x' = do
(dt, s) <- update
let (mx, w) = stepWireP w' dt x'
mx `seq` return (mx, w, s)
stepSessionP_ ::
(MonadIO m)
=> WireP a b
-> Session m
-> a
-> m (b, WireP a b, Session m)
stepSessionP_ w' s' !x' = do
(mx, w, s) <- stepSessionP w' s' x'
let throwM = liftIO . throwIO
emptyErr = toException (userError "empty inhibition signal")
x <- either (throwM . maybe emptyErr id . getLast) return mx
return (x, w, s)
testPrint :: (Show e) => Int -> Int -> Either e String -> IO Int
testPrint n' int mx = do
let n = let nn = n' + 1 in
if nn >= int then 0 else nn
when (n' == 0) $ do
hPutStr stderr "\r\027[K"
hPutStr stderr (either (("(I) " ++) . show) id mx)
hFlush stderr
n `seq` return n
testWire ::
forall a b e m. (MonadIO m, Show e)
=> Int
-> Int
-> m a
-> Session m
-> Wire e m a String
-> m b
testWire int delay getInput = loop 0
where
loop :: Int -> Session m -> Wire e m a String -> m b
loop n' s' w' = do
x' <- getInput
(mx, w, s) <- stepSession w' s' x'
n <- mx `seq` liftIO (testPrint n' int mx)
when (delay > 0) (liftIO (threadDelay delay))
loop n s w
testWireP ::
forall a b e m. (MonadIO m, Show e)
=> Int
-> Int
-> m a
-> Session m
-> Wire e Identity a String
-> m b
testWireP int delay getInput = loop 0
where
loop :: Int -> Session m -> Wire e Identity a String -> m b
loop n' s' w' = do
x' <- getInput
(mx, w, s) <- stepSessionP w' s' x'
n <- mx `seq` liftIO (testPrint n' int mx)
when (delay > 0) (liftIO (threadDelay delay))
loop n s w