module Control.Wire.Trans.Combine
(
WContext(..),
WContextLimit(..),
WDistribute(..)
)
where
import qualified Data.Map as M
import Control.Arrow
import Control.Wire.Classes
import Control.Wire.TimedMap
import Control.Wire.Types
import Data.AdditiveGroup
import Data.Either
class Arrow (>~) => WContext (>~) where
context :: Ord k => Wire e (>~) (a, k) b -> Wire e (>~) (a, k) b
instance Monad m => WContext (Kleisli m) where
context w0 = context' M.empty
where
context' ctxs' =
WmGen $ \(x', ctx) -> do
let w' = M.findWithDefault w0 ctx ctxs'
(mx, w) <- toGenM w' (x', ctx)
let ctxs = M.insert ctx w ctxs'
return (mx, context' ctxs)
class Arrow (>~) => WContextLimit t (>~) | (>~) -> t where
contextLimit :: Ord k => Wire e (>~) (a, k) b -> Wire e (>~) ((a, k), t) b
instance (AdditiveGroup t, MonadClock t m, Ord t) => WContextLimit t (Kleisli m) where
contextLimit w0 = context' tmEmpty
where
context' ctxs' =
WmGen $ \((x', ctx), maxAge) -> do
t <- getTime
let w' = tmFindWithDefault w0 ctx ctxs'
(mx, w) <- toGenM w' (x', ctx)
let ctxs = tmLimitAge (t ^-^ maxAge) . tmInsert t ctx w $ ctxs'
return (mx, context' ctxs)
class Arrow (>~) => WDistribute (>~) where
distribute :: [Wire e (>~) a b] -> Wire e (>~) a [b]
instance Monad m => WDistribute (Kleisli m) where
distribute ws' =
WmGen $ \x' -> do
res <- mapM (\w' -> toGenM w' x') ws'
let (mxs, ws) = first rights . unzip $ res
return (Right mxs, distribute ws)