summaryrefslogtreecommitdiff
path: root/src/Flow.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-08-01 23:01:30 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-08-12 23:08:55 +0200
commitbda62efef1ad38779f23b38b4e1436f06fb9c7c1 (patch)
treed7efc976a63f97bea3e8877c30b291225f05ded3 /src/Flow.hs
parent71cfee5086a6bf1c7a810d83fd67320bb9552197 (diff)
Network protocol refactoring with explicit data flows
Diffstat (limited to 'src/Flow.hs')
-rw-r--r--src/Flow.hs52
1 files changed, 52 insertions, 0 deletions
diff --git a/src/Flow.hs b/src/Flow.hs
new file mode 100644
index 0000000..349178f
--- /dev/null
+++ b/src/Flow.hs
@@ -0,0 +1,52 @@
+module Flow (
+ Flow, SymFlow,
+ newFlow, newFlowIO,
+ readFlow, writeFlow, writeFlowBulk,
+ readFlowIO, writeFlowIO,
+
+ mapPath,
+) 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
+
+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
+
+readFlowIO :: Flow r w -> IO r
+readFlowIO path = atomically $ readFlow path
+
+writeFlowIO :: Flow r w -> w -> IO ()
+writeFlowIO path = atomically . writeFlow path
+
+
+mapPath :: (r -> r') -> (w' -> w) -> Flow r w -> Flow r' w'
+mapPath rf wf (MappedFlow rf' wf' up) = MappedFlow (rf . rf') (wf' . wf) up
+mapPath rf wf up = MappedFlow rf wf up