diff options
author | Roman Smrž <roman.smrz@seznam.cz> | 2023-11-17 20:28:44 +0100 |
---|---|---|
committer | Roman Smrž <roman.smrz@seznam.cz> | 2023-11-18 20:03:24 +0100 |
commit | 88a7bb50033baab3c2d0eed7e4be868e8966300a (patch) | |
tree | 861631a1e5e7434b92a8f19ef8f7b783790e1d1f /src/Flow.hs | |
parent | 5b908c86320ee73f2722c85f8a47fa03ec093c6c (diff) |
Split to library and executable parts
Diffstat (limited to 'src/Flow.hs')
-rw-r--r-- | src/Flow.hs | 73 |
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 |