module Control.Wire.Trans.Combine
(
context,
contextLimit,
distribute
)
where
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Arrow
import Control.Wire.Classes
import Control.Wire.Tools
import Control.Wire.Types
import Data.Either
import Data.Map (Map)
import Data.Set (Set)
context ::
forall a b e k (>~).
(ArrowApply (>~), ArrowChoice (>~), Ord k)
=> Wire e (>~) a b -> Wire e (>~) (a, k) b
context w0 = context' M.empty
where
context' :: Map k (Wire e (>~) a b) -> Wire e (>~) (a, k) b
context' ctxs' =
mkGen $ proc (x', ctx) -> do
let w' = M.findWithDefault w0 ctx ctxs'
(mx, w) <- toGen w' -<< x'
let ctxs = M.insert ctx w ctxs'
returnA -< (mx, context' ctxs)
contextLimit ::
forall a b e k t (>~).
(ArrowApply (>~), ArrowClock (>~), Num t, Ord k, Ord t, Time (>~) ~ t)
=> Wire e (>~) a b -> Wire e (>~) ((a, k), t) b
contextLimit w0 = context' M.empty M.empty
where
context' ::
Map k (Wire e (>~) a b, t)
-> Map t (Set k)
-> Wire e (>~) ((a, k), t) b
context' ctxs'' hist'' =
mkGen $ proc ((x', ctx), maxAge) -> do
t <- arrTime -< ()
let (w', t') = M.findWithDefault (w0, t) ctx ctxs''
(mx, w) <- toGen w' -<< x'
let ctxs' = M.insert ctx (w, t) ctxs''
hist' =
M.insertWith' S.union t (S.singleton ctx) .
M.update (\s' -> let s = S.delete ctx s'
in if S.null s then Nothing else Just s) t' $
hist''
(ctxs, hist) =
let (delMap, hist) = M.split (t maxAge) hist'
dels = M.fromDistinctAscList . map (, ()) .
S.toAscList . S.unions . M.elems $ delMap
in (ctxs' M.\\ dels, hist)
returnA -< (mx, context' ctxs hist)
distribute ::
ArrowApply (>~) =>
[Wire e (>~) a b] -> Wire e (>~) a [b]
distribute ws' =
mkGen $ proc x' -> do
(mxs, ws) <-
first rights . unzip ^<<
distA (map toGen ws') -<< x'
returnA -< (Right mxs, distribute ws)