summaryrefslogtreecommitdiff
path: root/src/Flow.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-11-17 20:28:44 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-11-18 20:03:24 +0100
commit88a7bb50033baab3c2d0eed7e4be868e8966300a (patch)
tree861631a1e5e7434b92a8f19ef8f7b783790e1d1f /src/Flow.hs
parent5b908c86320ee73f2722c85f8a47fa03ec093c6c (diff)
Split to library and executable parts
Diffstat (limited to 'src/Flow.hs')
-rw-r--r--src/Flow.hs73
1 files changed, 0 insertions, 73 deletions
diff --git a/src/Flow.hs b/src/Flow.hs
deleted file mode 100644
index b52712d..0000000
--- a/src/Flow.hs
+++ /dev/null
@@ -1,73 +0,0 @@
-module Flow (
- Flow, SymFlow,
- newFlow, newFlowIO,
- readFlow, tryReadFlow, canReadFlow,
- writeFlow, writeFlowBulk, tryWriteFlow, canWriteFlow,
- readFlowIO, writeFlowIO,
-
- mapFlow,
-) where
-
-import Control.Concurrent.STM
-
-
-data Flow r w = Flow (TMVar [r]) (TMVar [w])
- | forall r' w'. MappedFlow (r' -> r) (w -> w') (Flow r' w')
-
-type SymFlow a = Flow a a
-
-newFlow :: STM (Flow a b, Flow b a)
-newFlow = do
- x <- newEmptyTMVar
- y <- newEmptyTMVar
- return (Flow x y, Flow y x)
-
-newFlowIO :: IO (Flow a b, Flow b a)
-newFlowIO = atomically newFlow
-
-readFlow :: Flow r w -> STM r
-readFlow (Flow rvar _) = takeTMVar rvar >>= \case
- (x:[]) -> return x
- (x:xs) -> putTMVar rvar xs >> return x
- [] -> error "Flow: empty list"
-readFlow (MappedFlow f _ up) = f <$> readFlow up
-
-tryReadFlow :: Flow r w -> STM (Maybe r)
-tryReadFlow (Flow rvar _) = tryTakeTMVar rvar >>= \case
- Just (x:[]) -> return (Just x)
- Just (x:xs) -> putTMVar rvar xs >> return (Just x)
- Just [] -> error "Flow: empty list"
- Nothing -> return Nothing
-tryReadFlow (MappedFlow f _ up) = fmap f <$> tryReadFlow up
-
-canReadFlow :: Flow r w -> STM Bool
-canReadFlow (Flow rvar _) = not <$> isEmptyTMVar rvar
-canReadFlow (MappedFlow _ _ up) = canReadFlow up
-
-writeFlow :: Flow r w -> w -> STM ()
-writeFlow (Flow _ wvar) = putTMVar wvar . (:[])
-writeFlow (MappedFlow _ f up) = writeFlow up . f
-
-writeFlowBulk :: Flow r w -> [w] -> STM ()
-writeFlowBulk _ [] = return ()
-writeFlowBulk (Flow _ wvar) xs = putTMVar wvar xs
-writeFlowBulk (MappedFlow _ f up) xs = writeFlowBulk up $ map f xs
-
-tryWriteFlow :: Flow r w -> w -> STM Bool
-tryWriteFlow (Flow _ wvar) = tryPutTMVar wvar . (:[])
-tryWriteFlow (MappedFlow _ f up) = tryWriteFlow up . f
-
-canWriteFlow :: Flow r w -> STM Bool
-canWriteFlow (Flow _ wvar) = isEmptyTMVar wvar
-canWriteFlow (MappedFlow _ _ up) = canWriteFlow up
-
-readFlowIO :: Flow r w -> IO r
-readFlowIO path = atomically $ readFlow path
-
-writeFlowIO :: Flow r w -> w -> IO ()
-writeFlowIO path = atomically . writeFlow path
-
-
-mapFlow :: (r -> r') -> (w' -> w) -> Flow r w -> Flow r' w'
-mapFlow rf wf (MappedFlow rf' wf' up) = MappedFlow (rf . rf') (wf' . wf) up
-mapFlow rf wf up = MappedFlow rf wf up