{-# LANGUAGE BangPatterns #-}
module Transient.Indeterminism (
choose, choose', collect, collect', group, groupByTime
) where
import Transient.Base
import Transient.Backtrack(checkFinalize)
import Transient.Internals(killChildren, EventF(..),hangThread)
import Data.IORef
import Control.Applicative
import Data.Monoid
import Control.Concurrent
import Data.Typeable
import Control.Monad.State
import Control.Concurrent.STM as STM
import GHC.Conc
import Data.Time.Clock
choose :: Show a => [a] -> TransIO a
choose []= empty
choose xs = do
evs <- liftIO $ newIORef xs
r <- parallel $ do
es <- atomicModifyIORef' evs $ \es -> let !tes= tail es in (tes,es)
case es of
[x] -> x `seq` return $ SLast x
x:_ -> x `seq` return $ SMore x
checkFinalize r
group :: Int -> TransIO a -> TransIO [a]
group num proc = do
v <- liftIO $ newIORef (0,[])
x <- proc
mn <- liftIO $ atomicModifyIORef' v $ \(n,xs) ->
let !n'=n +1
in if n'== num
then ((0,[]), Just xs)
else ((n', x:xs),Nothing)
case mn of
Nothing -> stop
Just xs -> return xs
groupByTime :: Integer -> TransIO a -> TransIO [a]
groupByTime time proc = do
v <- liftIO $ newIORef (0,[])
t <- liftIO getCurrentTime
x <- proc
t' <- liftIO getCurrentTime
mn <- liftIO $ atomicModifyIORef' v $ \(n,xs) -> let !n'=n +1
in
if diffUTCTime t' t < fromIntegral time
then ((n', x:xs),Nothing)
else ((0,[]), Just xs)
case mn of
Nothing -> stop
Just xs -> return xs
choose' :: [a] -> TransIO a
choose' xs = foldl (<|>) empty $ map (async . return) xs
collect :: Int -> TransIO a -> TransIO [a]
collect n = collect' n 0.1 0
collect' :: Int -> NominalDiffTime -> NominalDiffTime -> TransIO a -> TransIO [a]
collect' n t1 t2 search= hookedThreads $ do
rv <- liftIO $ atomically $ newTVar (0,[])
endflag <- liftIO $ newTVarIO False
st <- newPool
t <- liftIO getCurrentTime
let worker = do
r <- search
liftIO $ atomically $ do
(n1,rs) <- readTVar rv
writeTVar rv (n1+1,r:rs)
stop
monitor= freeThreads $ do
xs <- async $ atomically $
do (n', xs) <- readTVar rv
ns <- readTVar $ children st
t' <- unsafeIOToSTM getCurrentTime
if
(n > 0 && n' >= n) ||
(null ns && (diffUTCTime t' t > t1)) ||
(t2 > 0 && diffUTCTime t' t > t2)
then return xs else retry
liftIO . killChildren $ children st
return xs
monitor <|> worker
where
newPool = do
chs <- liftIO $ newTVarIO []
s <- get
let s'= s{children= chs}
put s'
return s'