netwire 2.0.1 → 3.0.0
raw patch · 26 files changed
+1661/−740 lines, 26 filesdep +MonadRandomdep +forkable-monaddep +monad-controldep −transformers
Dependencies added: MonadRandom, forkable-monad, monad-control, mtl, stm
Dependencies removed: transformers
Files
- Control/Wire/Classes.hs +46/−33
- Control/Wire/Prefab.hs +2/−0
- Control/Wire/Prefab/Accum.hs +8/−5
- Control/Wire/Prefab/Analyze.hs +56/−39
- Control/Wire/Prefab/Calculus.hs +13/−26
- Control/Wire/Prefab/Clock.hs +16/−37
- Control/Wire/Prefab/Event.hs +148/−136
- Control/Wire/Prefab/Execute.hs +46/−0
- Control/Wire/Prefab/Queue.hs +2/−2
- Control/Wire/Prefab/Random.hs +29/−27
- Control/Wire/Prefab/Sample.hs +27/−18
- Control/Wire/Prefab/Simple.hs +10/−10
- Control/Wire/Prefab/Split.hs +43/−37
- Control/Wire/Session.hs +82/−5
- Control/Wire/TimedMap.hs +117/−0
- Control/Wire/Tools.hs +10/−1
- Control/Wire/Trans.hs +6/−0
- Control/Wire/Trans/Clock.hs +128/−0
- Control/Wire/Trans/Combine.hs +43/−59
- Control/Wire/Trans/Exhibit.hs +48/−26
- Control/Wire/Trans/Fork.hs +232/−0
- Control/Wire/Trans/Memoize.hs +99/−0
- Control/Wire/Trans/Sample.hs +115/−69
- Control/Wire/Trans/Simple.hs +26/−17
- Control/Wire/Types.hs +282/−186
- netwire.cabal +27/−7
Control/Wire/Classes.hs view
@@ -8,58 +8,71 @@ module Control.Wire.Classes ( -- * Various effects- ArrowClock(..),- ArrowIO(..),- ArrowRandom(..)+ -- ** Time+ MonadClock(..),+ -- ** Underlying monad+ ArrowKleisli(..),+ arrIO ) where +import Control.Applicative import Control.Arrow-import Control.Monad.IO.Class+import Control.Arrow.Transformer+import Control.Arrow.Transformer.Automaton+import Control.Arrow.Transformer.Error+import Control.Arrow.Transformer.Reader+import Control.Arrow.Transformer.State+import Control.Arrow.Transformer.Static+import Control.Arrow.Transformer.Writer+import Control.Monad.Trans (MonadIO(..))+import Data.Monoid import Data.Time.Clock.POSIX-import System.Random --- | Arrows with a clock.+-- | Monads with a clock. -class Arrow (>~) => ArrowClock (>~) where- -- | Type for time values.- type Time (>~)+class Monad m => MonadClock t m | m -> t where+ -- | Current time in some monad-specific frame of reference.+ getTime :: m t - -- | Current time in some arrow-specific frame of reference.- arrTime :: a >~ Time (>~) +-- | Instance for the system time. This is intentionally specific to+-- allow you to define better instances with custom monads. --- | Instance for the system time. Use this only for testing. This is--- intentionally specific to allow you to define better instances with--- custom arrows.+instance MonadClock Double IO where+ getTime = fmap realToFrac getPOSIXTime -instance ArrowClock (Kleisli IO) where- type Time (Kleisli IO) = Double- arrTime = Kleisli (const $ fmap realToFrac getPOSIXTime) +-- | Arrows which support running monadic computations. --- | Arrows which support running IO computations.+class Arrow (>~) => ArrowKleisli m (>~) | (>~) -> m where+ -- | Run the input computation and output its result.+ arrM :: Monad m => m b >~ b -class Arrow (>~) => ArrowIO (>~) where- -- | Run the input IO computation and output its result.- arrIO :: IO b >~ b+instance Monad m => ArrowKleisli m (Kleisli m) where+ arrM = Kleisli id -instance MonadIO m => ArrowIO (Kleisli m) where- arrIO = Kleisli liftIO+instance ArrowKleisli m (>~) => ArrowKleisli m (Automaton (>~)) where+ arrM = lift arrM +instance (ArrowChoice (>~), ArrowKleisli m (>~)) => ArrowKleisli m (ErrorArrow ex (>~)) where+ arrM = lift arrM --- | Arrows with support for random number generation.+instance ArrowKleisli m (>~) => ArrowKleisli m (ReaderArrow e (>~)) where+ arrM = lift arrM -class Arrow (>~) => ArrowRandom (>~) where- -- | Return a random number.- arrRand :: Random b => a >~ b+instance ArrowKleisli m (>~) => ArrowKleisli m (StateArrow s (>~)) where+ arrM = lift arrM - -- | Return a random number in the input range.- arrRandR :: Random b => (b, b) >~ b+instance (Applicative f, ArrowKleisli m (>~)) => ArrowKleisli m (StaticArrow f (>~)) where+ arrM = lift arrM --- | Instance for the 'IO'-builtin 'StdGen'.+instance (ArrowKleisli m (>~), Monoid l) => ArrowKleisli m (WriterArrow l (>~)) where+ arrM = lift arrM -instance ArrowRandom (Kleisli IO) where- arrRand = Kleisli (const randomIO)- arrRandR = Kleisli randomRIO++-- | Arrows, which have 'IO' at their base.++arrIO :: (ArrowKleisli m (>~), MonadIO m) => IO b >~ b+arrIO = arrM <<^ liftIO
Control/Wire/Prefab.hs view
@@ -13,6 +13,7 @@ module Control.Wire.Prefab.Calculus, module Control.Wire.Prefab.Clock, module Control.Wire.Prefab.Event,+ module Control.Wire.Prefab.Execute, module Control.Wire.Prefab.Queue, module Control.Wire.Prefab.Random, module Control.Wire.Prefab.Sample,@@ -26,6 +27,7 @@ import Control.Wire.Prefab.Calculus import Control.Wire.Prefab.Clock import Control.Wire.Prefab.Event+import Control.Wire.Prefab.Execute import Control.Wire.Prefab.Queue import Control.Wire.Prefab.Random import Control.Wire.Prefab.Sample
Control/Wire/Prefab/Accum.hs view
@@ -29,7 +29,7 @@ -- -- * Depends: current instant. -accum :: a -> Wire e (>~) (a -> a) a+accum :: WirePure (>~) => a -> Wire e (>~) (a -> a) a accum x = mkPure $ \f -> x `seq` (Right x, accum (f x)) @@ -39,13 +39,13 @@ -- -- * Depends: Current instant. -atFirst :: (b -> b) -> Wire e (>~) b b+atFirst :: WirePure (>~) => (b -> b) -> Wire e (>~) b b atFirst f = mkPure $ \x -> (Right (f x), identity) -- | Count upwards from the given starting value. -countFrom :: Enum b => b -> Wire e (>~) a b+countFrom :: (Enum b, WirePure (>~)) => b -> Wire e (>~) a b countFrom n = mkPure $ \_ -> n `seq` (Right n, countFrom (succ n)) @@ -54,5 +54,8 @@ -- -- * Depends: current instant. -countStep :: Num a => a -> Wire e (>~) a a-countStep x = mkPure $ \dx -> x `seq` (Right x, countStep (x + dx))+countStep :: (Num b, WirePure (>~)) => b -> Wire e (>~) b b+countStep x =+ mkPure $ \dx ->+ x `seq`+ (Right x, countStep (x + dx))
Control/Wire/Prefab/Analyze.hs view
@@ -12,6 +12,7 @@ avg, avgAll, avgFps,+ avgFpsInt, -- ** Peak highPeak, lowPeak,@@ -32,8 +33,8 @@ import Control.Arrow import Control.Monad.Fix import Control.Monad.ST-import Control.Wire.Classes-import Control.Wire.Prefab.Clock+import Control.Wire.Trans.Clock+import Control.Wire.Trans.Sample import Control.Wire.Types import Data.Map (Map) import Data.Monoid@@ -48,19 +49,24 @@ -- -- * Depends: current instant. -avg :: forall e v (>~). (Arrow (>~), Fractional v, Vu.Unbox v) => Int -> Wire e (>~) v v+avg ::+ forall e v (>~).+ (Fractional v, Vu.Unbox v, WirePure (>~))+ => Int+ -> Wire e (>~) v v avg n = mkPure $ \x -> (Right x, avg' (Vu.replicate n (x/d)) x 0) where avg' :: Vu.Vector v -> v -> Int -> Wire e (>~) v v avg' samples' s' cur' = mkPure $ \((/d) -> x) ->- let cur = let cur = succ cur' in if cur >= n then 0 else cur+ let cur = let ncur = succ cur' in+ if ncur >= n then 0 else ncur x' = samples' Vu.! cur samples = x' `seq` runST $ do- s <- Vu.unsafeThaw samples'- Vum.write s cur x- Vu.unsafeFreeze s+ sam <- Vu.unsafeThaw samples'+ Vum.write sam cur x+ Vu.unsafeFreeze sam s = s' - x' + x in cur `seq` s' `seq` (Right s, avg' samples s cur) @@ -76,7 +82,7 @@ -- -- * Depends: current instant. -avgAll :: forall e v (>~). (Arrow (>~), Fractional v) => Wire e (>~) v v+avgAll :: forall e v (>~). (Fractional v, WirePure (>~)) => Wire e (>~) v v avgAll = mkPure $ \x -> (Right x, avgAll' 1 x) where avgAll' :: v -> v -> Wire e (>~) v v@@ -90,24 +96,37 @@ -- | Calculate the average number of frames per virtual second for the -- last given number of frames. ----- Please note that this wire uses the clock from the 'ArrowClock'--- instance for the underlying arrow. If this clock doesn't represent--- real time, then the output of this wire won't either.+-- Please note that this wire uses the clock from the 'WWithDT' instance+-- for the underlying arrow. If this clock doesn't represent real time,+-- then the output of this wire won't either. avgFps ::- (ArrowChoice (>~), ArrowClock (>~), Fractional t, Time (>~) ~ t, Vu.Unbox t)+ (Arrow (Wire e (>~)), Fractional t, Vu.Unbox t, WirePure (>~), WWithDT t (>~)) => Int -> Wire e (>~) a t-avgFps n = recip ^<< avg n <<< dtime+avgFps n = recip ^<< passDT (avg n) +-- | Same as 'avgFps', but samples only at regular intervals. This can+-- improve performance, if querying the clock is an expensive operation.++avgFpsInt ::+ (Arrow (Wire e (>~)), Fractional t, Vu.Unbox t, WirePure (>~), WSampleInt (>~), WWithDT t (>~))+ => Int -- ^ Interval size.+ -> Int -- ^ Number of Samples.+ -> Wire e (>~) a t+avgFpsInt int n =+ proc x' ->+ (| sampleInt ((* fromIntegral int) ^<< avgFps n -< x') |) int++ -- | Collects all distinct inputs ever received. -- -- * Complexity: O(n) space, O(log n) time wrt collected inputs so far. -- -- * Depends: current instant. -collect :: forall b e (>~). Ord b => Wire e (>~) b (Set b)+collect :: forall b e (>~). (Ord b, WirePure (>~)) => Wire e (>~) b (Set b) collect = collect' S.empty where collect' :: Set b -> Wire e (>~) b (Set b)@@ -124,10 +143,8 @@ -- -- * Inhibits: on no change after the first instant. -diff :: forall b e (>~). (Eq b, Monoid e) => Wire e (>~) b b-diff =- mkPure $ \x -> (Right x, diff' x)-+diff :: forall b e (>~). (Eq b, Monoid e, WirePure (>~)) => Wire e (>~) b b+diff = mkPure $ \x -> (Right x, diff' x) where diff' :: b -> Wire e (>~) b b diff' x' =@@ -137,33 +154,31 @@ else (Right x', diff' x) --- | Reports the first time the given input was seen.+-- | Reports the first global time the given input was seen. -- -- * Complexity: O(n) space, O(log n) time wrt collected inputs so far. -- -- * Depends: Current instant. firstSeen ::- forall a e t (>~). (ArrowChoice (>~), ArrowClock (>~), Monoid e, Ord a, Time (>~) ~ t)+ forall a e t (>~). (Ord a, WirePure (>~), WWithSysTime t (>~)) => Wire e (>~) a t-firstSeen = firstSeen' M.empty+firstSeen = withSysTime (firstSeen' M.empty) where- firstSeen' :: Map a t -> Wire e (>~) a t+ firstSeen' :: Map a t -> Wire e (>~) (a, t) t firstSeen' xs' = fix $ \again ->- mkGen $ proc x' -> do- case M.lookup x' xs' of- Just t -> returnA -< (Right t, again)- Nothing -> do- t <- arrTime -< ()- returnA -< (Right t, firstSeen' (M.insert x' t xs'))+ mkPure $ \(x, t) ->+ case M.lookup x xs' of+ Just xt -> (Right xt, again)+ Nothing -> (Right t, firstSeen' (M.insert x t xs')) -- | Outputs the high peak of the input signal. -- -- * Depends: Current instant. -highPeak :: Ord b => Wire e (>~) b b+highPeak :: (Ord b, WirePure (>~)) => Wire e (>~) b b highPeak = peakBy compare @@ -177,24 +192,23 @@ -- * Inhibits: On first sight of a signal. lastSeen ::- forall a e t (>~). (ArrowClock (>~), Monoid e, Ord a, Time (>~) ~ t)+ forall a e t (>~). (Monoid e, Ord a, WirePure (>~), WWithSysTime t (>~)) => Wire e (>~) a t-lastSeen = lastSeen' M.empty+lastSeen = withSysTime (lastSeen' M.empty) where- lastSeen' :: Map a t -> Wire e (>~) a t+ lastSeen' :: Map a t -> Wire e (>~) (a, t) t lastSeen' xs' =- mkGen $ proc x' -> do- t <- arrTime -< ()- let xs = M.insert x' t xs'- returnA -< (maybe (Left mempty) Right $ M.lookup x' xs',- lastSeen' xs)+ mkPure $ \(x, t) ->+ let xs = M.insert x t xs'+ in (maybe (Left mempty) Right $ M.lookup x xs',+ lastSeen' xs) -- | Outputs the low peak of the input signal. -- -- * Depends: Current instant. -lowPeak :: Ord b => Wire e (>~) b b+lowPeak :: (Ord b, WirePure (>~)) => Wire e (>~) b b lowPeak = peakBy (flip compare) @@ -203,7 +217,10 @@ -- -- * Depends: Current instant. -peakBy :: forall b e (>~). (b -> b -> Ordering) -> Wire e (>~) b b+peakBy ::+ forall b e (>~). WirePure (>~)+ => (b -> b -> Ordering)+ -> Wire e (>~) b b peakBy comp = mkPure (Right &&& peakBy') where peakBy' :: b -> Wire e (>~) b b
Control/Wire/Prefab/Calculus.hs view
@@ -15,8 +15,7 @@ ) where -import Control.Arrow-import Control.Wire.Classes+import Control.Wire.Trans.Clock import Control.Wire.Types import Data.VectorSpace @@ -27,21 +26,15 @@ integral :: forall e t v (>~).- (ArrowClock (>~), Num t, Scalar v ~ t, Time (>~) ~ t, VectorSpace v)+ (VectorSpace v, WirePure (>~), WWithDT t (>~), Scalar v ~ t) => v -> Wire e (>~) v v-integral x0 =- mkGen $ proc _ -> do- t <- arrTime -< ()- returnA -< (Right x0, integral' x0 t)-+integral = withDT . integral' where- integral' :: v -> t -> Wire e (>~) v v- integral' x0 t' =- mkGen $ proc dx -> do- t <- arrTime -< ()- let dt = t - t'+ integral' :: v -> Wire e (>~) (v, t) v+ integral' x0 =+ mkPure $ \(dx, dt) -> let x1 = x0 ^+^ (dx ^* dt)- returnA -< x0 `seq` (Right x0, integral' x1 t)+ in x0 `seq` (Right x0, integral' x1) -- | Calculates the derivative of the input signal over time.@@ -50,18 +43,12 @@ derivative :: forall e t v (>~).- (ArrowClock (>~), Fractional t, Scalar v ~ t, Time (>~) ~ t, VectorSpace v)+ (Fractional t, VectorSpace v, WirePure (>~), WWithDT t (>~), Scalar v ~ t) => Wire e (>~) v v-derivative =- mkGen $ proc x0 -> do- t <- arrTime -< ()- returnA -< (Right zeroV, deriv' x0 t)-+derivative = mkPure $ \x0 -> (Right zeroV, withDT (deriv' x0)) where- deriv' :: v -> t -> Wire e (>~) v v- deriv' x0 t' =- mkGen $ proc x1 -> do- t <- arrTime -< ()- let dt = t - t'+ deriv' :: v -> Wire e (>~) (v, t) v+ deriv' x0 =+ mkPure $ \(x1, dt) -> let dx = (x1 ^-^ x0) ^/ dt- returnA -< x0 `seq` (Right dx, deriv' x1 t)+ in x0 `seq` (Right dx, deriv' x1)
Control/Wire/Prefab/Clock.hs view
@@ -9,53 +9,32 @@ module Control.Wire.Prefab.Clock ( -- * Clock wires dtime,- dtimeFrom,- time,- timeFrom,- timeOffset+ sysTime,+ time ) where -import Control.Arrow-import Control.Wire.Classes+import Control.Wire.Prefab.Simple+import Control.Wire.Trans.Clock import Control.Wire.Types --- | Time deltas starting from the first instant.--dtime :: (ArrowClock (>~), Time (>~) ~ t, Num t) => Wire e (>~) a t-dtime =- mkGen $ proc _ -> do- t <- arrTime -< ()- returnA -< (Right 0, dtimeFrom t)----- | Time deltas starting from the given instant.--dtimeFrom :: (ArrowClock (>~), Time (>~) ~ t, Num t) => t -> Wire e (>~) a t-dtimeFrom t' =- mkGen $ proc _ -> do- t <- arrTime -< ()- let dt = t - t'- returnA -< t' `seq` (Right dt, dtimeFrom t)----- | Current time with the given origin at the first instant.+-- | Time deltas starting from the time of the first instant. -timeFrom :: (ArrowClock (>~), Time (>~) ~ t, Num t) => t -> Wire e (>~) a t-timeFrom t0 =- mkGen $ proc _ -> do- t <- arrTime -< ()- returnA -< t0 `seq` (Right t0, timeOffset (t0 - t))+dtime :: (WirePure (>~), WWithDT t (>~)) => Wire e (>~) a t+dtime = passDT identity --- | Current time with the given offset.+-- | Global time. Independent of switching. *System* refers to the+-- wire system, not the operating system, so this does not+-- necessarily refer to OS time. -timeOffset :: (ArrowClock (>~), Time (>~) ~ t, Num t) => t -> Wire e (>~) a t-timeOffset offset = mkFix $ proc _ -> Right . (+ offset) ^<< arrTime -< ()+sysTime :: (WirePure (>~), WWithSysTime t (>~)) => Wire e (>~) a t+sysTime = passSysTime identity --- | Current time with origin 0 at the first instant.+-- | Local time. Starts at the 'AdditiveGroup' notion of zero when+-- switching in. -time :: (ArrowClock (>~), Time (>~) ~ t, Num t) => Wire e (>~) a t-time = timeFrom 0+time :: (WirePure (>~), WWithTime t (>~)) => Wire e (>~) a t+time = passTime identity
Control/Wire/Prefab/Event.hs view
@@ -9,11 +9,10 @@ module Control.Wire.Prefab.Event ( -- * Event generation -- ** Timed- after,- at,- delayEvents,- delayEventsSafe,- periodically,+ WAfter(..),+ WAt(..),+ WDelayEvents(..),+ WPeriodically(..), -- ** Unconditional inhibition inhibit, never,@@ -39,133 +38,129 @@ import Data.Monoid import Data.Map (Map) import Data.Sequence (Seq, ViewL(..), (><))+import Data.VectorSpace --- | Produces once after the input time delta has passed.+-- | Produces once after the input time interval has passed. -- -- * Depends: Current instant. -- -- * Inhibits: Always except at the target instant. -after ::- forall e t (>~).- (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)- => Wire e (>~) t ()-after =- mkGen $ proc dt -> do- t0 <- arrTime -< ()- returnA -<- if dt <= 0- then (Right (), never)- else (Left mempty, after' t0)+class Arrow (>~) => WAfter t (>~) | (>~) -> t where+ after :: Monoid e => Wire e (>~) t () - where- after' :: t -> Wire e (>~) t ()- after' t0 =- fix $ \again ->- mkGen $ proc dt -> do- t <- arrTime -< ()- returnA -<- if t - t0 >= dt- then (Right (), never)- else (Left mempty, again)+instance (AdditiveGroup t, MonadClock t m, Ord t) => WAfter t (Kleisli m) where+ after = after0+ where+ after0 :: forall e. Monoid e => Wire e (Kleisli m) t ()+ after0 =+ WmGen $ \int -> do+ t0 <- getTime+ return (int <= zeroV `orGoWith` after' t0) + where+ after' :: t -> Wire e (Kleisli m) t ()+ after' t0 =+ fix $ \again ->+ WmGen $ \int -> do+ t <- getTime+ return (t ^-^ t0 >= int `orGoWith` again) --- | Produces once as soon as the current time is later than or equal to--- the current time and never again.++-- | Produces once as soon as the current global time is later than or+-- equal to the input global time and never again. -- -- * Depends: Current instant. -- -- * Inhibits: Always except at the target instant. -at :: (ArrowClock (>~), Monoid e, Ord t, Time (>~) ~ t) => Wire e (>~) t ()-at =- mkGen $ proc tt -> do- t <- arrTime -< ()- returnA -<- if t >= tt- then (Right (), never)- else (Left mempty, at)+class Arrow (>~) => WAt t (>~) | (>~) -> t where+ at :: Monoid e => Wire e (>~) t () +instance (MonadClock t m, Ord t) => WAt t (Kleisli m) where+ at =+ WmGen $ \tt -> do+ t <- getTime+ return (t >= tt `orGoWith` at) --- | Delays each incoming event (left signal) by the given time delta--- (right signal). The time delta at the instant the event happened is--- significant.------ * Depends: Current instant.------ * Inhibits: When no delayed event happened. -delayEvents ::- forall b e t (>~).- (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)- => Wire e (>~) ([b], t) b-delayEvents = delayEvents' M.empty- where- delayEvents' :: Map t (Seq b) -> Wire e (>~) ([b], t) b- delayEvents' devs' =- mkGen $ proc (evs, dt) -> do- t <- arrTime -< ()- let devs | null evs = devs'- | otherwise = M.insertWith' (><) (t + dt) (S.fromList evs) devs'- returnA -<- devs `seq`- case M.minViewWithKey devs of- Nothing -> (Left mempty, delayEvents' devs)- Just ((tt, revs), restMap)- | tt > t -> (Left mempty, delayEvents' devs)- | otherwise ->- case S.viewl revs of- EmptyL -> (Left mempty, delayEvents' restMap)- rev :< restEvs ->- (Right rev,- delayEvents' (if S.null restEvs- then restMap- else M.insert tt restEvs restMap))+-- | Delay incoming events. +class Arrow (>~) => WDelayEvents t (>~) | (>~) -> t where+ -- | Delays each incoming event (left signal) by the given time+ -- delta (right signal). The time delta at the instant the event+ -- happened is significant.+ --+ -- * Depends: Current instant.+ --+ -- * Inhibits: When no delayed event happened.+ delayEvents :: Monoid e => Wire e (>~) ([b], t) b --- | Delays each incoming event (left signal) by the given time delta--- (middle signal). The time delta at the instant the event happened is--- significant. The right signal gives a maximum number of events--- queued. When exceeded, new events are dropped, until there is enough--- room.------ * Depends: Current instant.------ * Inhibits: When no delayed event happened.+ -- | Delays each incoming event (left signal) by the given time+ -- delta (middle signal). The time delta at the instant the event+ -- happened is significant. The right signal gives a maximum number+ -- of events queued. When exceeded, new events are dropped, until+ -- there is enough room.+ --+ -- * Depends: Current instant.+ --+ -- * Inhibits: When no delayed event happened.+ delayEventsSafe :: Monoid e => Wire e (>~) (([b], t), Int) b -delayEventsSafe ::- forall b e t (>~).- (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)- => Wire e (>~) (([b], t), Int) b-delayEventsSafe = delayEvents' 0 M.empty- where- delayEvents' :: Int -> Map t (Seq b) -> Wire e (>~) (([b], t), Int) b- delayEvents' curNum' devs' =- mkGen $ proc ((evs, dt), maxNum) -> do- t <- arrTime -< ()- let addSeq = S.fromList evs- (curNum, devs) =- if null evs || curNum' >= maxNum- then (curNum', devs')- else (curNum' + S.length addSeq,- M.insertWith' (><) (t + dt) addSeq devs')- returnA -<- case M.minViewWithKey devs of- Nothing -> (Left mempty, delayEvents' curNum devs)- Just ((tt, revs), restMap)- | tt > t -> (Left mempty, delayEvents' curNum devs)- | otherwise ->- case S.viewl revs of- EmptyL -> (Left mempty, delayEvents' curNum restMap)- rev :< restEvs ->- (Right rev,- delayEvents' (pred curNum)- (if S.null restEvs- then restMap- else M.insert tt restEvs restMap))+instance (AdditiveGroup t, MonadClock t m, Ord t) => WDelayEvents t (Kleisli m) where+ -- delayEvents+ delayEvents = delayEvents' M.empty+ where+ delayEvents' :: Monoid e => Map t (Seq b) -> Wire e (Kleisli m) ([b], t) b+ delayEvents' delayed' =+ WmGen $ \(evs, int) -> do+ t <- getTime+ let delayed = M.insertWith' (><) (t ^+^ int) (S.fromList evs) delayed' + return $+ case M.minViewWithKey delayed of+ Nothing -> (Left mempty, delayEvents' delayed)+ Just ((tt, revs), restMap)+ | tt > t -> (Left mempty, delayEvents' delayed)+ | otherwise ->+ case S.viewl revs of+ EmptyL -> (Left mempty, delayEvents' restMap)+ rev :< restEvs ->+ (Right rev,+ delayEvents' (if S.null restEvs+ then restMap+ else M.insert tt restEvs restMap)) + -- delayEventsSafe+ delayEventsSafe = delayEvents' 0 M.empty+ where+ delayEvents' :: Monoid e => Int -> Map t (Seq b) -> Wire e (Kleisli m) (([b], t), Int) b+ delayEvents' curNum' delayed' =+ WmGen $ \((evs, int), maxNum) -> do+ t <- getTime+ let addSeq = S.fromList evs+ (curNum, delayed) =+ if null evs || curNum' >= maxNum+ then (curNum', delayed')+ else (curNum' + S.length addSeq,+ M.insertWith' (><) (t ^+^ int) addSeq delayed')+ return $+ case M.minViewWithKey delayed of+ Nothing -> (Left mempty, delayEvents' curNum delayed)+ Just ((tt, revs), restMap)+ | tt > t -> (Left mempty, delayEvents' curNum delayed)+ | otherwise ->+ case S.viewl revs of+ EmptyL -> (Left mempty, delayEvents' curNum restMap)+ rev :< restEvs ->+ (Right rev,+ delayEvents' (pred curNum)+ (if S.null restEvs+ then restMap+ else M.insert tt restEvs restMap))++ -- | Inhibits as long as the input signal is 'False'. Once it switches -- to 'True', it produces forever. --@@ -173,7 +168,7 @@ -- -- * Inhibits: As long as input signal is 'False', then never again. -asSoonAs :: Monoid e => Wire e (>~) Bool ()+asSoonAs :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool () asSoonAs = mkPure $ \b -> if b then (Right (), constant ()) else (Left mempty, asSoonAs)@@ -186,7 +181,7 @@ -- -- * Inhibits: Always except at the above mentioned instants. -edge :: forall e (>~). Monoid e => Wire e (>~) Bool ()+edge :: forall e (>~). (Monoid e, WirePure (>~)) => Wire e (>~) Bool () edge = mkPure $ \b -> if b then (Right (), switchBack) else (Left mempty, edge)@@ -202,7 +197,7 @@ -- -- * Inhibits: When input is 'True'. -forbid :: Monoid e => Wire e (>~) Bool ()+forbid :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool () forbid = mkPureFix (\b -> if b then Left mempty else Right ()) @@ -212,7 +207,7 @@ -- -- * Inhibits: Always. -inhibit :: Wire e (>~) e b+inhibit :: WirePure (>~) => Wire e (>~) e b inhibit = mkPureFix Left @@ -220,7 +215,7 @@ -- -- * Inhibits: Always. -never :: Monoid e => Wire e (>~) a b+never :: (Monoid e, WirePure (>~)) => Wire e (>~) a b never = mkPureFix (const (Left mempty)) @@ -228,7 +223,7 @@ -- -- * Inhibits: At the first instant. -notYet :: Monoid e => Wire e (>~) b b+notYet :: (Monoid e, WirePure (>~)) => Wire e (>~) b b notYet = mkPure (const (Left mempty, identity)) @@ -236,7 +231,7 @@ -- -- * Inhibits: After the first instant. -once :: Monoid e => Wire e (>~) b b+once :: (Monoid e, WirePure (>~)) => Wire e (>~) b b once = mkPure $ \x -> (Right x, never) @@ -249,34 +244,37 @@ -- -- * Inhibits: Always except at the periodic ticks. -periodically ::- forall e t (>~).- (ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)- => Wire e (>~) t ()-periodically =- mkGen $ proc dt -> do- t <- arrTime -< ()- returnA -< (if dt <= 0 then Right () else Left mempty, periodically' t)+class Arrow (>~) => WPeriodically t (>~) | (>~) -> t where+ periodically :: Monoid e => Wire e (>~) t () - where- periodically' :: t -> Wire e (>~) t ()- periodically' t0 =- mkGen $ proc dt -> do- t <- arrTime -< ()- returnA -<- let tt = t0 + dt in- if tt <= t- then (Right (), periodically' tt)- else (Left mempty, periodically' t0)+instance (AdditiveGroup t, MonadClock t m, Ord t) => WPeriodically t (Kleisli m) where+ periodically =+ WmGen $ \int ->+ if int <= zeroV+ then return (Right (), periodically)+ else do+ t <- getTime+ return (Left mempty, periodically' t) + where+ periodically' :: Monoid e => t -> Wire e (Kleisli m) t ()+ periodically' t0 =+ WmGen $ \int -> do+ t <- getTime+ let tt = t0 ^+^ int+ return $+ if t >= tt+ then (Right (), periodically' tt)+ else (Left mempty, periodically' t0) + -- | Produces, whenever the current input signal is 'True'. -- -- * Depends: Current instant. -- -- * Inhibits: When input is 'False'. -require :: Monoid e => Wire e (>~) Bool ()+require :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool () require = mkPureFix (\b -> if b then Right () else Left mempty) @@ -287,7 +285,21 @@ -- -- * Inhibits: As soon as input becomes 'False'. -while :: Monoid e => Wire e (>~) Bool ()+while :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool () while = mkPure $ \b -> if b then (Right (), while) else (Left mempty, never)+++-- | Produces a single event occurence result, when the given 'Bool' is+-- true.++orGoWith ::+ (Monoid e, WirePure (>~))+ => Bool+ -> Wire e (>~) a b+ -> (Either e (), Wire e (>~) a b)+orGoWith True _ = (Right (), never)+orGoWith False w = (Left mempty, w)++infixl 3 `orGoWith`
+ Control/Wire/Prefab/Execute.hs view
@@ -0,0 +1,46 @@+-- |+-- Module: Control.Wire.Prefab.Execute+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Monadic computations for wires over Kleisli arrows. The difference+-- between these wires and 'Control.Wire.Classes.arrM' is that these are+-- exception-aware.++module Control.Wire.Prefab.Execute+ ( -- * Run monadic actions+ WExecute(..)+ )+ where++import Control.Applicative+import Control.Arrow+import Control.Exception.Control as Ex+import Control.Monad+import Control.Monad.IO.Control+import Control.Wire.Types+++-- | Run monadic actions.++class Arrow (>~) => WExecute m (>~) | (>~) -> m where+ -- | Run the input monadic action at each instant.+ --+ -- * Depends: Current instant.+ --+ -- * Inhibits: Whenever the input computation throws an exception.+ execute :: Applicative f => Wire (f SomeException) (>~) (m b) b+ execute = executeWith pure++ -- | Run the input monadic action at each instant. The argument+ -- function converts thrown exceptions to inhibition values.+ --+ -- * Depends: Current instant.+ --+ -- * Inhibits: Whenever the input computation throws an exception.+ executeWith :: (SomeException -> e) -> Wire e (>~) (m b) b++instance MonadControlIO m => WExecute m (Kleisli m) where+ executeWith fromEx =+ mkFixM $ liftM (either (Left . fromEx) Right) . Ex.try
Control/Wire/Prefab/Queue.hs view
@@ -27,7 +27,7 @@ -- -- * Inhibits: when the queue is empty. -fifo :: forall a e (>~). Monoid e => Wire e (>~) [a] a+fifo :: forall a e (>~). (Monoid e, WirePure (>~)) => Wire e (>~) [a] a fifo = fifo' S.empty where fifo' :: Seq a -> Wire e (>~) [a] a@@ -46,7 +46,7 @@ -- -- * Inhibits: when the queue is empty. -lifo :: forall a e (>~). Monoid e => Wire e (>~) [a] a+lifo :: forall a e (>~). (Monoid e, WirePure (>~)) => Wire e (>~) [a] a lifo = lifo' S.empty where lifo' :: Seq a -> Wire e (>~) [a] a
Control/Wire/Prefab/Random.hs view
@@ -19,44 +19,46 @@ where import Control.Arrow-import Control.Wire.Classes+import Control.Monad+import Control.Monad.Random.Class import Control.Wire.Types import System.Random --- | Generate random noise.--noise :: (ArrowRandom (>~), Random b) => Wire e (>~) a b-noise = mkFix $ arr Right <<< arrRand----- | Generate random noise in range 0 <= x < 1.+-- | Random number wires. -noiseF :: ArrowRandom (>~) => Wire e (>~) a Double-noiseF = noise+class Arrow (>~) => WRandom (>~) where+ -- | Generate random noise.+ noise :: Random b => Wire e (>~) a b + -- | Generate random noise in a certain range given by the input+ -- signal.+ --+ -- * Depends: Current instant.+ noiseR :: Random b => Wire e (>~) (b, b) b --- | Generate random noise in range -1 <= x < 1.+ -- | Generate a random boolean, where the input signal is the+ -- probability to be 'True'.+ --+ -- * Depends: Current instant.+ wackelkontakt :: Wire e (>~) Double Bool -noiseF1 :: ArrowRandom (>~) => Wire e (>~) a Double-noiseF1 = mkFix (arr (Right . (*2) . pred) <<< arrRand)+instance MonadRandom m => WRandom (Kleisli m) where+ noise = mkFixM (liftM Right . const getRandom)+ noiseR = mkFixM (liftM Right . getRandomR)+ wackelkontakt =+ mkFixM $ \p -> do+ s <- getRandom+ return (Right (not (s >= p))) --- | Generate random noise in a certain range given by the input signal.------ * Depends: Current instant.+-- | Generate random noise in range 0 <= x < 1. -noiseR :: (ArrowRandom (>~), Random b) => Wire e (>~) (b, b) b-noiseR = mkFix $ arr Right <<< arrRandR+noiseF :: WRandom (>~) => Wire e (>~) a Double+noiseF = noise --- | Generate a random boolean, where the input signal is the--- probability to be 'True'.------ * Depends: Current instant.+-- | Generate random noise in range -1 <= x < 1. -wackelkontakt :: ArrowRandom (>~) => Wire e (>~) Double Bool-wackelkontakt =- mkFix $ proc p -> do- s <- arrRand -< ()- returnA -< Right (not (s >= p))+noiseF1 :: (Arrow (Wire e (>~)), WRandom (>~)) => Wire e (>~) a Double+noiseF1 = ((*2) . pred) ^<< noise
Control/Wire/Prefab/Sample.hs view
@@ -8,7 +8,7 @@ module Control.Wire.Prefab.Sample ( -- * Simple samplers- discrete,+ WDiscrete(..), keep ) where@@ -17,6 +17,7 @@ import Control.Wire.Classes import Control.Wire.Prefab.Simple import Control.Wire.Types+import Data.AdditiveGroup -- | Sample the right signal at discrete intervals given by the left@@ -24,28 +25,36 @@ -- -- * Depends: Current instant (left), last sampling instant (right). -discrete ::- forall b e t (>~). (ArrowClock (>~), Num t, Ord t, Time (>~) ~ t)- => Wire e (>~) (t, b) b-discrete =- mkGen $ proc (_, x) -> do- t <- arrTime -< ()- returnA -< (Right x, discrete' t x)+class Arrow (>~) => WDiscrete t (>~) | (>~) -> t where+ discrete :: Wire e (>~) (t, b) b - where- discrete' :: t -> b -> Wire e (>~) (t, b) b- discrete' t' x0 =- mkGen $ proc (dt, x) -> do- t <- arrTime -< ()- returnA -<- if (t - t' >= dt)- then (Right x, discrete' t x)- else (Right x0, discrete' t' x0)+instance (AdditiveGroup t, MonadClock t m, Ord t) => WDiscrete t (Kleisli m) where+ discrete =+ WmGen $ \(int, x) ->+ if int <= zeroV+ then return (Right x, discrete)+ else do+ t <- getTime+ return (Right x, discrete' t x) + where+ discrete' :: t -> b -> Wire e (Kleisli m) (t, b) b+ discrete' t0 x0 =+ WmGen $ \(int, x) ->+ if int > zeroV+ then do+ t <- getTime+ let tt = t0 ^+^ int+ return $+ if t >= tt+ then (Right x, discrete' tt x)+ else (Right x0, discrete' t0 x0)+ else return (Right x, discrete) + -- | Keep the signal in the first instant forever. -- -- * Depends: First instant. -keep :: Wire e (>~) b b+keep :: WirePure (>~) => Wire e (>~) b b keep = mkPure $ \x -> (Right x, constant x)
Control/Wire/Prefab/Simple.hs view
@@ -28,8 +28,8 @@ -- | The constant wire. Outputs the given value all the time. -constant :: b -> Wire e (>~) a b-constant x = x `seq` mkPureFix (Right . const x)+constant :: WirePure (>~) => b -> Wire e (>~) a b+constant x = mkPureFix (Right . const x) -- | Force the input signal to weak head normal form, before outputting@@ -37,8 +37,8 @@ -- -- * Depends: Current instant. -force :: Wire e (>~) b b-force = mkPureFix $ \x -> x `seq` Right x+force :: WirePure (>~) => Wire e (>~) b b+force = mkPureFix (Right $!) -- | Force the input signal to normal form, before outputting it.@@ -46,16 +46,16 @@ -- -- * Depends: Current instant. -forceNF :: NFData b => Wire e (>~) b b-forceNF = mkPureFix $ \x -> x `deepseq` Right x+forceNF :: (NFData b, WirePure (>~)) => Wire e (>~) b b+forceNF = mkPureFix (\x -> x `deepseq` Right x) -- | The identity wire. Outputs its input signal unchanged. -- -- * Depends: Current instant. -identity :: Wire e (>~) a a-identity = mkPureFix (Right $!)+identity :: WirePure (>~) => Wire e (>~) a a+identity = mkPureFix (Right $) -- | Inject the given 'Either' value as a signal. 'Left' means@@ -65,7 +65,7 @@ -- -- * Inhibits: When input is 'Left'. -inject :: Wire e (>~) (Either e b) b+inject :: WirePure (>~) => Wire e (>~) (Either e b) b inject = mkPureFix id @@ -76,5 +76,5 @@ -- -- * Inhibits: When input is 'Nothing'. -injectEvent :: Monoid e => Wire e (>~) (Maybe b) b+injectEvent :: (Monoid e, WirePure (>~)) => Wire e (>~) (Maybe b) b injectEvent = mkPureFix (maybe (Left mempty) Right)
Control/Wire/Prefab/Split.hs view
@@ -4,56 +4,62 @@ -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- Wires for splitting and terminating computations.+-- Nondeterministic wires. module Control.Wire.Prefab.Split- ( -- * Simple splitters- fork,-- -- * Simple terminators- quit,- quitWith+ ( -- * Nondeterministic wires+ WSplit(..) ) where +import qualified Data.Foldable as F import Control.Arrow+import Control.Monad import Control.Wire.Types-import Data.Monoid+import Data.Foldable (Foldable) --- | Takes the input list and forks the wire for each value. Also forks--- a single inhibiting wire. Warning: Incorrect usage will cause space--- leaks! Use with care!------ * Depends: Current instant------ * Inhibits: Always in one thread, never in all others.+-- | Split the wires in the sense of the underlying arrow. A /thread/+-- in this sense is called a branch. This makes most sense with some+-- logic monad (like a list monad transformer) wrapped in a 'Kleisli'+-- arrow. ----- * Threads: Length of input list + 1.--fork :: (ArrowChoice (>~), ArrowPlus (>~), Monoid e) => Wire e (>~) [b] b-fork = mkFix fork'- where- fork' = proc xs' ->- case xs' of- [] -> returnA -< Left mempty- (x:xs) -> arr (Right . fst) <+> (fork' <<^ snd) -< (x, xs)+-- Warning: Incorrect usage will cause space leaks. Use with care! +class Arrow (>~) => WSplit (>~) where+ -- | Splits the wire into a branch for each given input value.+ -- Additionally adds a single inhibiting branch.+ --+ -- Note: This wire splits at every instant. In many cases you+ -- probably want to apply 'swallow' to it to split only in the first+ -- instant.+ --+ -- * Branches: As many as there are input values + 1.+ --+ -- * Depends: Current instant.+ --+ -- * Inhibits: Always in one branch, never in all others.+ branch :: Foldable f => Wire e (>~) (f b) b --- | Terminates the current wire with no output.------ * Threads: None.+ -- | Quits the current branch.+ --+ -- * Branches: Zero.+ quit :: Wire e (>~) a b -quit :: ArrowZero (>~) => Wire e (>~) a b-quit = mkGen zeroArrow+ -- | Acts like the identity wire in the first instant and terminates+ -- the branch in the next.+ --+ -- * Branches: One, then zero.+ --+ -- * Depends: Current instant.+ quitWith :: Wire e (>~) b b --- | Terminates the current wire thread with the given input value as--- the last output.------ * Depends: Current instant.------ * Threads: 1, then none.+instance MonadPlus m => WSplit (Kleisli m) where+ branch =+ WmGen $ \xs' -> do+ x <- F.foldl' (\xs x -> xs `mplus` return x) mzero xs'+ return (Right x, branch) -quitWith :: ArrowZero (>~) => Wire e (>~) b b-quitWith = mkGen $ arr (\x -> (Right x, quit))+ quit = WmGen (const mzero)+ quitWith = WmPure (\x -> (Right x, quit))
Control/Wire/Session.hs view
@@ -9,38 +9,93 @@ module Control.Wire.Session ( -- * Running wires stepWire,+ stepWireM, -- * Testing wires- testWire+ testWire,+ testWireM,+ -- ** Utility functions+ printInt,+ printRes,+ showRes,+ succMod ) where import Control.Arrow import Control.Monad+import Control.Monad.Trans import Control.Wire.Classes import Control.Wire.Types import System.IO +-- | Print a wire result on one line at regular intervals (first+-- argument). The second argument is the interval counter.++printInt :: (Num a, Ord a) => a -> a -> String -> IO a+printInt int n' str = do+ when (n' == 0) (printRes str)+ return (succMod int n')+++-- | Print a wire result on one line.++printRes :: String -> IO ()+printRes str = do+ putStr "\r\027[K"+ putStr str+ hFlush stdout+++-- | Turn a wire result into a string for printing.++showRes :: Show e => Either e String -> String+showRes = either (("Inhibited: " ++) . show) id++ -- | Performs an instant of the given wire. stepWire ::- Arrow (>~)+ WireToGen (>~) => Wire e (>~) a b -- ^ Wire to step. -> (a >~ (Either e b, Wire e (>~) a b)) stepWire = toGen +-- | Performs an instant of the given monad-based wire.++stepWireM ::+ Monad m+ => Wire e (Kleisli m) a b -- ^ Wire to step.+ -> a -- ^ Input signal.+ -> m (Either e b, Wire e (Kleisli m) a b)+stepWireM = toGenM+++-- | Increments. Results in 0, if the result is greater than or equal+-- to the first argument.++succMod :: (Num a, Ord a) => a -> a -> a+succMod int n =+ let nn = n + 1 in+ if nn >= int then 0 else nn++ -- | Test a wire. This function runs the given wire continuously -- printing its output on a single line.+--+-- The first argument specifies how often the wire's result is printed.+-- If you specify 100 here, then the output is printed at every 100th+-- frame. testWire ::- forall a e (>~). (ArrowApply (>~), ArrowIO (>~), Show e)- => Int -- ^ Frames per output. FPS/accuracy tradeoff.+ forall a e m (>~). (ArrowApply (>~), ArrowKleisli m (>~), MonadIO m, Show e, WireToGen (>~))+ => Int -- ^ Frames per output. Speed/accuracy tradeoff. -> (() >~ a) -- ^ Input generator. -> (Wire e (>~) a String >~ ()) testWire int getInput =- proc w' -> loop -< (int, w')+ proc w' -> loop -< (0, w') where loop :: (Int, Wire e (>~) a String) >~ ()@@ -58,3 +113,25 @@ hFlush stdout loop -< (n, w)+++-- | Test a monad-based wire. This function runs the given wire+-- continuously printing its output on a single line.+--+-- The first argument specifies how often the wire's result is printed.+-- If you specify 100 here, then the output is printed at every 100th+-- frame.++testWireM ::+ forall a e m. (Show e, MonadIO m)+ => Int -- ^ Frames per output. FPS/accuracy tradeoff.+ -> m a -- ^ Input generator.+ -> Wire e (Kleisli m) a String+ -> m ()+testWireM int getInput = loop 0+ where+ loop :: Int -> Wire e (Kleisli m) a String -> m ()+ loop n' w' = do+ (mstr, w) <- stepWireM w' =<< getInput+ n <- liftIO . printInt int n' . showRes $ mstr+ loop n w
+ Control/Wire/TimedMap.hs view
@@ -0,0 +1,117 @@+-- |+-- Module: Control.Wire.TimedMap+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- This module implements a map, where each key has a timestamp. It+-- maintains a timestamp index allowing you delete oldest entries+-- quickly.++module Control.Wire.TimedMap+ ( -- * Timed map+ TimedMap(..),++ -- * Operations+ -- ** Construct+ tmEmpty,+ -- ** Read+ tmFindWithDefault,+ tmLookup,+ -- ** Modify+ tmInsert,+ tmLimitAge,+ tmLimitSize+ )+ where++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Map (Map)+import Data.Set (Set)+++-- | A timed map is a regular map with timestamps and a timestamp index.++data TimedMap t k a =+ TimedMap {+ tmMap :: Map k (a, t), -- ^ Underlying map with timestamps.+ tmTimes :: Map t (Set k) -- ^ Timestamp index.+ }+ deriving Show+++-- | Find a value with default.++tmFindWithDefault ::+ Ord k+ => a -- ^ Default, if key is not found.+ -> k -- ^ Key to look up.+ -> TimedMap t k a -- ^ Map to query.+ -> a -- ^ Retrieved or default value.+tmFindWithDefault x0 k = M.findWithDefault x0 k . fmap fst . tmMap+++-- | The empty timed map.++tmEmpty :: TimedMap t k a+tmEmpty = TimedMap M.empty M.empty+++-- | Insert a value into the map.++tmInsert ::+ (Ord k, Ord t)+ => t -- ^ Timestamp.+ -> k -- ^ Key.+ -> a -- ^ Value.+ -> TimedMap t k a -- ^ Original map.+ -> TimedMap t k a -- ^ Map with the value added.+tmInsert t k x (TimedMap xs' ts'') =+ TimedMap xs ts++ where+ xs = M.insert k (x, t) xs'+ ts = M.insertWith S.union t (S.singleton k) ts'+ ts' =+ case M.lookup k xs' of+ Nothing -> ts''+ Just (_, t') ->+ M.update (\s' -> let s = S.delete k s' in+ if S.null s then Nothing else Just s)+ t' ts''+++-- | Delete all items older than the specified timestamp.++tmLimitAge :: (Ord t, Ord k) => t -> TimedMap t k a -> TimedMap t k a+tmLimitAge minT (TimedMap xs' ts') = TimedMap xs ts+ where+ xs = xs' M.\\ delMap+ ts = maybe id (M.insert minT) tsCur tsYounger++ (tsOlder, tsCur, tsYounger) = M.splitLookup minT ts'+ delMap =+ M.fromDistinctAscList . map (, ()) .+ S.toAscList . S.unions . M.elems $ tsOlder+++-- | Delete at least as many oldest items as necessary to limit the+-- map's size to the given value. If you have multiple keys with the+-- same timestamp, this function can delete more keys than necessary.++tmLimitSize :: Ord k => Int -> TimedMap t k a -> TimedMap t k a+tmLimitSize n tm@(TimedMap xs ts') =+ if n >= 0 && M.size xs > n+ then tmLimitSize n $ TimedMap (xs M.\\ delMap) ts+ else tm++ where+ delMap = M.fromDistinctAscList . map (, ()) . S.toAscList $ delKeys+ ((_, delKeys), ts) = M.deleteFindMin ts'+++-- | Look up the value for the given key.++tmLookup :: Ord k => k -> TimedMap t k a -> Maybe a+tmLookup k (TimedMap xs _) = fmap fst (M.lookup k xs)
Control/Wire/Tools.hs view
@@ -9,7 +9,10 @@ module Control.Wire.Tools ( -- * Arrow tools distA,- mapA+ mapA,++ -- * Utility functions+ dup ) where @@ -22,6 +25,12 @@ distA :: forall a b (>~). Arrow (>~) => [a >~ b] -> (a >~ [b]) distA [] = arr (const []) distA (c:cs) = arr (uncurry (:)) <<< c &&& distA cs+++-- | Duplicate a value into a tuple.++dup :: a -> (a, a)+dup x = (x, x) -- | Lift an arrow computation to lists of values.
Control/Wire/Trans.hs view
@@ -8,14 +8,20 @@ module Control.Wire.Trans ( -- * Reexports+ module Control.Wire.Trans.Clock, module Control.Wire.Trans.Combine, module Control.Wire.Trans.Exhibit,+ module Control.Wire.Trans.Fork,+ module Control.Wire.Trans.Memoize, module Control.Wire.Trans.Sample, module Control.Wire.Trans.Simple ) where +import Control.Wire.Trans.Clock import Control.Wire.Trans.Combine import Control.Wire.Trans.Exhibit+import Control.Wire.Trans.Fork+import Control.Wire.Trans.Memoize import Control.Wire.Trans.Sample import Control.Wire.Trans.Simple
+ Control/Wire/Trans/Clock.hs view
@@ -0,0 +1,128 @@+-- |+-- Module: Control.Wire.Trans.Clock+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Supplying clocks to wires.++module Control.Wire.Trans.Clock+ ( -- * Time deltas+ WWithDT(..),++ -- * Global time+ WWithSysTime(..),++ -- * Local time+ WWithTime(..)+ )+ where++import Control.Arrow+import Control.Monad.Fix+import Control.Wire.Classes+import Control.Wire.Types+import Data.AdditiveGroup+++-- | Passes time deltas to the given wire with respect to the clock+-- represented by the underlying arrow. Using this wire transformer you+-- can program in the more traditional AFRP way using time deltas+-- instead of time offsets. Note: The first time delta is 0.+--+-- * Depends: Like argument wire.+--+-- * Inhibits: When argument wire inhibits.++class Arrow (>~) => WWithDT t (>~) | (>~) -> t where+ -- | Simplified variant without additional input.+ passDT :: Wire e (>~) t b -> Wire e (>~) a b++ -- | Full variant.+ withDT :: Wire e (>~) (a, t) b -> Wire e (>~) a b++instance (AdditiveGroup t, MonadClock t m) => WWithDT t (Kleisli m) where+ passDT w' =+ WmGen $ \_ -> do+ t <- getTime+ (mx, w) <- toGenM w' zeroV+ return (mx, withDT' t w)++ where+ withDT' :: t -> Wire e (Kleisli m) t b -> Wire e (Kleisli m) a b+ withDT' t' w' =+ WmGen $ \_ -> do+ t <- getTime+ let dt = t ^-^ t'+ (mx, w) <- toGenM w' dt+ return (mx, withDT' t w)++ withDT w' =+ WmGen $ \x' -> do+ t <- getTime+ (mx, w) <- toGenM w' (x', zeroV)+ return (mx, withDT' t w)++ where+ withDT' :: t -> Wire e (Kleisli m) (a, t) b -> Wire e (Kleisli m) a b+ withDT' t' w' =+ WmGen $ \x' -> do+ t <- getTime+ let dt = t ^-^ t'+ (mx, w) <- toGenM w' (x', dt)+ return (mx, withDT' t w)+++-- | Passes the time passed since the first instant to the given wire.+--+-- * Depends: Like argument wire.+--+-- * Inhibits: When argument wire inhibits.++class Arrow (>~) => WWithTime t (>~) | (>~) -> t where+ -- | Simplified variant without additional input.+ passTime :: Wire e (>~) t b -> Wire e (>~) a b++ -- | Full variant.+ withTime :: Wire e (>~) (a, t) b -> Wire e (>~) a b++instance (AdditiveGroup t, MonadClock t m) => WWithTime t (Kleisli m) where+ passTime = withTime . mapInputM snd++ withTime w' =+ WmGen $ \x' -> do+ t0 <- getTime+ (mx, w) <- toGenM w' (x', zeroV)+ return (mx, withTime' t0 w)++ where+ withTime' :: t -> Wire e (Kleisli m) (a, t) b -> Wire e (Kleisli m) a b+ withTime' t0 =+ fix $ \again w' ->+ WmGen $ \x' -> do+ t <- getTime+ (mx, w) <- toGenM w' (x', t ^-^ t0)+ return (mx, again w)+++-- | Passes the system time to the given wire.+--+-- * Depends: Like argument wire.+--+-- * Inhibits: When argument wire inhibits.++class Arrow (>~) => WWithSysTime t (>~) | (>~) -> t where+ -- | Simplified variant without additional input.+ passSysTime :: Wire e (>~) t b -> Wire e (>~) a b++ -- | Full variant.+ withSysTime :: Wire e (>~) (a, t) b -> Wire e (>~) a b++instance MonadClock t m => WWithSysTime t (Kleisli m) where+ passSysTime = withSysTime . mapInputM snd++ withSysTime w' =+ WmGen $ \x' -> do+ t <- getTime+ (mx, w) <- toGenM w' (x', t)+ return (mx, withSysTime w)
Control/Wire/Trans/Combine.hs view
@@ -8,97 +8,81 @@ module Control.Wire.Trans.Combine ( -- * Context-sensitive evolution- context,- contextLimit,+ WContext(..),+ WContextLimit(..), -- * Distribute- distribute+ WDistribute(..) ) 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.TimedMap import Control.Wire.Types+import Data.AdditiveGroup import Data.Either-import Data.Map (Map)-import Data.Set (Set) -- | Make the given wire context-sensitive. The right signal is a -- context and the wire will evolve individually for each context. -- -- * Depends: Like context wire (left), current instant (right).+-- -- * Inhibits: Like context wire. -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)+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' :: Ord k => Map k (Wire e (Kleisli m) (a, k) b) -> Wire e (Kleisli m) (a, k) b+ 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) + -- | Same as 'context', but with a time limit. The third signal -- specifies a maximum age. Contexts not used for longer than the -- maximum age are forgotten. -- -- * Depends: Like context wire (left), current instant (right).+-- -- * Inhibits: Like context wire. -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'+class Arrow (>~) => WContextLimit t (>~) | (>~) -> t where+ contextLimit :: Ord k => Wire e (>~) (a, k) b -> Wire e (>~) ((a, k), t) b - 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''+instance (AdditiveGroup t, MonadClock t m, Ord t) => WContextLimit t (Kleisli m) where+ contextLimit w0 = context' tmEmpty+ where+ --context' :: Ord k => TimedMap t k (Wire e (Kleisli m) (a, k) b) -> Wire e (Kleisli m) ((a, k), t) b+ context' ctxs' =+ WmGen $ \((x', ctx), maxAge) -> do+ t <- getTime+ let w' = tmFindWithDefault w0 ctx ctxs'+ (mx, w) <- toGenM w' (x', ctx) - (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)+ let ctxs = tmLimitAge (t ^-^ maxAge) . tmInsert t ctx w $ ctxs'+ return (mx, context' ctxs) -- | Distribute the input signal over the given wires, evolving each of--- them individually. Collects produced outputs.------ Note: This wire transformer discards all inhibited signals.+-- them individually. Discards all inhibited signals. -- -- * Depends: as strict as the strictest subwire. -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)+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)
Control/Wire/Trans/Exhibit.hs view
@@ -8,8 +8,7 @@ module Control.Wire.Trans.Exhibit ( -- * Exhibition- event,- exhibit+ WExhibit(..) ) where @@ -17,31 +16,54 @@ import Control.Wire.Types --- | Produces 'Just', whenever the argument wire produces, otherwise--- 'Nothing'.------ * Depends: like argument wire.+-- | Wire transformers for handling inhibited signals. -event :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a (Maybe b)-event (WPure f) =- mkPure $ \(f -> (mx, w)) ->- (Right $ either (const Nothing) Just mx, event w)-event (WGen c) =- mkGen $ proc x' -> do- (mx, w) <- c -< x'- returnA -< (Right $ either (const Nothing) Just mx, event w)+class Arrow (>~) => WExhibit (>~) where+ -- | Produces 'Just', whenever the argument wire produces, otherwise+ -- 'Nothing'.+ --+ -- * Depends: like argument wire.+ event :: Wire e (>~) a b -> Wire e (>~) a (Maybe b) + -- | Produces 'Right', whenever the argument wire produces, otherwise+ -- 'Left' with the inhibition value.+ --+ -- * Depends: like argument wire.+ exhibit :: Wire e (>~) a b -> Wire e (>~) a (Either e b) --- | Produces 'Right', whenever the argument wire produces, otherwise--- 'Left' with the inhibition value.------ * Depends: like argument wire.+ -- | Produces 'True', whenever the argument wire produces, otherwise+ -- 'False'.+ gotEvent :: Wire e (>~) a b -> Wire e (>~) a Bool -exhibit :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a (Either e b)-exhibit (WPure f) =- mkPure $ \(f -> (mx, w)) ->- (Right mx, exhibit w)-exhibit (WGen c) =- mkGen $ proc x' -> do- (mx, w) <- c -< x'- returnA -< (Right mx, exhibit w)++instance Monad m => WExhibit (Kleisli m) where+ event (WmPure f) =+ WmPure $ \(f -> (mx, w)) ->+ (Right (either (const Nothing) Just mx), event w)+ event (WmGen c) =+ WmGen $ \x' -> do+ (mx, w) <- c x'+ return (Right (either (const Nothing) Just mx), event w)++ exhibit (WmPure f) =+ WmPure $ \(f -> (mx, w)) ->+ (Right mx, exhibit w)+ exhibit (WmGen c) =+ WmGen $ \x' -> do+ (mx, w) <- c x'+ return (Right mx, exhibit w)++ gotEvent (WmPure f) =+ WmPure $ \(f -> (mx, w)) ->+ (Right (isRight mx), gotEvent w)+ gotEvent (WmGen c) =+ WmGen $ \x' -> do+ (mx, w) <- c x'+ return (Right (isRight mx), gotEvent w)+++-- | 'True', if 'Right'.++isRight :: Either e a -> Bool+isRight (Right _) = True+isRight (Left _) = False
+ Control/Wire/Trans/Fork.hs view
@@ -0,0 +1,232 @@+-- |+-- Module: Control.Wire.Trans.Fork+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wire concurrency.+--+-- /Warning/: This module is highly experimental and currently causes+-- space leaks. Please use wire concurrency only for short-lived+-- threads.++module Control.Wire.Trans.Fork+ ( -- * Embedding concurrent wires+ WFork(..),++ -- * Wire thread manager+ WireMgr,+ startWireMgr,+ stopWireMgr,+ withWireMgr,++ -- * Wire threads+ -- ** Channels+ WireChan,+ feedWireChan,+ readWireChan,+ -- ** Threads+ WireThread,+ killWireThread+ )+ where++import qualified Data.Map as M+import Control.Applicative+import Control.Arrow+import Control.Concurrent.Forkable+import Control.Concurrent.STM+import Control.Exception.Control+import Control.Monad+import Control.Monad.Fix+import Control.Monad.IO.Control+import Control.Monad.Trans+import Control.Wire.Types+import Data.Map (Map)+import Data.Monoid+++{-# WARNING WFork "Wire concurrency is not stable at the moment!" #-}+++-- | Forking wire transformer. Creates a concurrent wire thread and+-- opens a communication channel to it.++class Arrow (>~) => WFork (>~) where+ -- | Feed a wire thread with additional input.+ --+ -- * Depends: Current instant.+ feedWire :: Wire e (>~) (WireChan a b, a) ()++ -- | Fork the input wire using the input wire manager.+ --+ -- Note: This wire forks at every instant. In many cases you will+ -- want to use the 'swallow' wire transformer with this.+ --+ -- * Depends: Current instant.+ forkWire :: Wire e (>~) (Wire e (>~) a b, WireMgr)+ (WireChan a b, WireThread)++ -- | Asks the given wire for its next output.+ --+ -- * Depends: Current instant.+ --+ -- * Inhibits: When there is no data.+ queryWire :: Monoid e => Wire e (>~) (WireChan a b) b++instance (ForkableMonad m, MonadControlIO m) => WFork (Kleisli m) where+ -- feedWire+ feedWire =+ mkFixM $ \(wc, x') -> do+ let ichan = wcInputChan wc+ liftIO . atomically $ writeTChan ichan x'+ return (Right ())++ -- forkWire+ forkWire =+ mkFixM $ \(thrW, mgr) -> do+ ichan <- liftIO newTChanIO+ ochan <- liftIO newTChanIO+ doneVar <- liftIO (newTVarIO False)+ quitVar <- liftIO (newTVarIO False)++ let wc = WireChan { wcInputChan = ichan,+ wcOutputChan = ochan }++ mgrOp mgr $ do+ tid <- forkIO (thread ichan ochan quitVar doneVar thrW)++ let wt = WireThread { wtDoneVar = doneVar,+ wtThreadId = tid,+ wtQuitVar = quitVar }++ let thrsVar = wmThrsVar mgr+ liftIO . atomically $ do+ thrs <- readTVar thrsVar+ writeTVar thrsVar (M.insert tid wt thrs)++ return (Right (wc, wt))++ where+ thread ichan ochan quitVar doneVar =+ fix $ \loop w' -> do+ mx' <- liftIO . atomically $+ Just <$> readTChan ichan <|>+ Nothing <$ (readTVar quitVar >>= check)+ case mx' of+ Just x' -> do+ (mx, w) <- toGenM w' x'+ either (const $ return ()) (liftIO . atomically . writeTChan ochan) mx+ loop w+ Nothing -> do+ liftIO (atomically $ writeTVar doneVar True)++ -- queryWire+ queryWire =+ mkFixM $ \wc -> do+ let ochan = wcOutputChan wc+ liftIO . atomically $+ Right <$> readTChan ochan <|>+ return (Left mempty)+++-- | A wire channel allows you to send input to and receive output from+-- a concurrently running wire.++data WireChan a b =+ WireChan {+ wcInputChan :: !(TChan a), -- ^ Input channel.+ wcOutputChan :: !(TChan b) -- ^ Output channel.+ }+++-- | A wire thread manager keeps track of created wire threads.++data WireMgr =+ WireMgr {+ wmFreeVar :: !(TVar Bool),+ wmThrsVar :: !(TVar (Map ThreadId WireThread))+ }+++-- | A wire thread is a concurrently running wire.++data WireThread+ = WireThread {+ wtDoneVar :: !(TVar Bool), -- ^ True, when wire has quitted.+ wtThreadId :: !ThreadId, -- ^ Thread id.+ wtQuitVar :: !(TVar Bool) -- ^ Set to true to terminate the wire.+ }+++-- | Feed the given wire thread with input.++feedWireChan :: WireChan a b -> a -> IO ()+feedWireChan (wcInputChan -> ichan) = atomically . writeTChan ichan+++-- | Kill the given wire thread.++killWireThread :: WireMgr -> WireThread -> IO ()+killWireThread mgr thr = do+ let WireThread { wtDoneVar = doneVar,+ wtThreadId = tid,+ wtQuitVar = quitVar } = thr+ thrsVar = wmThrsVar mgr+ mgrOp mgr $ do+ thrs <- readTVarIO thrsVar+ atomically (writeTVar quitVar True)+ atomically $ do+ readTVar doneVar >>= check+ writeTVar thrsVar (M.delete tid thrs)+++-- | Perform a manager operation safely.++mgrOp :: MonadControlIO m => WireMgr -> m a -> m a+mgrOp mgr c = do+ let freeVar = wmFreeVar mgr+ liftIO . atomically $ do+ readTVar freeVar >>= check+ writeTVar freeVar False++ c `finally` liftIO (atomically $ writeTVar freeVar True)+++-- | Read the given wire's next output.++readWireChan :: WireChan a b -> IO b+readWireChan (wcOutputChan -> ochan) = atomically (readTChan ochan)+++-- | Start a wire manager.++startWireMgr :: IO WireMgr+startWireMgr = do+ freeVar <- newTVarIO True+ thrsVar <- newTVarIO M.empty+ return WireMgr { wmFreeVar = freeVar,+ wmThrsVar = thrsVar }+++-- | Stop a wire manager terminating all threads it keeps track of.++stopWireMgr :: WireMgr -> IO ()+stopWireMgr mgr =+ mgrOp mgr $ do+ let thrsVar = wmThrsVar mgr+ thrs <- fmap M.assocs (readTVarIO thrsVar)+ forM_ thrs $ \(_, wtQuitVar -> quitVar) ->+ atomically (writeTVar quitVar True)+ forM_ thrs $ \(tid, wtDoneVar -> doneVar) -> do+ atomically (readTVar doneVar >>= check)+ killThread tid+ atomically (writeTVar thrsVar M.empty)+++-- | Convenient wrapper around 'startWireMgr' and 'stopWireMgr'.++withWireMgr :: MonadControlIO m => (WireMgr -> m a) -> m a+withWireMgr k = do+ mgr <- liftIO startWireMgr+ k mgr `finally` liftIO (stopWireMgr mgr)
+ Control/Wire/Trans/Memoize.hs view
@@ -0,0 +1,99 @@+-- |+-- Module: Control.Wire.Trans.Memoize+-- Copyright: (c) 2011 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Memoizing wire transformers.++module Control.Wire.Trans.Memoize+ ( -- * Memoizing+ WCache(..),+ WPurify(..)+ )+ where++import Control.Arrow+import Control.Monad.Fix+import Control.Wire.Classes+import Control.Wire.TimedMap+import Control.Wire.Types+import Data.AdditiveGroup+++-- | Remember the most recently produced values. You can limit both the+-- maximum age and the number of remembered values. The second input+-- value specifies the maximum age, the third specifies the maximum+-- number.+--+-- Note: Inhibtion is never remembered.+--+-- Note: Decreasing the size limit has O(n * log n) complexity, where n+-- is the difference to the old limit.+--+-- * Depends: Current instant.+--+-- * Inhibits: Whenever result is not cached and argument wire inhibits.++class Arrow (>~) => WCache t (>~) | (>~) -> t where+ cache :: Ord a => Wire e (>~) a b -> Wire e (>~) ((a, t), Int) b++instance (AdditiveGroup t, MonadClock t m, Ord t) => WCache t (Kleisli m) where+ cache = cache' tmEmpty+ where+ cache' :: Ord a => TimedMap t a b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) ((a, t), Int) b+ cache' xs' w' =+ WmGen $ \((x', maxAge), limit) -> do+ t <- getTime+ (mx, w) <-+ case tmLookup x' xs' of+ Nothing -> toGenM w' x'+ Just x -> return (Right x, w')+ let xs = tmLimitSize limit .+ tmLimitAge (t ^-^ maxAge) .+ either (const id) (tmInsert t x') mx $ xs'+ return (mx, cache' xs w)+++-- | Remember the last produced value. Whenever an input is repeated,+-- the argument wire is ignored and the memoized result is returned+-- instantly. Note: inhibition will not be remembered.+--+-- * Depends: Current instant.+--+-- * Inhibits: Like the argument wire for non-memoized inputs.++class Arrow (>~) => WPurify (>~) where+ purify :: Eq a => Wire e (>~) a b -> Wire e (>~) a b++instance Monad m => WPurify (Kleisli m) where+ purify w' =+ case w' of+ WmPure f ->+ WmPure $ \x' ->+ let (mx, w) = f x' in+ (mx, either (const $ purify w) (\x -> purify' x' x w) mx)+ WmGen c ->+ WmGen $ \x' -> do+ (mx, w) <- c x'+ return (mx, either (const $ purify w) (\x -> purify' x' x w) mx)++ where+ purify' :: Eq a => a -> b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) a b+ purify' x0' x0 =+ fix $ \again w' ->+ case w' of+ WmPure f ->+ WmPure $ \x' ->+ if x' /= x0'+ then+ let (mx, w) = f x' in+ (mx, either (const $ again w) (\x -> purify' x' x w) mx)+ else (Right x0, again w')+ WmGen c ->+ WmGen $ \x' ->+ if x' /= x0'+ then do+ (mx, w) <- c x'+ return (mx, either (const $ again w) (\x -> purify' x' x w) mx)+ else return (Right x0, again w')
Control/Wire/Trans/Sample.hs view
@@ -8,108 +8,154 @@ module Control.Wire.Trans.Sample ( -- * Sampling- hold,- holdWith,- sample,- swallow+ 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 --- | Keeps the latest produced value.------ * Depends: Like argument wire.--- * Inhibits: Until first production.+-- | Hold signals. -hold :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a b-hold (WPure f) =- mkPure $ \x' ->- let (mx, w) = f x' in- case mx of- Left ex -> (Left ex, hold w)- Right x -> (Right x, holdWith x w)-hold (WGen c) =- mkGen $ proc x' -> do- (mx, w) <- c -< x'- returnA -<+class Arrow (>~) => WHold (>~) where+ -- | Keeps the latest produced value.+ --+ -- * Depends: Like argument wire.+ --+ -- * Inhibits: Until first production.+ hold :: Wire e (>~) a b -> Wire e (>~) a b++ -- | Keeps the latest produced value. Produces the argument value until+ -- the argument wire starts producing.+ --+ -- * Depends: Like argument wire.+ holdWith :: b -> Wire e (>~) a b -> Wire e (>~) a b++instance Monad m => WHold (Kleisli m) where+ -- hold+ 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)----- | Keeps the latest produced value. Produces the argument value until--- the argument wire starts producing.------ * Depends: Like argument wire.+ 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 :: Arrow (>~) => b -> Wire e (>~) a b -> Wire e (>~) a b-holdWith x0 (WPure f) =- mkPure $ \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 (WGen c) =- mkGen $ proc x' -> do- (mx, w) <- c -< x'- returnA -<+ -- holdWith+ 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) --- | Samples the given wire at discrete intervals. Only runs the input--- through the wire, then the next sampling interval has elapsed.+-- | Samples the given wire at discrete time intervals. Only runs the+-- input through the wire, when the next sampling interval starts. -- -- * Depends: Current instant (left), like argument wire at sampling -- intervals (right).+-- -- * Inhibits: Starts inhibiting when argument wire inhibits. Keeps -- inhibiting until next sampling interval. -sample ::- forall a b e t (>~).- (ArrowChoice (>~), ArrowClock (>~), Num t, Ord t, Time (>~) ~ t)- => Wire e (>~) a b- -> Wire e (>~) (a, t) b-sample w' =- mkGen $ proc (x', _) -> do- t <- arrTime -< ()- (mx, w) <- toGen w' -< x'- returnA -< (mx, sample' t mx w)+class Arrow (>~) => WSample t (>~) | (>~) -> t where+ sample :: Wire e (>~) a b -> Wire e (>~) (a, t) b - where- sample' :: t -> Either e b -> Wire e (>~) a b -> Wire e (>~) (a, t) b- sample' t' mx0 w' =- mkGen $ proc (x', dt) -> do- t <- arrTime -< ()- if t - t' < dt- then returnA -< (mx0, sample' t' mx0 w')+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- (mx, w) <- toGen w' -< x'- returnA -< (mx, sample' t mx w)+ 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') ++-- | Samples the given wire at discrete frame count intervals. Only+-- runs the input through the wire, when the next sampling interval+-- starts.+--+-- * Depends: Current instant (left), like argument wire at sampling+-- intervals (right).+--+-- * Inhibits: Starts inhibiting when argument wire inhibits. Keeps+-- inhibiting until next sampling interval.++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')++ -- | Waits for the argument wire to produce and then keeps the first -- produced value forever. -- -- * Depends: Like argument wire until first production. Then stops -- depending.+-- -- * Inhibits: Until the argument wire starts producing. -swallow :: ArrowChoice (>~) => Wire e (>~) a b -> Wire e (>~) a b-swallow (WPure f) =- mkPure $ \x' ->- case f x' of- (Left ex, w) -> (Left ex, swallow w)- (Right x, _) -> (Right x, constant x)-swallow (WGen c) =- mkGen $ proc x' -> do- (mx, w) <- c -< x'- case mx of- Left ex -> returnA -< (Left ex, swallow w)- Right x -> returnA -< (Right x, constant x)+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)
Control/Wire/Trans/Simple.hs view
@@ -8,7 +8,7 @@ module Control.Wire.Trans.Simple ( -- * Override input- (--<),+ WOverrideInput(..), (>--) ) where@@ -17,32 +17,41 @@ import Control.Wire.Types --- | Apply the given function to the input, until the argument wire--- starts producing.------ * Depends: Like argument wire.--- * Inhibits: Like argument wire.+-- | Override input. -(--<) :: Arrow (>~) => Wire e (>~) a b -> (a -> a) -> Wire e (>~) a b-WPure f --< g =- mkPure $ \x' ->- let (mx, w) = f (g x') in- (mx, either (const $ w --< g) (const w) mx)-WGen c --< g =- mkGen $ proc x' -> do- (mx, w) <- c -< g x'- returnA -< (mx, either (const $ w --< g) (const w) mx)+class Arrow (>~) => WOverrideInput (>~) where+ -- | Apply the given function to the input, until the argument wire+ -- starts producing.+ --+ -- * Depends: Like argument wire.+ --+ -- * Inhibits: Like argument wire. -infixr 5 --<+ (--<) :: Arrow (>~) => Wire e (>~) a b -> (a -> a) -> Wire e (>~) a b + infixr 5 --< ++instance Monad m => WOverrideInput (Kleisli m) where+ WmPure f --< g =+ WmPure $ \x' ->+ let (mx, w) = f (g x') in+ (mx, either (const $ w --< g) (const w) mx)+ WmGen c --< g =+ WmGen $ \x' -> do+ (mx, w) <- c (g x')+ return (mx, either (const $ w --< g) (const w) mx)+++ -- | Apply the given function to the input, until the argument wire -- starts producing. -- -- * Depends: Like argument wire.+-- -- * Inhibits: Like argument wire. -(>--) :: Arrow (>~) => (a -> a) -> Wire e (>~) a b -> Wire e (>~) a b+(>--) :: WOverrideInput (>~) => (a -> a) -> Wire e (>~) a b -> Wire e (>~) a b (>--) = flip (--<) infixl 5 >--
Control/Wire/Types.hs view
@@ -9,15 +9,22 @@ module Control.Wire.Types ( -- * The wire Wire(..),+ WireM, - -- * Smart construction- mkFix,- mkGen,- mkPure,- mkPureFix,+ -- * Construction and destruction+ WireGen(..),+ WirePure(..),+ WireToGen(..),+ mkFixM,+ toGenM, - -- * Destruction- toGen+ -- * Inhibition+ LastException,+ inhibitException,+ inhibitMsg,++ -- * Utilities+ mapInputM ) where @@ -27,71 +34,84 @@ import Control.Arrow.Operations import Control.Arrow.Transformer import Control.Category+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Writer.Class import Control.Wire.Classes+import Control.Wire.Tools import Data.Monoid import Prelude hiding ((.), id) +-- | Convenience type for wire exceptions.++type LastException = Last Ex.SomeException++ -- | Signal networks. -data Wire e (>~) a b where- WGen :: !(a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b- WPure :: !(a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b+data family Wire :: * -> (* -> * -> *) -> * -> * -> * +data instance Wire e (Kleisli m) a b where+ WmGen :: (a -> m (Either e b, Wire e (Kleisli m) a b)) -> Wire e (Kleisli m) a b+ WmPure :: (a -> (Either e b, Wire e (Kleisli m) a b)) -> Wire e (Kleisli m) a b + -- | Wire side channels. -instance ArrowChoice (>~) => Arrow (Wire e (>~)) where+instance Monad m => Arrow (Wire e (Kleisli m)) where arr f = mkPureFix $ Right . f - first (WGen c) =- WGen $ proc (x', y) -> do- (mx, w) <- c -< x'- returnA -< (fmap (, y) mx, first w)- first (WPure f) =- WPure $ \(x', y) ->+ first (WmGen c) =+ WmGen $ \(x', y) -> do+ (mx, w) <- c x'+ return (fmap (, y) mx, first w)+ first (WmPure f) =+ WmPure $ \(x', y) -> let (mx, w) = f x' in (fmap (, y) mx, first w) - second (WGen c) =- WGen $ proc (x, y') -> do- (my, w) <- c -< y'- returnA -< (fmap (x,) my, second w)- second (WPure f) =- WPure $ \(x, y') ->+ second (WmGen c) =+ WmGen $ \(x, y') -> do+ (my, w) <- c y'+ return (fmap (x,) my, second w)+ second (WmPure f) =+ WmPure $ \(x, y') -> let (my, w) = f y' in (fmap (x,) my, second w) -- (&&&) combinator.- WGen c1 &&& w2'@(WGen c2) =- WGen $ proc x' -> do- (mx1, w1) <- c1 -< x'+ WmGen c1 &&& w2'@(WmGen c2) =+ WmGen $ \x' -> do+ (mx1, w1) <- c1 x' case mx1 of- Left ex -> returnA -< (Left ex, w1 &&& w2')+ Left ex -> return (Left ex, w1 &&& w2') Right x1 -> do- (mx2, w2) <- c2 -< x'- returnA -< (fmap (x1,) mx2, w1 &&& w2)+ (mx2, w2) <- c2 x'+ return (fmap (x1,) mx2, w1 &&& w2) - WGen c1 &&& w2'@(WPure g) =- WGen $ proc x' -> do- (mx1, w1) <- c1 -< x'+ WmGen c1 &&& w2'@(WmPure g) =+ WmGen $ \x' -> do+ (mx1, w1) <- c1 x' case mx1 of- Left ex -> returnA -< (Left ex, w1 &&& w2')+ Left ex -> return (Left ex, w1 &&& w2') Right x1 -> let (mx2, w2) = g x' in- returnA -< (fmap (x1,) mx2, w1 &&& w2)+ return (fmap (x1,) mx2, w1 &&& w2) - WPure f &&& w2'@(WGen c2) =- WGen $ proc x' ->+ WmPure f &&& w2'@(WmGen c2) =+ WmGen $ \x' -> let (mx1, w1) = f x' in case mx1 of- Left ex -> returnA -< (Left ex, w1 &&& w2')+ Left ex -> return (Left ex, w1 &&& w2') Right x1 -> do- (mx2, w2) <- c2 -< x'- returnA -< (fmap (x1,) mx2, w1 &&& w2)+ (mx2, w2) <- c2 x'+ return (fmap (x1,) mx2, w1 &&& w2) - WPure f &&& w2'@(WPure g) =- WPure $ \x' ->+ WmPure f &&& w2'@(WmPure g) =+ WmPure $ \x' -> let (mx1, w1) = f x' (mx2, w2) = g x' in case mx1 of@@ -99,32 +119,33 @@ Right x1 -> (fmap (x1,) mx2, w1 &&& w2) -- (***) combinator.- WGen c1 *** w2'@(WGen c2) =- WGen $ proc (x', y') -> do- (mx, w1) <- c1 -< x'+ WmGen c1 *** w2'@(WmGen c2) =+ WmGen $ \(x', y') -> do+ (mx, w1) <- c1 x' case mx of- Left ex -> returnA -< (Left ex, w1 *** w2')+ Left ex -> return (Left ex, w1 *** w2') Right x -> do- (my, w2) <- c2 -< y'- returnA -< (fmap (x,) my, w1 *** w2)+ (my, w2) <- c2 y'+ return (fmap (x,) my, w1 *** w2) - WGen c1 *** w2'@(WPure g) =- WGen $ proc (x', g -> (my, w2)) -> do- (mx, w1) <- c1 -< x'- case mx of- Left ex -> returnA -< (Left ex, w1 *** w2')- Right x -> returnA -< (fmap (x,) my, w1 *** w2)+ WmGen c1 *** w2'@(WmPure g) =+ WmGen $ \(x', g -> (my, w2)) -> do+ (mx, w1) <- c1 x'+ return $+ case mx of+ Left ex -> (Left ex, w1 *** w2')+ Right x -> (fmap (x,) my, w1 *** w2) - WPure f *** w2'@(WGen c2) =- WGen $ proc (f -> (mx, w1), y') -> do+ WmPure f *** w2'@(WmGen c2) =+ WmGen $ \(f -> (mx, w1), y') -> do case mx of- Left ex -> returnA -< (Left ex, w1 *** w2')+ Left ex -> return (Left ex, w1 *** w2') Right x -> do- (my, w2) <- c2 -< y'- returnA -< (fmap (x,) my, w1 *** w2)+ (my, w2) <- c2 y'+ return (fmap (x,) my, w1 *** w2) - WPure f *** w2'@(WPure g) =- WPure $ \(f -> (mx, w1), g -> (my, w2)) ->+ WmPure f *** w2'@(WmPure g) =+ WmPure $ \(f -> (mx, w1), g -> (my, w2)) -> case mx of Left ex -> (Left ex, w1 *** w2') Right x -> (fmap (x,) my, w1 *** w2)@@ -132,70 +153,70 @@ -- | Support for choice (signal redirection). -instance ArrowChoice (>~) => ArrowChoice (Wire e (>~)) where- left w'@(WPure f) =- WPure $ \mx' ->+instance Monad m => ArrowChoice (Wire e (Kleisli m)) where+ left w'@(WmPure f) =+ WmPure $ \mx' -> case mx' of Left x' -> fmap Left *** left $ f x' Right x' -> (Right (Right x'), left w') - left w'@(WGen c) =- WGen $ proc mx' ->+ left w'@(WmGen c) =+ WmGen $ \mx' -> case mx' of- Left x' -> (fmap Left *** left) ^<< c -< x'- Right x' -> returnA -< (Right (Right x'), left w')+ Left x' -> liftM (fmap Left *** left) (c x')+ Right x' -> return (Right (Right x'), left w') - right w'@(WPure f) =- WPure $ \mx' ->+ right w'@(WmPure f) =+ WmPure $ \mx' -> case mx' of Right x' -> fmap Right *** right $ f x' Left x' -> (Right (Left x'), right w') - right w'@(WGen c) =- WGen $ proc mx' ->+ right w'@(WmGen c) =+ WmGen $ \mx' -> case mx' of- Right x' -> (fmap Right *** right) ^<< c -< x'- Left x' -> returnA -< (Right (Left x'), right w')+ Right x' -> liftM (fmap Right *** right) (c x')+ Left x' -> return (Right (Left x'), right w') - wl'@(WPure f) +++ wr'@(WPure g) =- WPure $ \mx' ->+ wl'@(WmPure f) +++ wr'@(WmPure g) =+ WmPure $ \mx' -> case mx' of Left x' -> (fmap Left *** (+++ wr')) . f $ x' Right x' -> (fmap Right *** (wl' +++)) . g $ x' wl' +++ wr' =- WGen $ proc mx' ->+ WmGen $ \mx' -> case mx' of- Left x' -> arr (fmap Left *** (+++ wr')) . toGen wl' -< x'- Right x' -> arr (fmap Right *** (wl' +++)) . toGen wr' -< x'+ Left x' -> liftM (fmap Left *** (+++ wr')) (toGenM wl' x')+ Right x' -> liftM (fmap Right *** (wl' +++)) (toGenM wr' x') - wl'@(WPure f) ||| wr'@(WPure g) =- WPure $ \mx' ->+ wl'@(WmPure f) ||| wr'@(WmPure g) =+ WmPure $ \mx' -> case mx' of Left x' -> second (||| wr') . f $ x' Right x' -> second (wl' |||) . g $ x' wl' ||| wr' =- WGen $ proc mx' ->+ WmGen $ \mx' -> case mx' of- Left x' -> arr (second (||| wr')) . toGen wl' -< x'- Right x' -> arr (second (wl' |||)) . toGen wr' -< x'+ Left x' -> liftM (second (||| wr')) (toGenM wl' x')+ Right x' -> liftM (second (wl' |||)) (toGenM wr' x') -- | Support for one-instant delays. -instance (ArrowChoice (>~), ArrowLoop (>~)) => ArrowCircuit (Wire e (>~)) where- delay x' = mkPure $ \x -> (Right x', delay x)+instance (MonadFix m, Monoid e) => ArrowCircuit (Wire e (Kleisli m)) where+ delay x' = WmPure $ \x -> (Right x', delay x) -- | Inhibition handling interface. See also the -- "Control.Wire.Trans.Exhibit" and "Control.Wire.Prefab.Event" modules. -instance ArrowChoice (>~) => ArrowError e (Wire e (>~)) where+instance Monad m => ArrowError e (Wire e (Kleisli m)) where raise = mkPureFix Left - handle (WPure f) wh'@(WPure fh) =- WPure $ \x' ->+ handle (WmPure f) wh'@(WmPure fh) =+ WmPure $ \x' -> let (mx, w) = f x' in case mx of Left ex ->@@ -204,19 +225,19 @@ Right _ -> (mx, handle w wh') handle w' wh' =- WGen $ proc x' -> do- (mx, w) <- toGen w' -< x'+ WmGen $ \x' -> do+ (mx, w) <- toGenM w' x' case mx of Left ex -> do- (mxh, wh) <- toGen wh' -< (x', ex)- returnA -< (mxh, handle w wh)- Right _ -> returnA -< (mx, handle w wh')+ (mxh, wh) <- toGenM wh' (x', ex)+ return (mxh, handle w wh)+ Right _ -> return (mx, handle w wh') - newError (WPure f) = WPure $ (Right *** newError) . f- newError (WGen c) = WGen $ arr (Right *** newError) . c+ newError (WmPure f) = WmPure $ (Right *** newError) . f+ newError (WmGen c) = WmGen $ liftM (Right *** newError) . c - tryInUnless (WPure f) ws'@(WPure fs) we'@(WPure fe) =- WPure $ \x' ->+ tryInUnless (WmPure f) ws'@(WmPure fs) we'@(WmPure fe) =+ WmPure $ \x' -> let (mx, w) = f x' in case mx of Left ex ->@@ -227,23 +248,22 @@ in (mxs, tryInUnless w ws we') tryInUnless w' ws' we' =- WGen $ proc x' -> do- (mx, w) <- toGen w' -< x'+ WmGen $ \x' -> do+ (mx, w) <- toGenM w' x' case mx of Left ex -> do- (mxe, we) <- toGen we' -< (x', ex)- returnA -< (mxe, tryInUnless w ws' we)+ (mxe, we) <- toGenM we' (x', ex)+ return (mxe, tryInUnless w ws' we) Right x -> do- (mxs, ws) <- toGen ws' -< (x', x)- returnA -< (mxs, tryInUnless w ws we')+ (mxs, ws) <- toGenM ws' (x', x)+ return (mxs, tryInUnless w ws we') --- | When the target arrow is an 'ArrowIO' (e.g. a Kleisli arrow over--- IO), then the wire arrow is also an @ArrowIO@.+-- | When the target arrow is an 'ArrowKleisli', then the wire arrow is+-- also an ArrowKleisli. -instance (Applicative f, ArrowChoice (>~), ArrowIO (>~)) =>- ArrowIO (Wire (f Ex.SomeException) (>~)) where- arrIO = mkFix $ arr (mapLeft pure) <<< arrIO <<< arr Ex.try+instance Monad m => ArrowKleisli m (Wire e (Kleisli m)) where+ arrM = mkFix (Right ^<< arrM) -- | Value recursion in the wire arrows. **NOTE**: Wires with feedback@@ -251,45 +271,46 @@ -- handling the inhibition case, which you will observe as a fatal -- pattern match error. -instance (ArrowChoice (>~), ArrowLoop (>~)) => ArrowLoop (Wire e (>~)) where+instance (MonadFix m, Monoid e) => ArrowLoop (Wire e (Kleisli m)) where loop w' =- WGen $ proc x' -> do- rec (Right (x, d), w) <- toGen w' -< (x', d)- returnA -< (Right x, loop w)+ WmGen $ \x' -> do+ rec (mx, w) <- toGenM w' (x', d)+ let d = either (error "Loop data dependency broken by inhibition") snd mx+ return (fmap fst mx, loop w) -- | Combining possibly inhibiting wires. -instance (ArrowChoice (>~), Monoid e) => ArrowPlus (Wire e (>~)) where- WGen c1 <+> w2'@(WGen c2) =- WGen $ proc x' -> do- (mx1, w1) <- c1 -< x'+instance (Monad m, Monoid e) => ArrowPlus (Wire e (Kleisli m)) where+ WmGen c1 <+> w2'@(WmGen c2) =+ WmGen $ \x' -> do+ (mx1, w1) <- c1 x' case mx1 of- Right _ -> returnA -< (mx1, w1 <+> w2')+ Right _ -> return (mx1, w1 <+> w2') Left ex1 -> do- (mx2, w2) <- c2 -< x'- returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)+ (mx2, w2) <- c2 x'+ return (mapLeft (mappend ex1) mx2, w1 <+> w2) - WGen c1 <+> w2'@(WPure g) =- WGen $ proc x' -> do- (mx1, w1) <- c1 -< x'+ WmGen c1 <+> w2'@(WmPure g) =+ WmGen $ \x' -> do+ (mx1, w1) <- c1 x' case mx1 of- Right _ -> returnA -< (mx1, w1 <+> w2')+ Right _ -> return (mx1, w1 <+> w2') Left ex1 -> let (mx2, w2) = g x' in- returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)+ return (mapLeft (mappend ex1) mx2, w1 <+> w2) - WPure f <+> w2'@(WGen c2) =- WGen $ proc x' ->+ WmPure f <+> w2'@(WmGen c2) =+ WmGen $ \x' -> let (mx1, w1) = f x' in case mx1 of- Right _ -> returnA -< (mx1, w1 <+> w2')+ Right _ -> return (mx1, w1 <+> w2') Left ex1 -> do- (mx2, w2) <- c2 -< x'- returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)+ (mx2, w2) <- c2 x'+ return (mapLeft (mappend ex1) mx2, w1 <+> w2) - WPure f <+> w2'@(WPure g) =- WPure $ \x' ->+ WmPure f <+> w2'@(WmPure g) =+ WmPure $ \x' -> let (mx1, w1) = f x' (mx2, w2) = g x' in case mx1 of@@ -300,116 +321,191 @@ -- | If the underlying arrow is a reader arrow, then the wire arrow is -- also a reader arrow. -instance (ArrowChoice (>~), ArrowReader r (>~)) => ArrowReader r (Wire e (>~)) where- readState = lift readState+instance MonadReader r m => ArrowReader r (Wire e (Kleisli m)) where+ readState = mkFixM (const (liftM Right ask)) - newReader (WPure f) = WPure (second newReader . f . fst)- newReader (WGen c) = WGen $ arr (second newReader) . newReader c+ newReader (WmPure f) = WmPure (second newReader . f . fst)+ newReader (WmGen c) =+ WmGen $ \(x', env) ->+ liftM (second newReader) (local (const env) (c x')) -- | If the underlying arrow is a state arrow, then the wire arrow is -- also a state arrow. -instance (ArrowChoice (>~), ArrowState s (>~)) => ArrowState s (Wire e (>~)) where- fetch = lift fetch- store = lift store+instance MonadState s m => ArrowState s (Wire e (Kleisli m)) where+ fetch = mkFixM (const (liftM Right get))+ store = mkFixM (liftM Right . put) -- | Wire arrows are arrow transformers. -instance ArrowChoice (>~) => ArrowTransformer (Wire e) (>~) where- lift c = mkFix $ Right ^<< c+instance Monad m => ArrowTransformer (Wire e) (Kleisli m) where+ lift (Kleisli f) = mkFixM (liftM Right . f) -- | If the underlying arrow is a writer arrow, then the wire arrow is -- also a writer arrow. -instance (ArrowChoice (>~), ArrowWriter w (>~)) => ArrowWriter w (Wire e (>~)) where- write = lift write+instance MonadWriter w m => ArrowWriter w (Wire e (Kleisli m)) where+ write = mkFixM (liftM Right . tell) - newWriter (WPure f) = WPure ((fmap (, mempty) *** newWriter) . f)- newWriter (WGen c) =- WGen $ arr (\((mx, w), log) ->- (fmap (, log) mx, newWriter w)) .- newWriter c+ newWriter (WmPure f) = WmPure ((fmap (, mempty) *** newWriter) . f)+ newWriter (WmGen c) =+ WmGen $ \x' -> do+ ((mx, w), log) <- listen (c x')+ return (fmap (, log) mx, newWriter w) -- | The always inhibiting wire. The @zeroArrow@ is equivalent to -- "Control.Wire.Prefab.Event.never". -instance (ArrowChoice (>~), Monoid e) => ArrowZero (Wire e (>~)) where+instance (Monad m, Monoid e) => ArrowZero (Wire e (Kleisli m)) where zeroArrow = mkPureFix (const $ Left mempty) -- | Sequencing of wires. -instance ArrowChoice (>~) => Category (Wire e (>~)) where- id = arr id+instance Monad m => Category (Wire e (Kleisli m)) where+ id = WmPure $ \x -> (Right x, id) - w2'@(WGen c2) . WGen c1 =- WGen $ proc x'' -> do- (mx', w1) <- c1 -< x''+ w2'@(WmGen c2) . WmGen c1 =+ WmGen $ \x'' -> do+ (mx', w1) <- c1 x'' case mx' of- Left ex -> returnA -< (Left ex, w2' . w1)+ Left ex -> return (Left ex, w2' . w1) Right x' -> do- (mx, w2) <- c2 -< x'- returnA -< (mx, w2 . w1)+ (mx, w2) <- c2 x'+ return (mx, w2 . w1) - w2'@(WGen c2) . WPure g =- WGen $ proc (g -> (mx', w1)) -> do+ w2'@(WmGen c2) . WmPure g =+ WmGen $ \(g -> (mx', w1)) -> do case mx' of- Left ex -> returnA -< (Left ex, w2' . w1)+ Left ex -> return (Left ex, w2' . w1) Right x' -> do- (mx, w2) <- c2 -< x'- returnA -< (mx, w2 . w1)+ (mx, w2) <- c2 x'+ return (mx, w2 . w1) - w2'@(WPure f) . WGen c1 =- WGen $ proc x'' -> do- (mx', w1) <- c1 -< x''- case mx' of- Left ex -> returnA -< (Left ex, w2' . w1)- Right (f -> (mx, w2)) -> returnA -< (mx, w2 . w1)+ w2'@(WmPure f) . WmGen c1 =+ WmGen $ \x'' -> do+ (mx', w1) <- c1 x''+ return $+ case mx' of+ Left ex -> (Left ex, w2' . w1)+ Right (f -> (mx, w2)) -> (mx, w2 . w1) - w2'@(WPure f) . WPure g =- WPure $ \(g -> (mx', w1)) ->+ w2'@(WmPure f) . WmPure g =+ WmPure $ \(g -> (mx', w1)) -> case mx' of Left ex -> (Left ex, w2' . w1) Right (f -> (mx, w2)) -> (mx, w2 . w1) --- | Maps over the left side of an 'Either' value.+-- | Map a function over the output signal. -mapLeft :: (e' -> e) -> Either e' a -> Either e a-mapLeft f (Left x) = Left (f x)-mapLeft _ (Right x) = Right x+instance Monad m => Functor (Wire e (Kleisli m) a) where+ fmap f (WmGen g) = WmGen (liftM (fmap f *** fmap f) . g)+ fmap f (WmPure g) = WmPure ((fmap f *** fmap f) . g) --- | Create a wire from the given stateless transformation computation.+-- | Choice at the functor level. -mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b-mkFix c = let w = WGen (arr (, w) . c) in w+instance (Monad m, Monoid e) => Alternative (Wire e (Kleisli m) a) where+ empty = zeroArrow+ (<|>) = (<+>) +-- | Map a function signal over the output signal.++instance Monad m => Applicative (Wire e (Kleisli m) a) where+ pure = mkPureFix . const . Right+ wf <*> wx = uncurry ($) ^<< (wf *** wx) <<^ dup++ -- | Create a wire from the given transformation computation. -mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b-mkGen = WGen+class Arrow (>~) => WireGen (>~) where+ -- | Stateful variant.+ mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b + -- | Stateless variant.+ mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b+ mkFix c = let w = mkGen (arr (, w) . c) in w --- | Create a pure wire from the given transformation function.+instance Monad m => WireGen (Kleisli m) where+ mkGen (Kleisli c) = WmGen c+ mkFix (Kleisli c) = let w = WmGen (liftM (, w) . c) in w -mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b-mkPure = WPure +-- | Monad-based wires. +type WireM e m = Wire e (Kleisli m)++ -- | Create a pure wire from the given transformation function. -mkPureFix :: (a -> Either e b) -> Wire e (>~) a b-mkPureFix f = let w = WPure ((, w) . f) in w+class Arrow (>~) => WirePure (>~) where+ -- | Stateful variant.+ mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b + -- | Stateless variant.+ mkPureFix :: (a -> Either e b) -> Wire e (>~) a b+ mkPureFix f = let w = mkPure (\x -> (f x, w)) in w +instance Monad m => WirePure (Kleisli m) where+ mkPure = WmPure++ -- | Convert the given wire to a generic arrow computation. -toGen :: Arrow (>~) => Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))-toGen (WGen c) = c-toGen (WPure f) = arr f+class WireToGen (>~) where+ toGen :: Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))++instance Monad m => WireToGen (Kleisli m) where+ toGen = Kleisli . toGenM+++-- | Turn an arbitrary exception to a wire exception.++inhibitException :: Ex.Exception e => e -> LastException+inhibitException = Last . Just . Ex.toException+++-- | Turn a string into a 'userError' exception wrapped by+-- 'LastException'.++inhibitMsg :: String -> LastException+inhibitMsg = inhibitException . userError+++-- | Map a function over the input.++mapInputM :: Monad m => (a' -> a) -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) a' b+mapInputM f (WmPure g) = WmPure (second (mapInputM f) . g . f)+mapInputM f (WmGen g) = WmGen (liftM (second (mapInputM f)) . g . f)+++-- | Map a function over the 'Left' value of an 'Either'.++mapLeft :: (e' -> e) -> Either e' b -> Either e b+mapLeft f = either (Left . f) Right+++-- | Create a stateless wire from the given monadic computation.++mkFixM ::+ Monad m+ => (a -> m (Either e b))+ -> Wire e (Kleisli m) a b+mkFixM f = let w = WmGen (liftM (, w) . f) in w+++-- | Convert the given wire to a generic monadic computation.++toGenM ::+ Monad m+ => Wire e (Kleisli m) a b -- ^ Wire to convert.+ -> a -- ^ Input value.+ -> m (Either e b, Wire e (Kleisli m) a b)+toGenM (WmGen c) = c+toGenM (WmPure f) = (return . f)
netwire.cabal view
@@ -1,7 +1,7 @@ Name: netwire-Version: 2.0.1+Version: 3.0.0 Category: Control, FRP-Synopsis: Generic automaton arrow transformer and useful tools+Synopsis: Fast generic automaton arrow transformer for AFRP Maintainer: Ertugrul Söylemez <es@ertes.de> Author: Ertugrul Söylemez <es@ertes.de> Copyright: (c) 2011 Ertugrul Söylemez@@ -11,8 +11,9 @@ Stability: experimental Cabal-version: >= 1.8 Description:- This library implements a powerful generic automaton arrow- transformer.+ This library implements a fast and powerful generic automaton arrow+ transformer for arrowized functional reactive programming or+ automaton programming in general. Library Build-depends:@@ -20,16 +21,23 @@ base >= 4 && < 5, containers >= 0.4.0, deepseq >= 1.1.0,+ forkable-monad >= 0.1.1,+ monad-control >= 0.2.0,+ MonadRandom >= 0.1.6, random >= 1.0.0, time >= 1.2.0,- transformers >= 0.2.2,+ mtl >= 2.0.1,+ stm >= 2.2.0, vector >= 0.9, vector-space >= 0.7.8 Extensions: Arrows+ FlexibleContexts FlexibleInstances+ FunctionalDependencies GADTs MultiParamTypeClasses+ RankNTypes ScopedTypeVariables TupleSections TypeFamilies@@ -47,16 +55,21 @@ Control.Wire.Prefab.Calculus Control.Wire.Prefab.Clock Control.Wire.Prefab.Event+ Control.Wire.Prefab.Execute Control.Wire.Prefab.Queue Control.Wire.Prefab.Random Control.Wire.Prefab.Sample Control.Wire.Prefab.Simple Control.Wire.Prefab.Split Control.Wire.Session+ Control.Wire.TimedMap Control.Wire.Tools Control.Wire.Trans+ Control.Wire.Trans.Clock Control.Wire.Trans.Combine Control.Wire.Trans.Exhibit+ Control.Wire.Trans.Fork+ Control.Wire.Trans.Memoize Control.Wire.Trans.Sample Control.Wire.Trans.Simple Control.Wire.Types@@ -66,13 +79,20 @@ -- arrows, -- base >= 4 && < 5, -- containers,+-- logict,+-- MonadRandom,+-- mtl, -- netwire,--- transformers+-- random,+-- time -- Extensions: -- Arrows+-- FlexibleInstances+-- MultiParamTypeClasses+-- ScopedTypeVariables -- TupleSections -- TypeFamilies -- ViewPatterns -- Hs-source-dirs: test -- Main-is: Main.hs--- GHC-Options: -W -threaded -rtsopts+-- GHC-Options: -threaded -rtsopts