module Util.Sources(
Source,
Client,
staticSource,
staticSourceIO,
variableSource,
variableGeneralSource,
Updater,
applyToUpdater,
attachClient,
map1,
map1IO,
map2,
filter2,
filter2IO,
foldSource,
foldSourceIO,
stepSource,
choose,
seqSource,
flattenSource,
SimpleSource(..),
staticSimpleSource,
staticSimpleSourceIO,
HasSource(..),
HasSimpleSource(..),
readContents,
mkHistorySource,
mkHistorySimpleSource,
uniqSimpleSource,
pairSimpleSources,
sequenceSimpleSource,
change1,
mapIOSeq,
addNewSourceActions,
traceSimpleSource,
traceSource,
noLoopSimpleSource,
mkIOSimpleSource,
foldSimpleSourceIO,
) where
import Data.Maybe
import Control.Concurrent
import Data.IORef
import Util.ExtendedPrelude(HasMapIO(..))
import Util.Sink
import Util.TSem
import Util.Debug(debug)
newtype Source x d = Source (Client d -> IO x)
newtype Client d = Client (d -> IO (Maybe (Client d)))
data SourceData x d = SourceData {
x :: x,
client :: Maybe (Client d)
}
staticSource :: x -> Source x d
staticSource x = Source (\ _ -> return x)
staticSourceIO :: IO x -> Source x d
staticSourceIO action = Source (\ _ -> action)
variableSource :: x -> IO (Source x d,(x -> (x,[d])) -> IO ())
variableSource x =
do
mVar <- newMVar (SourceData {
x = x,
client = Nothing
})
let
update updateFn =
do
(SourceData {x = x1,client = clientOpt}) <- takeMVar mVar
let
(x2,ds) = updateFn x1
sendUpdates (Just (Client clientFn)) (d:ds) =
do
newClientOpt <- clientFn d
sendUpdates newClientOpt ds
sendUpdates clientOpt _ = return clientOpt
newClientOpt <- sendUpdates clientOpt ds
putMVar mVar (SourceData {x = x2,client = newClientOpt})
addClient newClient =
do
(SourceData {x = x,client = oldClientOpt}) <- takeMVar mVar
let
fullNewClient = case oldClientOpt of
Nothing -> newClient
Just oldClient -> combineClients oldClient newClient
putMVar mVar (SourceData {x = x,client = Just fullNewClient})
return x
return (Source addClient,update)
newtype Updater x d = Updater (forall extra . (x -> (x,[d],extra)) -> IO extra)
applyToUpdater :: Updater x d -> (x -> (x,[d],extra)) -> IO extra
applyToUpdater (Updater update) updateAct = update updateAct
variableGeneralSource :: x -> IO (Source x d,Updater x d)
variableGeneralSource x =
do
mVar <- newMVar (SourceData {
x = x,
client = Nothing
})
let
update updateFn =
do
(SourceData {x = x1,client = clientOpt}) <- takeMVar mVar
let
(x2,ds,extra) = updateFn x1
sendUpdates (Just (Client clientFn)) (d:ds) =
do
newClientOpt <- clientFn d
sendUpdates newClientOpt ds
sendUpdates clientOpt _ = return clientOpt
newClientOpt <- sendUpdates clientOpt ds
putMVar mVar (SourceData {x = x2,client = newClientOpt})
return extra
addClient newClient =
do
(SourceData {x = x,client = oldClientOpt}) <- takeMVar mVar
let
fullNewClient = case oldClientOpt of
Nothing -> newClient
Just oldClient -> combineClients oldClient newClient
putMVar mVar (SourceData {x = x,client = Just fullNewClient})
return x
return (Source addClient,Updater update)
combineClients :: Client d -> Client d -> Client d
combineClients (Client clientFn1) (Client clientFn2) =
let
clientFn d =
do
newClient1Opt <- clientFn1 d
newClient2Opt <- clientFn2 d
case (newClient1Opt,newClient2Opt) of
(Nothing,Nothing) -> return Nothing
(Just newClient1,Nothing) -> return (Just newClient1)
(Nothing,Just newClient2) -> return (Just newClient2)
(Just newClient1,Just newClient2)
-> return (Just (combineClients newClient1 newClient2))
in
Client clientFn
attachClient :: Client d -> Source x d -> IO x
attachClient client (Source addClient) = addClient client
attachClientTemporary :: Client d -> Source x d -> IO (x,IO ())
attachClientTemporary client source =
do
(newClient,terminator) <- mkTemporaryClient client
x <- attachClient newClient source
return (x,terminator)
mkTemporaryClient :: Client d -> IO (Client d,IO ())
mkTemporaryClient client =
do
ioRef <- newIORef True
let
newClient client = Client (newClientFn client)
newClientFn (Client oldClientFn) d =
do
goAhead <- readIORef ioRef
if goAhead
then
do
newClientOpt <- oldClientFn d
return (fmap newClient newClientOpt)
else
return Nothing
return (newClient client,writeIORef ioRef False)
mkComputedClient :: (x -> Client d) -> IO (Client d,x -> IO ())
mkComputedClient getClient =
do
mVar <- newEmptyMVar
let
client = Client clientFn
clientFn d =
do
x <- takeMVar mVar
let
(Client realClientFn) = getClient x
realClientFn d
return (client,putMVar mVar)
mkComputedClientIO :: (x -> IO (Maybe (Client d))) -> IO (Client d,x -> IO ())
mkComputedClientIO getClient =
do
mVar <- newEmptyMVar
let
client = Client clientFn
clientFn d =
do
x <- takeMVar mVar
clientOpt <- getClient x
case clientOpt of
Nothing -> return Nothing
Just (Client realClientFn) -> realClientFn d
return (client,putMVar mVar)
mkStaticClient :: Client d -> IO (Client d)
mkStaticClient client =
do
(newClient,_) <- mkStaticClientGeneral client
return newClient
mkStaticClientGeneral :: Client d -> IO (Client d,IO Bool)
mkStaticClientGeneral (client :: Client d) =
do
mVar <- newMVar (Just client)
let
client = Client clientFn
clientFn d =
do
clientOpt <- takeMVar mVar
case clientOpt of
Nothing -> do
putMVar mVar clientOpt
return Nothing
Just (Client clientFnInner) ->
do
newClientOpt <- clientFnInner d
putMVar mVar newClientOpt
return (Just client)
clientRunning =
do
clientOpt <- readMVar mVar
return (isJust clientOpt)
return (client,clientRunning)
map1 :: (x1 -> x2) -> Source x1 d -> Source x2 d
map1 mapFn (Source addClient1) =
let
addClient2 d =
do
x1 <- addClient1 d
return (mapFn x1)
in
Source addClient2
map1IO :: (x1 -> IO x2) -> Source x1 d -> Source x2 d
map1IO mapFn (Source addClient1) =
let
addClient2 d =
do
x1 <- addClient1 d
mapFn x1
in
Source addClient2
map2 :: (d1 -> d2) -> Source x d1 -> Source x d2
map2 mapFn (Source addClient1) =
let
addClient2 newClient1 = addClient1 (coMapClient mapFn newClient1)
in
Source addClient2
coMapClient :: (d1 -> d2) -> Client d2 -> Client d1
coMapClient mapFn (Client clientFn2) =
let
client1 = Client clientFn1
clientFn1 d1 =
do
let
d2 = mapFn d1
newClient2Opt <- clientFn2 d2
return (fmap
(coMapClient mapFn)
newClient2Opt
)
in
client1
filter2 :: (d1 -> Maybe d2) -> Source x d1 -> Source x d2
filter2 filterFn (Source addClient1) =
let
addClient2 newClient1 = addClient1 (filterClient filterFn newClient1)
in
Source addClient2
filterClient :: (d1 -> Maybe d2) -> Client d2 -> Client d1
filterClient filterFn (Client clientFn2) =
let
client1 = Client clientFn1
clientFn1 d1 =
let
d2Opt = filterFn d1
in
case d2Opt of
Nothing -> return (Just client1)
Just d2 ->
do
newClient2Opt <- clientFn2 d2
return (fmap
(filterClient filterFn)
newClient2Opt
)
in
client1
filter2IO :: (d1 -> IO (Maybe d2)) -> Source x d1 -> Source x d2
filter2IO filterFn (Source addClient1) =
let
addClient2 newClient1 = addClient1 (filterClientIO filterFn newClient1)
in
Source addClient2
filterClientIO :: (d1 -> IO (Maybe d2)) -> Client d2 -> Client d1
filterClientIO filterFn (Client clientFn2) =
let
client1 = Client clientFn1
clientFn1 d1 =
do
d2Opt <- filterFn d1
case d2Opt of
Nothing -> return (Just client1)
Just d2 ->
do
newClient2Opt <- clientFn2 d2
return (fmap
(filterClientIO filterFn)
newClient2Opt
)
in
client1
foldSource :: (x -> state) -> (state -> d1 -> (state,d2))
-> Source x d1 -> Source (state,x) d2
foldSource xFn foldFn =
let
xFnIO x = return (xFn x,x)
foldFnIO state d = return (foldFn state d)
in
foldSourceIO xFnIO foldFnIO
foldSourceIO :: (x1 -> IO (state,x2)) -> (state -> d1 -> IO (state,d2))
-> Source x1 d1 -> Source (state,x2) d2
foldSourceIO (xFnIO :: x1 -> IO (state,x2))
(foldFnIO :: state -> d1 -> IO (state,d2))
((Source addClient1) :: Source x1 d1) =
let
addClient2 :: Client d2 -> IO (state,x2)
addClient2 client2 =
do
let
createClient :: state -> Client d1
createClient state = foldClientIO state foldFnIO client2
(computedClient,writeState) <- mkComputedClient createClient
x1 <- addClient1 computedClient
(state,x2) <- xFnIO x1
writeState state
return (state,x2)
in
Source addClient2
foldClientIO
:: state -> (state -> d1 -> IO (state,d2)) -> Client d2 -> Client d1
foldClientIO state1 foldFnIO (Client clientFn2) =
let
clientFn1 d1 =
do
(state2,d2) <- foldFnIO state1 d1
(newClient2Opt) <- clientFn2 d2
return (fmap
(foldClientIO state2 foldFnIO)
newClient2Opt
)
in
Client clientFn1
stepSource :: (x -> d2) -> (d1 -> d2) -> Source x d1 -> Source x d2
stepSource fromX fromD (Source addClient1) =
let
addClient2 (Client clientFn2) =
do
(computedClient,writeClientOpt) <- mkComputedClientIO return
x <- addClient1 ((coMapClient fromD) computedClient)
clientOpt <- clientFn2 (fromX x)
writeClientOpt clientOpt
return x
in
Source addClient2
flattenSource :: Source x [d] -> Source x d
flattenSource (Source addClient1) =
let
addClient2 client1 = addClient1 (flattenClient client1)
in
(Source addClient2)
flattenClient :: Client d -> Client [d]
flattenClient client0 = Client (mkClientFn client0)
where
mkClientFn :: Client d -> [d] -> IO (Maybe (Client [d]))
mkClientFn client0 [] = return (Just (flattenClient client0))
mkClientFn (Client clientFn1) (d:ds) =
do
client1Opt <- clientFn1 d
case client1Opt of
Nothing -> return Nothing
Just client2 -> mkClientFn client2 ds
choose :: Source x1 d1 -> Source x2 d2 -> Source (x1,x2) (Either d1 d2)
choose ((Source addClient1) :: Source x1 d1)
((Source addClient2) :: Source x2 d2) =
let
addClient (client :: Client (Either d1 d2)) =
do
(Client staticClientFn) <- mkStaticClient client
let
client1 = Client clientFn1
clientFn1 d1 =
do
continue <- staticClientFn (Left d1)
return (fmap (\ _ -> client1) continue)
client2 = Client clientFn2
clientFn2 d2 =
do
continue <- staticClientFn (Right d2)
return (fmap (\ _ -> client2) continue)
x1 <- addClient1 client1
x2 <- addClient2 client2
return (x1,x2)
in
Source addClient
seqSource :: Source x1 x1 -> (x1 -> Source x2 x2) -> Source x2 x2
seqSource source getSource = seqSourceIO source (\ x1 -> return (getSource x1))
seqSourceIO :: Source x1 x1 -> (x1 -> (IO (Source x2 x2))) -> Source x2 x2
seqSourceIO (source1 :: Source x1 x1) (getSource2 :: x1 -> IO (Source x2 x2)) =
let
addClient client2 =
do
(staticClient2 @ (Client staticClientFn),clientRunning)
<- mkStaticClientGeneral client2
let
getClient1 :: (IO (),x1) -> Client x1
getClient1 (oldTerminator,x1) =
let
client1 terminator = Client (clientFn1 terminator)
clientFn1 oldTerminator x1 =
do
source2 <- getSource2 x1
oldTerminator
continue <- clientRunning
if continue
then
do
(staticClient2',write)
<- mkComputedClient
(const staticClient2)
(x2,newTerminator)
<- attachClientTemporary
staticClient2' source2
staticClientFn x2
write ()
return (Just (client1 newTerminator))
else
return Nothing
in
client1 oldTerminator
(client1',write) <- mkComputedClient getClient1
x1 <- attachClient client1' source1
source2 <- getSource2 x1
(x2,firstTerminator) <- attachClientTemporary staticClient2 source2
write (firstTerminator,x1)
return x2
in
Source addClient
newtype SimpleSource x = SimpleSource (Source x x)
staticSimpleSource :: x -> SimpleSource x
staticSimpleSource x = SimpleSource (staticSource x)
staticSimpleSourceIO :: IO x -> SimpleSource x
staticSimpleSourceIO act = SimpleSource (staticSourceIO act)
instance Functor SimpleSource where
fmap mapFn (SimpleSource source) =
SimpleSource ( (map1 mapFn) . (map2 mapFn) $ source)
instance HasMapIO SimpleSource where
mapIO mapFn (SimpleSource source) =
SimpleSource (
(map1IO mapFn)
. (filter2IO
(\ x ->
do
y <- mapFn x
return (Just y)
)
)
$ source
)
mapIOSeq :: SimpleSource a -> (a -> IO (SimpleSource b)) -> SimpleSource b
mapIOSeq (SimpleSource (source1 :: Source a a))
(getSimpleSource :: (a -> IO (SimpleSource b))) =
let
getSource :: a -> IO (Source b b)
getSource a =
do
(SimpleSource source) <- getSimpleSource a
return source
source2 :: Source b b
source2 = seqSourceIO source1 getSource
in
SimpleSource source2
instance Monad SimpleSource where
return x = SimpleSource (staticSource x)
(>>=) (SimpleSource source1) getSimpleSource2 =
let
getSource2 x =
let
(SimpleSource source2) = getSimpleSource2 x
in
source2
in
SimpleSource (seqSource source1 getSource2)
class HasSource hasSource x d | hasSource -> x,hasSource -> d where
toSource :: hasSource -> Source x d
class HasSimpleSource hasSource x | hasSource -> x where
toSimpleSource :: hasSource -> SimpleSource x
instance HasSource (Source x d) x d where
toSource source = source
instance HasSimpleSource (SimpleSource x) x where
toSimpleSource simpleSource = simpleSource
instance HasSource (SimpleSource x) x x where
toSource (SimpleSource source) = source
readContents :: HasSource source x d => source -> IO x
readContents hasSource =
let
trivialClient = Client (\ _ -> return Nothing)
in
attachClient trivialClient (toSource hasSource)
instance HasSource hasSource x d => CanAddSinks hasSource x d where
addOldSink hasSource sink =
do
let
client = Client clientFn
clientFn d =
do
continue <- putSink sink d
return (if continue
then
Just client
else
Nothing
)
attachClient client (toSource hasSource)
pairSimpleSources :: SimpleSource x1 -> SimpleSource x2 -> SimpleSource (x1,x2)
pairSimpleSources (SimpleSource source1) (SimpleSource source2) =
let
sourceChoose = choose source1 source2
source =
foldSource
id
(\ (x1,x2) change ->
let
new = case change of
Left newX1 -> (newX1,x2)
Right newX2 -> (x1,newX2)
in
(new,new)
)
sourceChoose
in
SimpleSource (map1 fst source)
sequenceSimpleSource :: [SimpleSource x] -> SimpleSource [x]
sequenceSimpleSource [] = return []
sequenceSimpleSource (first:rest) =
fmap (uncurry (:)) (pairSimpleSources first (sequenceSimpleSource rest))
mkHistorySource :: (x -> d) -> Source x d -> Source x (d,d)
mkHistorySource getD source =
map1 (\ (d,x) -> x) (foldSource getD (\ lastD d -> (d,(lastD,d))) source)
mkHistorySimpleSource :: x -> SimpleSource x -> SimpleSource (x,x)
mkHistorySimpleSource lastX (SimpleSource source) =
SimpleSource (map1 (\ x -> (lastX,x)) (mkHistorySource id source))
uniqSimpleSource :: Eq x => SimpleSource x -> SimpleSource x
uniqSimpleSource (SimpleSource source0) =
let
source1 = mkHistorySource id source0
source2 = filter2 (\ (lastD,d) -> if lastD == d then Nothing else Just d)
source1
in
SimpleSource source2
foldSimpleSourceIO :: (x1 -> IO (state,x2)) -> (state -> x1 -> IO (state,x2))
-> SimpleSource x1 -> SimpleSource x2
foldSimpleSourceIO (getStateIO :: x1 -> IO (state,x2)) updateStateIO
(SimpleSource (source :: Source x1 x1)) =
let
source1 :: Source (state,x2) x2
source1 = foldSourceIO getStateIO updateStateIO source
in
SimpleSource (map1 snd source1)
change1 :: SimpleSource x -> x -> SimpleSource x
change1 (SimpleSource source) x = SimpleSource (map1 (\ _ -> x) source)
addNewSourceActions :: Source x d -> (x -> IO ()) -> (d -> IO ())
-> SinkID -> ParallelExec -> IO x
addNewSourceActions (source1 :: Source x d) actionX actionD sinkID parallelX =
do
mVar <- newEmptyMVar
let
actionX' x =
do
putMVar mVar x
actionX x
(source2 :: Source x (IO ())) = stepSource actionX' actionD source1
addNewQuickSinkGeneral
source2
(\ action -> parallelExec parallelX action)
sinkID
takeMVar mVar
traceSimpleSource :: (a -> String) -> SimpleSource a -> SimpleSource a
traceSimpleSource toS (SimpleSource source) =
SimpleSource (
(map1IO
(\ a ->
do
putStrLn ("Initialising "++toS a)
return a
)
)
.
(filter2IO
(\ a ->
do
putStrLn ("Updating "++toS a)
return (Just a)
)
)
$
source
)
traceSource :: (a -> String) -> (d -> String) -> Source a d -> Source a d
traceSource toS1 toS2 source =
(map1IO
(\ a ->
do
putStrLn ("Initialising "++toS1 a)
return a
)
)
.
(filter2IO
(\ d ->
do
putStrLn ("Updating "++toS2 d)
return (Just d)
)
)
$
source
noLoopSource :: TSem -> ([String] -> x) -> ([String] -> d)
-> Source x d -> Source x d
noLoopSource tSem toX toD (Source addClient0 :: Source x d) =
let
mkClient :: Client d -> Client d
mkClient client = Client (mkClientFn client)
mkClientFn :: Client d -> d -> IO (Maybe (Client d))
mkClientFn (client @ (Client clientFn0)) d =
do
(looped :: Either [String] (Maybe (Client d)))
<- synchronizeTSem tSem (clientFn0 d)
case looped of
Left strings ->
do
debug ("mkClientFn loop caught " ++ show strings)
mkClientFn client (toD strings)
Right clientOpt -> return (fmap mkClient clientOpt)
addClient1 :: Client d -> IO x
addClient1 client =
do
stringsOrX <- synchronizeTSem tSem
(addClient0 (mkClient client))
case stringsOrX of
Left strings -> return (toX strings)
Right x -> return x
in
Source addClient1
noLoopSimpleSource :: TSem -> ([String] -> a) -> SimpleSource a
-> SimpleSource a
noLoopSimpleSource tSem toA (SimpleSource source0) =
let
source1 = noLoopSource tSem toA toA source0
in
SimpleSource source1
mkIOSource :: IO (Source x d) -> Source x d
mkIOSource act =
let
addClient client =
do
(Source addClient1) <- act
addClient1 client
in
Source addClient
mkIOSimpleSource :: IO (SimpleSource a) -> SimpleSource a
mkIOSimpleSource act =
SimpleSource (mkIOSource (
do
simpleSource <- act
return (toSource simpleSource)
))