module Control.Wire.Trans.Sample
(
WHold(..),
WSample(..),
WSampleInt(..),
WSwallow(..)
)
where
import Control.Arrow
import Control.Monad
import Control.Wire.Classes
import Control.Wire.Prefab.Simple
import Control.Wire.Types
import Data.AdditiveGroup
class Arrow (>~) => WHold (>~) where
hold :: Wire e (>~) a b -> Wire e (>~) a b
holdWith :: b -> Wire e (>~) a b -> Wire e (>~) a b
instance Monad m => WHold (Kleisli m) where
hold (WmPure f) =
WmPure $ \x' ->
let (mx, w) = f x' in
case mx of
Left ex -> (Left ex, hold w)
Right x -> (Right x, holdWith x w)
hold (WmGen c) =
WmGen $ \x' -> do
(mx, w) <- c x'
return $
case mx of
Left ex -> (Left ex, hold w)
Right x -> (Right x, holdWith x w)
holdWith x0 (WmPure f) =
WmPure $ \x' ->
let (mx, w) = f x' in
case mx of
Left _ -> (Right x0, holdWith x0 w)
Right x -> (Right x, holdWith x w)
holdWith x0 (WmGen c) =
WmGen $ \x' -> do
(mx, w) <- c x'
return $
case mx of
Left _ -> (Right x0, holdWith x0 w)
Right x -> (Right x, holdWith x w)
class Arrow (>~) => WSample t (>~) | (>~) -> t where
sample :: Wire e (>~) a b -> Wire e (>~) (a, t) b
instance (AdditiveGroup t, MonadClock t m, Ord t) => WSample t (Kleisli m) where
sample w' =
WmGen $ \(x', int) ->
if int <= zeroV
then liftM (second sample) (toGenM w' x')
else do
t0 <- getTime
(mx, w) <- toGenM w' x'
return (mx, sample' t0 mx w)
where
sample' :: Ord t => t -> Either e b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) (a, t) b
sample' t0 mx0 w' =
WmGen $ \(x', int) ->
if int <= zeroV
then liftM (second sample) (toGenM w' x')
else do
t <- getTime
let tt = t0 ^+^ int
if t >= tt
then do
(mx, w) <- toGenM w' x'
return (mx, sample' tt mx w)
else return (mx0, sample' t0 mx0 w')
class Arrow (>~) => WSampleInt (>~) where
sampleInt :: Wire e (>~) a b -> Wire e (>~) (a, Int) b
instance Monad m => WSampleInt (Kleisli m) where
sampleInt w' =
WmGen $ \(x', _) -> do
(mx, w) <- toGenM w' x'
return (mx, sample' 0 mx w)
where
sample' :: Int -> Either e b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) (a, Int) b
sample' (succ -> n) mx0 w' =
WmGen $ \(x', int) ->
if n >= int
then do
(mx, w) <- toGenM w' x'
return (mx, sample' 0 mx w)
else return (mx0, sample' n mx0 w')
class Arrow (>~) => WSwallow (>~) where
swallow :: Wire e (>~) a b -> Wire e (>~) a b
instance Monad m => WSwallow (Kleisli m) where
swallow (WmPure f) =
WmPure $ \x' ->
let (mx, w) = f x' in
(mx, either (const $ swallow w) constant mx)
swallow (WmGen c) =
WmGen $ \x' -> do
(mx, w) <- c x'
return (mx, either (const $ swallow w) constant mx)