packages feed

netwire 1.0.0 → 1.1.0

raw patch · 14 files changed

+475/−282 lines, 14 filesdep +monad-controldep +randomdep +transformers

Dependencies added: monad-control, random, transformers

Files

FRP/NetWire.hs view
@@ -10,7 +10,7 @@  module FRP.NetWire     ( -- * Wires-      Wire, Time, DTime, Event,+      Wire, Event, Output, Time,        -- * Reactive sessions       Session,@@ -19,24 +19,34 @@       stepWireTime,       withWire, -      -- * Reexports+      -- * Pure wires+      SF,+      stepSF,+      stepWirePure,++      -- * Netwire Reexports       module FRP.NetWire.Analyze,       module FRP.NetWire.Calculus,-      -- module FRP.NetWire.Concurrent,+      module FRP.NetWire.Concurrent,       module FRP.NetWire.Event,       module FRP.NetWire.IO,       module FRP.NetWire.Random,       module FRP.NetWire.Request,       module FRP.NetWire.Switch,-      module FRP.NetWire.Tools+      module FRP.NetWire.Tools,++      -- * Other convenience reexports+      module Data.Functor.Identity     )     where +import Data.Functor.Identity import FRP.NetWire.Analyze import FRP.NetWire.Calculus--- import FRP.NetWire.Concurrent+import FRP.NetWire.Concurrent import FRP.NetWire.Event import FRP.NetWire.IO+import FRP.NetWire.Pure import FRP.NetWire.Random import FRP.NetWire.Request import FRP.NetWire.Session
FRP/NetWire/Analyze.hs view
@@ -23,9 +23,10 @@     )     where -import qualified Data.Vector.Unboxed.Mutable as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM import Control.DeepSeq-import Data.Vector.Unboxed.Mutable (IOVector, Unbox)+import Control.Monad.ST import FRP.NetWire.Wire  @@ -36,21 +37,21 @@ -- If you need an average over all samples ever produced, consider using -- 'avgAll' instead. -avg :: forall v. (Fractional v, NFData v, Unbox v) => Int -> Wire v v-avg n =-    mkGen $ \_ x -> do-        samples <- V.replicate n (x/d)-        return (Just x, avg' samples x 0)-+avg :: forall m v. (Fractional v, Monad m, NFData v, U.Unbox v) => Int -> Wire m v v+avg n = mkGen $ \_ x -> return (Right x, avg' (U.replicate n (x/d)) x 0)     where-    avg' :: IOVector v -> v -> Int -> Wire v v-    avg' samples s' cur' =+    avg' :: U.Vector v -> v -> Int -> Wire m v v+    avg' samples' s' cur' =         mkGen $ \_ ((/d) -> x) -> do             let cur = let cur = succ cur' in if cur >= n then 0 else cur-            x' <- V.read samples cur-            V.write samples cur x+                x' = samples' U.! cur+                samples =+                    x' `seq` runST $ do+                        s <- U.unsafeThaw samples'+                        UM.write s cur x+                        U.unsafeFreeze s             let s = s' - x' + x-            s `deepseq` return (Just s, avg' samples s cur)+            s `deepseq` return (Right s, avg' samples s cur)      d :: v     d = realToFrac n@@ -62,15 +63,15 @@ -- space and is generally faster than 'avg', but most applications will -- benefit from averages over only the last few samples. -avgAll :: forall v. (Fractional v, NFData v) => Wire v v-avgAll = mkGen $ \_ x -> return (Just x, avgAll' 1 x)+avgAll :: forall m v. (Fractional v, Monad m, NFData v) => Wire m v v+avgAll = mkGen $ \_ x -> return (Right x, avgAll' 1 x)     where-    avgAll' :: v -> v -> Wire v v+    avgAll' :: v -> v -> Wire m v v     avgAll' n' a' =         mkGen $ \_ x ->             let n = n' + 1                 a = a' - a'/n + x/n in-            n `deepseq` a `deepseq` return (Just a, avgAll' n a)+            n `deepseq` a `deepseq` return (Right a, avgAll' n a)   -- | Calculate the average number of frames per virtual second for the@@ -81,10 +82,10 @@ -- doesn't represent real time, then the output of this wire won't -- either. -avgFps :: forall a. Int -> Wire a Double+avgFps :: forall a m. Monad m => Int -> Wire m a Double avgFps = avgFps' . avg     where-    avgFps' :: Wire Double Double -> Wire a Double+    avgFps' :: Wire m Double Double -> Wire m a Double     avgFps' w' =         mkGen $ \ws@(wsDTime -> dt) _ -> do             (ma, w) <- toGen w' ws dt@@ -95,40 +96,40 @@ -- contains the last input value and the time elapsed since the last -- change. -diff :: forall a. Eq a => Wire a (Event (a, Time))+diff :: forall a m. (Eq a, Monad m) => Wire m a (Event (a, Time)) diff =     mkGen $ \(wsDTime -> dt) x' ->-        return (Just Nothing, diff' dt x')+        return (Right Nothing, diff' dt x')      where-    diff' :: Time -> a -> Wire a (Event (a, Time))+    diff' :: Time -> a -> Wire m a (Event (a, Time))     diff' t' x' =         mkGen $ \(wsDTime -> dt) x ->             let t = t' + dt in             if x' == x-              then return (Just Nothing, diff' t x')-              else return (Just (Just (x', t)), diff' 0 x)+              then return (Right Nothing, diff' t x')+              else return (Right (Just (x', t)), diff' 0 x)  --- | Returh the high peak.+-- | Return the high peak. -highPeak :: (NFData a, Ord a) => Wire a a+highPeak :: (Monad m, NFData a, Ord a) => Wire m a a highPeak = peakBy compare   -- | Return the low peak. -lowPeak :: (NFData a, Ord a) => Wire a a+lowPeak :: (Monad m, NFData a, Ord a) => Wire m a a lowPeak = peakBy (flip compare)   -- | Return the high peak with the given comparison function. -peakBy :: forall a. NFData a => (a -> a -> Ordering) -> Wire a a-peakBy comp = mkGen $ \_ x -> return (Just x, peakBy' x)+peakBy :: forall a m. (Monad m, NFData a) => (a -> a -> Ordering) -> Wire m a a+peakBy comp = mkGen $ \_ x -> return (Right x, peakBy' x)     where-    peakBy' :: a -> Wire a a+    peakBy' :: a -> Wire m a a     peakBy' p' =         mkGen $ \_ x -> do             let p = if comp x p' == GT then x else p'-            p `deepseq` return (Just p, peakBy' p)+            p `deepseq` return (Right p, peakBy' p)
FRP/NetWire/Calculus.hs view
@@ -21,25 +21,28 @@  -- | Differentiate over time.  Inhibits at first instant. -derivative :: (NFData v, VectorSpace v, Scalar v ~ Double) => Wire v v-derivative = mkGen $ \_ y2 -> return (Nothing, derivativeFrom y2)+derivative :: (Monad m, NFData v, VectorSpace v, Scalar v ~ Double) => Wire m v v+derivative =+    mkGen $ \_ y2 ->+        return (Left (inhibitEx "Derivative at first instant"),+                derivativeFrom y2)   -- | Differentiate over time.  The argument is the value before the -- first instant. -derivativeFrom :: (NFData v, VectorSpace v, Scalar v ~ Double) => v -> Wire v v+derivativeFrom :: (Monad m, NFData v, VectorSpace v, Scalar v ~ Double) => v -> Wire m v v derivativeFrom y1 =     mkGen $ \(wsDTime -> dt) y2 -> do         let dy = (y2 ^-^ y1) ^/ dt-        dy `deepseq` return (Just dy, derivativeFrom y2)+        dy `deepseq` return (Right dy, derivativeFrom y2)   -- | Integrate over time.  The argument is the integration constant. -integral :: (NFData v, VectorSpace v, Scalar v ~ Double) => v -> Wire v v+integral :: (Monad m, NFData v, VectorSpace v, Scalar v ~ Double) => v -> Wire m v v integral x1 =     mkGen $ \ws dx -> do         let dt = wsDTime ws             x2 = x1 ^+^ dt *^ dx-        x2 `deepseq` return (Just x2, integral x2)+        x2 `deepseq` return (Right x2, integral x2)
+ FRP/NetWire/Concurrent.hs view
@@ -0,0 +1,91 @@+-- |+-- Module:     FRP.NetWire.Concurrent+-- Copyright:  (c) 2011 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Wire concurrency.  Send signals through multiple wires concurrently.+-- This module is *highly experimental* and subject to change entirely+-- in future revisions.  Please use it with care.++module FRP.NetWire.Concurrent+    ( -- * Combining wires+      (~*~),+      (~&~),+      (~+~)+    )+    where++import Control.Applicative+import Control.Arrow+import Control.Concurrent+import Control.Concurrent.STM+import Control.DeepSeq+import FRP.NetWire.Tools+import FRP.NetWire.Wire+++-- | Concurrent version of '(***)'.  Passes its input signals to both+-- argument wires concurrently.++(~*~) :: Wire IO a c -> Wire IO b d -> Wire IO (a, b) (c, d)+w1' ~*~ w2' =+    mkGen $ \ws (x', y') -> do+        (xVar, thr1) <- forkWire w1' ws x'+        (yVar, thr2) <- forkWire w2' ws y'+        (mx, w1) <- takeMVar xVar+        (my, w2) <- takeMVar yVar+        mapM_ killThread [thr1, thr2]+        return (liftA2 (,) mx my, w1 ~*~ w2)++infixr 3 ~*~+++-- | Concurrent version of '(&&&)'.  Passes its input signal to both+-- argument wires concurrently.++(~&~) :: Wire IO a b -> Wire IO a c -> Wire IO a (b, c)+w1' ~&~ w2' = arr dup >>> w1' ~*~ w2'++infixr 3 ~&~+++-- | Concurrent version of '(<+>)'.  Passes its input signal to both+-- argument wires concurrently, returning the result of the first wire+-- which does not inhibit.++(~+~) :: NFData b => Wire IO a b -> Wire IO a b -> Wire IO a b+w1' ~+~ w2' =+    mkGen $ \ws x' -> do+        x1Var <- newEmptyTMVarIO+        x2Var <- newEmptyTMVarIO+        thr1 <- forkIO (toGen w1' ws x' >>= atomically . putTMVar x1Var)+        thr2 <- forkIO (toGen w2' ws x' >>= atomically . putTMVar x2Var)+        let res1 = do (mx, w1) <- takeTMVar x1Var; check (isRight mx); return (mx, w1 ~+~ w2')+            res2 = do (mx, w2) <- takeTMVar x2Var; check (isRight mx); return (mx, w1' ~+~ w2)+            noRes = do (mx1, w1) <- takeTMVar x1Var+                       (mx2, w2) <- takeTMVar x2Var+                       check (isLeft mx1 && isLeft mx2)+                       return (mx2, w1 ~+~ w2)+        atomically (res1 <|> res2 <|> noRes) <* mapM_ killThread [thr1, thr2]+++-- | Pass the given input to the given wire concurrently.++forkWire :: Wire IO a b -> WireState IO -> a -> IO (MVar (Output b, Wire IO a b), ThreadId)+forkWire w' ws x' = do+    resultVar <- newEmptyMVar+    thr <- forkIO (toGen w' ws x' >>= putMVar resultVar)+    return (resultVar, thr)+++-- | Is this a left value?++isLeft :: Either e a -> Bool+isLeft = either (const True) (const False)+++-- | Is this a right value?++isRight :: Either e a -> Bool+isRight = either (const False) (const True)
FRP/NetWire/Event.hs view
@@ -54,27 +54,27 @@ -- an input event is received, its function is applied to the current -- accumulator and the new value is emitted. -accum :: forall a. a -> Wire (Event (a -> a)) (Event a)+accum :: forall a m. Monad m => a -> Wire m (Event (a -> a)) (Event a) accum ee' = accum'     where-    accum' :: Wire (Event (a -> a)) (Event a)+    accum' :: Wire m (Event (a -> a)) (Event a)     accum' =         mkGen $ \_ ->             return .-            maybe (Nothing, accum')-                  (\f -> let ee = f ee' in ee `seq` (Just (Just ee), accum ee))+            maybe (Right Nothing, accum')+                  (\f -> let ee = f ee' in ee `seq` (Right (Just ee), accum ee))   -- | Produce an event once after the specified delay and never again. -- The event's value will be the input signal at that point. -after :: forall a. DTime -> Wire a (Event a)+after :: Monad m => Time -> Wire m a (Event a) after t' =     mkGen $ \(wsDTime -> dt) x ->         let t = t' - dt in         if t <= 0-          then return (Just (Just x), never)-          else return (Nothing, after t)+          then return (Right (Just x), never)+          else return (Right Nothing, after t)   -- | Produce an event according to the given list of time deltas and@@ -83,18 +83,18 @@ -- produces the event @'a'@ after one second, @'b'@ after three seconds -- and @'c'@ after six seconds. -afterEach :: forall a b. [(DTime, b)] -> Wire a (Event b)+afterEach :: forall a b m. Monad m => [(Time, b)] -> Wire m a (Event b) afterEach = afterEach' 0     where-    afterEach' :: DTime -> [(DTime, b)] -> Wire a (Event b)+    afterEach' :: Time -> [(Time, b)] -> Wire m a (Event b)     afterEach' _ [] = never     afterEach' t' d@((int, x):ds) =         mkGen $ \(wsDTime -> dt) _ ->             let t = t' + dt in             if t >= int               then let nextT = t - int-                   in nextT `seq` return (Just (Just x), afterEach' (t - int) ds)-              else return (Just Nothing, afterEach' t d)+                   in nextT `seq` return (Right (Just x), afterEach' (t - int) ds)+              else return (Right Nothing, afterEach' t d)   -- | Event dam.  Collects all values from the input list and emits one@@ -103,15 +103,15 @@ -- Note that this combinator can cause event congestion.  If you feed -- values faster than it can produce, it will leak memory. -dam :: forall a. Wire [a] (Event a)+dam :: forall a m. Monad m => Wire m [a] (Event a) dam = dam' []     where-    dam' :: [a] -> Wire [a] (Event a)+    dam' :: [a] -> Wire m [a] (Event a)     dam' xs =         mkGen $ \_ ys ->             case xs ++ ys of-              []        -> return (Just Nothing, dam' [])-              (ee:rest) -> return (Just (Just ee), dam' rest)+              []        -> return (Right Nothing, dam' [])+              (ee:rest) -> return (Right (Just ee), dam' rest)   -- | Delay events by the time interval in the left signal.@@ -122,19 +122,19 @@ -- starts to drop), it will leak memory.  Use 'delayEventSafe' to -- prevent this. -delayEvents :: Wire (DTime, Event a) (Event a)+delayEvents :: forall a m. Monad m => Wire m (Time, Event a) (Event a) delayEvents = delayEvent' Seq.empty 0     where-    delayEvent' :: Seq (DTime, a) -> Time -> Wire (DTime, Event a) (Event a)+    delayEvent' :: Seq (Time, a) -> Time -> Wire m (Time, Event a) (Event a)     delayEvent' es' t' =         mkGen $ \(wsDTime -> dt) (int, ev) -> do             let t = t' + dt                 es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev             case Seq.viewl es of-              Seq.EmptyL -> return (Nothing, delayEvent' es 0)+              Seq.EmptyL -> return (Right Nothing, delayEvent' es 0)               (et, ee) :< rest-                  | t >= et   -> return (Just (Just ee), delayEvent' rest t)-                  | otherwise -> return (Just Nothing, delayEvent' es t)+                  | t >= et   -> return (Right (Just ee), delayEvent' rest t)+                  | otherwise -> return (Right Nothing, delayEvent' es t)   -- | Delay events by the time interval in the left signal.  The event@@ -146,66 +146,66 @@ -- However, if it's decreased below the number of currently queued -- events, the events are not deleted. -delayEventsSafe :: Wire (DTime, Int, Event a) (Event a)+delayEventsSafe :: forall a m. Monad m => Wire m (Time, Int, Event a) (Event a) delayEventsSafe = delayEventSafe' Seq.empty 0     where-    delayEventSafe' :: Seq (DTime, a) -> Time -> Wire (DTime, Int, Event a) (Event a)+    delayEventSafe' :: Seq (Time, a) -> Time -> Wire m (Time, Int, Event a) (Event a)     delayEventSafe' es' t' =         mkGen $ \(wsDTime -> dt) (int, maxEvs, ev') -> do             let t = t' + dt                 ev = guard (Seq.length es' < maxEvs) >> ev'                 es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev             case Seq.viewl es of-              Seq.EmptyL -> return (Nothing, delayEventSafe' es 0)+              Seq.EmptyL -> return (Right Nothing, delayEventSafe' es 0)               (et, ee) :< rest-                  | t >= et   -> return (Just (Just ee), delayEventSafe' rest t)-                  | otherwise -> return (Just Nothing, delayEventSafe' es t)+                  | t >= et   -> return (Right (Just ee), delayEventSafe' rest t)+                  | otherwise -> return (Right Nothing, delayEventSafe' es t)   -- | Decoupled variant of 'hold'. -dHold :: forall a. a -> Wire (Event a) a+dHold :: forall a m. Monad m => a -> Wire m (Event a) a dHold x0 = dHold'     where-    dHold' :: Wire (Event a) a+    dHold' :: Wire m (Event a) a     dHold' =         mkGen $ \_ ->-            return . maybe (Just x0, dHold') (\x1 -> (Just x0, dHold x1))+            return . maybe (Right x0, dHold') (\x1 -> (Right x0, dHold x1))   -- | Drop the given number of events, before passing events through. -dropEvents :: forall a. Int -> Wire (Event a) (Event a)+dropEvents :: forall a m. Monad m => Int -> Wire m (Event a) (Event a) dropEvents 0 = identity dropEvents n = drop'     where-    drop' :: Wire (Event a) (Event a)+    drop' :: Wire m (Event a) (Event a)     drop' =         mkGen $ \_ ->             return .-            maybe (Nothing, drop')-                  (const (Nothing, dropEvents (pred n)))+            maybe (Right Nothing, drop')+                  (const (Right Nothing, dropEvents (pred n)))   -- | Timed event gate for the right signal, which begins closed and -- opens after the time interval in the left signal has passed. -dropFor :: forall a. Wire (DTime, Event a) (Event a)+dropFor :: forall a m. Monad m => Wire m (Time, Event a) (Event a) dropFor = dropFor' 0     where-    dropFor' :: Time -> Wire (DTime, Event a) (Event a)+    dropFor' :: Time -> Wire m (Time, Event a) (Event a)     dropFor' t' =         mkGen $ \(wsDTime -> dt) (int, ev) ->             let t = t' + dt in             if t >= int-              then return (Just ev, arr snd)-              else return (Just Nothing, dropFor' t)+              then return (Right ev, arr snd)+              else return (Right Nothing, dropFor' t)   -- | Produce a single event with the right signal whenever the left -- signal switches from 'False' to 'True'. -edge :: Wire (Bool, a) (Event a)+edge :: Monad m => Wire m (Bool, a) (Event a) edge = edgeBy fst snd  @@ -213,28 +213,26 @@ -- to 'True' for the input signal, produce an event carrying the value -- given by applying the second argument function to the input signal. -edgeBy :: forall a b. (a -> Bool) -> (a -> b) -> Wire a (Event b)+edgeBy :: forall a b m. Monad m => (a -> Bool) -> (a -> b) -> Wire m a (Event b) edgeBy p f = edgeBy'     where-    edgeBy' :: Wire a (Event b)+    edgeBy' :: Wire m a (Event b)     edgeBy' =         mkGen $ \_ subject ->             if p subject-              then return (Just (Just (f subject)), switchBack)-              else return (Just Nothing, edgeBy')+              then return (Right (Just (f subject)), switchBack)+              else return (Right Nothing, edgeBy') -    switchBack :: Wire a (Event b)+    switchBack :: Wire m a (Event b)     switchBack =         mkGen $ \_ subject ->-            if p subject-              then return (Just Nothing, switchBack)-              else return (Just Nothing, edgeBy')+            return (Right Nothing, if p subject then switchBack else edgeBy')   -- | Produce a single event carrying the value of the input signal, -- whenever the input signal switches to 'Just'. -edgeJust :: Wire (Maybe a) (Event a)+edgeJust :: Monad m => Wire m (Maybe a) (Event a) edgeJust = edgeBy isJust fromJust  @@ -242,114 +240,114 @@ -- the argument value.  Each time an event occurs, the produced value is -- switched to the event's value. -hold :: forall a. a -> Wire (Event a) a+hold :: forall a m. Monad m => a -> Wire m (Event a) a hold x0 = hold'     where-    hold' :: Wire (Event a) a+    hold' :: Wire m (Event a) a     hold' =         mkGen $ \_ ->             return .-            maybe (Just x0, hold')-                  (\x -> (Just x, hold x))+            maybe (Right x0, hold')+                  (Right &&& hold)   -- | Never produce an event. -never :: Wire a (Event b)+never :: Monad m => Wire m a (Event b) never = constant Nothing   -- | Suppress the first event occurence. -notYet :: Wire (Event a) (Event a)-notYet = mkGen $ \_ -> return . maybe (Just Nothing, notYet) (const (Just Nothing, identity))+notYet :: Monad m => Wire m (Event a) (Event a)+notYet = mkGen $ \_ -> return . maybe (Right Nothing, notYet) (const (Right Nothing, identity))   -- | Produce an event at the first instant and never again. -now :: b -> Wire a (Event b)+now :: Monad m => b -> Wire m a (Event b) now x = constantAfter Nothing (Just x)   -- | Pass the first event occurence through and suppress all future -- events. -once :: Wire (Event a) (Event a)+once :: Monad m => Wire m (Event a) (Event a) once =     mkGen $ \_ ev ->         case ev of-          Nothing -> return (Just Nothing, once)-          Just _  -> return (Just ev, constant Nothing)+          Nothing -> return (Right Nothing, once)+          Just _  -> return (Right ev, constant Nothing)   -- | Emit the right signal event each time the left signal interval -- passes. -repeatedly :: forall a. Wire (DTime, a) (Event a)+repeatedly :: forall a m. Monad m => Wire m (Time, a) (Event a) repeatedly = repeatedly' 0     where-    repeatedly' :: Time -> Wire (DTime, a) (Event a)+    repeatedly' :: Time -> Wire m (Time, a) (Event a)     repeatedly' t' =         mkGen $ \(wsDTime -> dt) (int, x) ->             let t = t' + dt in             if t >= int               then let nextT = fmod t int-                   in nextT `seq` return (Just (Just x), repeatedly' nextT)-              else return (Just Nothing, repeatedly' t)+                   in nextT `seq` return (Right (Just x), repeatedly' nextT)+              else return (Right Nothing, repeatedly' t)   -- | Each time the signal interval passes emit the next element from the -- given list. -repeatedlyList :: forall a. [a] -> Wire DTime (Event a)+repeatedlyList :: forall a m. Monad m => [a] -> Wire m Time (Event a) repeatedlyList = repeatedly' 0     where-    repeatedly' :: DTime -> [a] -> Wire DTime (Event a)+    repeatedly' :: Time -> [a] -> Wire m Time (Event a)     repeatedly' _ [] = constant Nothing     repeatedly' t' x@(x0:xs) =         mkGen $ \(wsDTime -> dt) int ->             let t = t' + dt in             if t >= int               then let nextT = fmod t int-                   in nextT `seq` return (Just (Just x0), repeatedly' nextT xs)-              else return (Just Nothing, repeatedly' t x)+                   in nextT `seq` return (Right (Just x0), repeatedly' nextT xs)+              else return (Right Nothing, repeatedly' t x)   -- | Pass only the first given number of events.  Then suppress events -- forever. -takeEvents :: Int -> Wire (Event a) (Event a)+takeEvents :: forall a m. Monad m => Int -> Wire m (Event a) (Event a) takeEvents 0 = constant Nothing takeEvents n = take'     where-    take' :: Wire (Event a) (Event a)+    take' :: Wire m (Event a) (Event a)     take' =         mkGen $ \_ ev ->             case ev of-              Nothing -> return (Just Nothing, take')-              Just _  -> return (Just ev, takeEvents (pred n))+              Nothing -> return (Right Nothing, take')+              Just _  -> return (Right ev, takeEvents (pred n))   -- | Timed event gate for the right signal, which starts open and slams -- shut after the left signal time interval passed. -takeFor :: Wire (DTime, Event a) (Event a)+takeFor :: forall a m. Monad m => Wire m (Time, Event a) (Event a) takeFor = takeFor' 0     where-    takeFor' :: Time -> Wire (DTime, Event a) (Event a)+    takeFor' :: Time -> Wire m (Time, Event a) (Event a)     takeFor' t' =         mkGen $ \(wsDTime -> dt) (int, ev) ->             let t = t' + dt in             if t >= int-              then return (Just Nothing, constant Nothing)-              else return (Just ev, takeFor' t)+              then return (Right Nothing, constant Nothing)+              else return (Right ev, takeFor' t)   -- | Inhibit the signal, unless an event occurs. -wait :: Wire (Event a) a+wait :: Monad m => Wire m (Event a) a wait =     mkGen $ \_ ev ->         case ev of-          Nothing -> return (Nothing, wait)-          Just _  -> return (ev, wait)+          Nothing -> return (Left (inhibitEx "Waiting for event"), wait)+          Just ee -> return (Right ee, wait)
FRP/NetWire/IO.hs view
@@ -14,7 +14,9 @@     )     where -import Control.Exception+import Control.Exception.Control+import Control.Monad+import Control.Monad.IO.Control import FRP.NetWire.Tools import FRP.NetWire.Wire @@ -24,22 +26,18 @@ -- Note: If the action throws an exception, then this wire inhibits the -- signal. -execute :: Wire (IO a) a+execute :: MonadControlIO m => Wire m (m a) a execute =-    mkGen $ \_ c -> do-        mx <- try c-        case mx of-          Left (_ :: SomeException) -> return (Nothing, execute)-          Right x                   -> return (Just x, execute)+    mkGen $ \_ c -> liftM (, execute) (try c)   -- | Executes the IO action in the right input signal periodically -- keeping its most recent result value. -executeEvery :: forall a. Wire (DTime, IO a) a-executeEvery = executeEvery' True 0 Nothing+executeEvery :: forall a m. MonadControlIO m => Wire m (Time, m a) a+executeEvery = executeEvery' True 0 (Left (inhibitEx "No result yet."))     where-    executeEvery' :: Bool -> Time -> Maybe a -> Wire (DTime, IO a) a+    executeEvery' :: Bool -> Time -> Output a -> Wire m (Time, m a) a     executeEvery' firstRun t' mx' =         mkGen $ \(wsDTime -> dt) (int, c) ->             let t = t' + dt in@@ -48,20 +46,16 @@                   let nextT = fmod t int                   mx <- nextT `seq` try c                   case mx of-                    Left (_ :: SomeException) -> return (mx', executeEvery' False nextT mx')-                    Right x ->-                        let mx = Just x-                        in mx `seq` return (mx, executeEvery' False nextT mx)+                    Left _  -> return (mx', executeEvery' False nextT mx')+                    Right _ -> return (mx, executeEvery' False nextT mx)               else return (mx', executeEvery' False t mx')   -- | Executes the IO action in the input signal and inhibits, until it -- succeeds without an exception.  Keeps the result forever. -executeOnce :: Wire (IO a) a+executeOnce :: MonadControlIO m => Wire m (m a) a executeOnce =     mkGen $ \_ c -> do         mx <- try c-        case mx of-          Left (_ :: SomeException) -> return (Nothing, executeOnce)-          Right x                   -> return (Just x, constant x)+        return (mx, either (const executeOnce) constant mx)
+ FRP/NetWire/Pure.hs view
@@ -0,0 +1,29 @@+-- |+-- Module:     FRP.NetWire.Pure+-- Copyright:  (c) 2011 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+--+-- Pure wire sessions.++module FRP.NetWire.Pure+    ( -- * Pure sessions+      stepSF,+      stepWirePure+    )+    where++import Data.Functor.Identity+import FRP.NetWire.Wire+++-- | Perform the next instant of a pure wire over the identity monad.++stepSF :: Time -> a -> SF a b -> (Output b, SF a b)+stepSF dt x' = runIdentity . stepWirePure dt x'+++-- | Perform the next instant of a pure wire.++stepWirePure :: Monad m => Time -> a -> Wire m a b -> m (Output b, Wire m a b)+stepWirePure dt x' w' = toGen w' (PureState dt) x'
FRP/NetWire/Random.hs view
@@ -7,54 +7,83 @@ -- Noise generators.  module FRP.NetWire.Random-    ( -- * Noise generators+    ( -- * Impure noise generators       noise,       noise1,       noiseGen,       noiseR,-      wackelkontakt+      wackelkontakt,++      -- * Pure noise generators+      pureNoise,+      pureNoiseR     )     where +import qualified System.Random as R+import Control.Monad+import Control.Monad.IO.Class import FRP.NetWire.Wire import System.Random.Mersenne  --- | Noise between 0 (inclusive) and 1 (exclusive).+-- | Impure noise between 0 (inclusive) and 1 (exclusive). -noise :: Wire a Double+noise :: MonadIO m => Wire m a Double noise = noiseGen  --- | Noise between -1 and 1 exclusive.+-- | Impure noise between -1 (inclusive) and 1 (exclusive). -noise1 :: Wire a Double+noise1 :: MonadIO m => Wire m a Double noise1 =     mkGen $ \(wsRndGen -> mt) _ -> do-        x <- fmap (pred . (2*)) $ random mt-        x `seq` return (Just x, noise1)+        x <- liftM (pred . (2*)) . liftIO $ random mt+        x `seq` return (Right x, noise1)  --- | Noise.+-- | Impure noise. -noiseGen :: MTRandom b => Wire a b+noiseGen :: (MonadIO m, MTRandom b) => Wire m a b noiseGen =     mkGen $ \(wsRndGen -> mt) _ -> do-        x <- random mt-        x `seq` return (Just x, noiseGen)+        x <- liftIO (random mt)+        x `seq` return (Right x, noiseGen)  --- | Noise between 0 (inclusive) and the input signal (exclusive).+-- | Impure noise between 0 (inclusive) and the input signal+-- (exclusive).  Note:  The noise is generated by multiplying a+-- 'Double', hence the precision is limited. -noiseR :: (Real a, Integral b) => Wire a b+noiseR :: (MonadIO m, Real a, Integral b) => Wire m a b noiseR =     mkGen $ \(wsRndGen -> mt) n -> do-        x' <- random mt+        x' <- liftIO (random mt)         let x = floor ((x' :: Double) * realToFrac n)-        x `seq` return (Just x, noiseR)+        x `seq` return (Right x, noiseR)  --- | Random boolean.+-- | Pure noise.  For impure wires it's recommended to use the impure+-- noise generators. -wackelkontakt :: Wire a Bool+pureNoise :: (Monad m, R.RandomGen g, R.Random b) => g -> Wire m a b+pureNoise g' =+    mkGen $ \_ _ ->+        let (x, g) = R.random g'+        in x `seq` return (Right x, pureNoise g)+++-- | Pure noise in a range.  For impure wires it's recommended to use+-- the impure noise generators.++pureNoiseR :: (Monad m, R.RandomGen g, R.Random b) => g -> Wire m (b, b) b+pureNoiseR g' =+    mkGen $ \_ range ->+        let (x, g) = R.randomR range g'+        in x `seq` return (Right x, pureNoise g)+++-- | Impure random boolean.++wackelkontakt :: MonadIO m => Wire m a Bool wackelkontakt = noiseGen
FRP/NetWire/Request.hs view
@@ -12,19 +12,20 @@     )     where +import Control.Monad.IO.Class import Control.Concurrent.STM import FRP.NetWire.Wire   -- | Choose a unique identifier when switching in and keep it. -identifier :: Wire a Int+identifier :: MonadIO m => Wire m a Int identifier =     mkGen $ \ws _ -> do         let reqVar = wsReqVar ws-        req <- atomically $ do+        req <- liftIO . atomically $ do                    req' <- readTVar reqVar                    let req = succ req'                    req `seq` writeTVar reqVar (succ req')                    return req'-        return (Just req, WConst req)+        return (Right req, WConst req)
FRP/NetWire/Session.hs view
@@ -29,17 +29,17 @@  data Session a b =     Session {-      sessFreeVar  :: TVar Bool,        -- ^ False, if in use.-      sessStateRef :: IORef WireState,  -- ^ State of the last instant.-      sessTimeRef  :: IORef UTCTime,    -- ^ Time of the last instant.-      sessWireRef  :: IORef (Wire a b)  -- ^ Wire for the next instant.+      sessFreeVar  :: TVar Bool,             -- ^ False, if in use.+      sessStateRef :: IORef (WireState IO),  -- ^ State of the last instant.+      sessTimeRef  :: IORef UTCTime,         -- ^ Time of the last instant.+      sessWireRef  :: IORef (Wire IO a b)    -- ^ Wire for the next instant.     }   -- | Feed the given input value into the reactive system performing the -- next instant using real time. -stepWire :: a -> Session a b -> IO (Maybe b)+stepWire :: a -> Session a b -> IO (Output b) stepWire x' sess =     withBlock sess $ do         t <- getCurrentTime@@ -49,7 +49,7 @@ -- | Feed the given input value into the reactive system performing the -- next instant using the given time delta. -stepWireDelta :: NominalDiffTime -> a -> Session a b -> IO (Maybe b)+stepWireDelta :: NominalDiffTime -> a -> Session a b -> IO (Output b) stepWireDelta dt x' sess =     withBlock sess $ do         t' <- readIORef (sessTimeRef sess)@@ -61,7 +61,7 @@ -- next instant, which is at the given time.  This function is -- thread-safe. -stepWireTime :: UTCTime -> a -> Session a b -> IO (Maybe b)+stepWireTime :: UTCTime -> a -> Session a b -> IO (Output b) stepWireTime t' x' sess = withBlock sess (stepWireTime' t' x' sess)  @@ -69,7 +69,7 @@ -- next instant, which is at the given time.  This function is *not* -- thread-safe. -stepWireTime' :: UTCTime -> a -> Session a b -> IO (Maybe b)+stepWireTime' :: UTCTime -> a -> Session a b -> IO (Output b) stepWireTime' t x' sess = do     let Session { sessTimeRef = tRef, sessStateRef = wsRef, sessWireRef = wRef                 } = sess@@ -103,7 +103,7 @@ -- | Initialize a reactive session and pass it to the given -- continuation. -withWire :: Wire a b -> (Session a b -> IO c) -> IO c+withWire :: Wire IO a b -> (Session a b -> IO c) -> IO c withWire w k = do     t@(UTCTime td tt) <- getCurrentTime     ws <- initWireState
FRP/NetWire/Switch.hs view
@@ -24,6 +24,7 @@     where  import qualified Data.Traversable as T+import Control.Applicative import Data.Traversable (Traversable) import FRP.NetWire.Wire @@ -31,10 +32,10 @@ -- | Decoupled variant of 'rpSwitch'.  drpSwitch ::-    Traversable f =>+    (Applicative m, Monad m, Traversable f) =>     (forall w. a -> f w -> f (b, w)) ->-    f (Wire b c) ->-    Wire (a, Event (f (Wire b c) -> f (Wire b c))) (f c)+    f (Wire m b c) ->+    Wire m (a, Event (f (Wire m b c) -> f (Wire m b c))) (f c) drpSwitch route wires''' =     WGen $ \ws (x'', ev) -> do         let wires'' = route x'' wires'''@@ -48,9 +49,9 @@ -- | Decoupled variant of 'rpSwitchB'.  drpSwitchB ::-    forall a b f. Traversable f =>-    f (Wire a b) ->-    Wire (a, Event (f (Wire a b) -> f (Wire a b))) (f b)+    (Applicative m, Monad m, Traversable f) =>+    f (Wire m a b) ->+    Wire m (a, Event (f (Wire m a b) -> f (Wire m a b))) (f b) drpSwitchB wires'' =     WGen $ \ws (x', ev) -> do         r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires''@@ -62,7 +63,7 @@  -- | Decoupled variant of 'rSwitch'. -drSwitch :: Wire a b -> Wire (a, Event (Wire a b)) b+drSwitch :: Monad m => Wire m a b -> Wire m (a, Event (Wire m a b)) b drSwitch w1' =     WGen $ \ws (x', swEv) -> do         (mx, w1) <- toGen w1' ws x'@@ -72,16 +73,16 @@  -- | Decoupled variant of 'switch'. -dSwitch :: Wire a (b, Event c) -> (c -> Wire a b) -> Wire a b+dSwitch :: Monad m => Wire m a (b, Event c) -> (c -> Wire m a b) -> Wire m a b dSwitch w1' f =     WGen $ \ws x' -> do         (m, w1) <- toGen w1' ws x'         case m of-          Nothing        -> return (Nothing, dSwitch w1 f)-          Just (x, swEv) ->+          Left ex         -> return (Left ex, dSwitch w1 f)+          Right (x, swEv) ->               case swEv of-                Nothing -> return (Just x, dSwitch w1 f)-                Just sw -> return (Just x, f sw)+                Nothing -> return (Right x, dSwitch w1 f)+                Just sw -> return (Right x, f sw)   -- | Route signal to a collection of signal functions using the supplied@@ -89,8 +90,8 @@ -- inhibits.  par ::-    Traversable f =>-    (forall w. a -> f w -> f (b, w)) -> f (Wire b c) -> Wire a (f c)+    (Applicative m, Monad m, Traversable f) =>+    (forall w. a -> f w -> f (b, w)) -> f (Wire m b c) -> Wire m a (f c) par route wires'' =     WGen $ \ws x'' -> do         let wires' = route x'' wires''@@ -103,7 +104,7 @@ -- | Broadcast signal to a collection of signal functions.  If any of -- the wires inhibits, then the whole parallel network inhibits. -parB :: Traversable f => f (Wire a b) -> Wire a (f b)+parB :: (Applicative m, Monad m, Traversable f) => f (Wire m a b) -> Wire m a (f b) parB wires' =     WGen $ \ws x' -> do         r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires'@@ -120,10 +121,10 @@ -- inhibits.  rpSwitch ::-    Traversable f =>+    (Applicative m, Monad m, Traversable f) =>     (forall w. a -> f w -> f (b, w)) ->-    f (Wire b c) ->-    Wire (a, Event (f (Wire b c) -> f (Wire b c))) (f c)+    f (Wire m b c) ->+    Wire m (a, Event (f (Wire m b c) -> f (Wire m b c))) (f c) rpSwitch route wires''' =     WGen $ \ws (x'', ev) -> do         let wires'' = maybe id id ev wires'''@@ -142,8 +143,8 @@ -- inhibits.  rpSwitchB ::-    Traversable f =>-    f (Wire a b) -> Wire (a, Event (f (Wire a b) -> f (Wire a b))) (f b)+    (Applicative m, Monad m, Traversable f) =>+    f (Wire m a b) -> Wire m (a, Event (f (Wire m a b) -> f (Wire m a b))) (f b) rpSwitchB wires'' =     WGen $ \ws (x', ev) -> do         let wires' = maybe id id ev wires''@@ -157,7 +158,7 @@ -- switch takes switching events and switches to the wires contained in -- the events.  The first argument is the initial wire. -rSwitch :: Wire a b -> Wire (a, Event (Wire a b)) b+rSwitch :: Monad m => Wire m a b -> Wire m (a, Event (Wire m a b)) b rSwitch w1 =     WGen $ \ws (x', swEv) -> do         let w' = maybe w1 id swEv@@ -172,13 +173,13 @@ -- event at some point.  When this event is produced, then the signal -- path switches to the wire produced by the second argument function. -switch :: Wire a (b, Event c) -> (c -> Wire a b) -> Wire a b+switch :: Monad m => Wire m a (b, Event c) -> (c -> Wire m a b) -> Wire m a b switch w1' f =     WGen $ \ws x' -> do         (m, w1) <- toGen w1' ws x'         case m of-          Nothing        -> return (Nothing, switch w1 f)-          Just (x, swEv) ->+          Left ex         -> return (Left ex, switch w1 f)+          Right (x, swEv) ->               case swEv of-                Nothing -> return (Just x, switch w1 f)+                Nothing -> return (Right x, switch w1 f)                 Just sw -> toGen (f sw) (ws { wsDTime = 0 }) x'
FRP/NetWire/Tools.hs view
@@ -50,67 +50,68 @@  import Control.Arrow import Control.Category hiding ((.))+import Control.Exception import FRP.NetWire.Wire import Prelude hiding (id)   -- | Override the output value at the first non-inhibited instant. -(-->) :: b -> Wire a b -> Wire a b+(-->) :: Monad m => b -> Wire m a b -> Wire m a b y --> w' =     WGen $ \ws x -> do         (mx, w) <- toGen w' ws x         case mx of-          Nothing -> return (Nothing, y --> w)-          Just _  -> return (Just y, w)+          e@(Left _) -> return (e, y --> w)+          Right _    -> return (Right y, w)   -- | Override the input value, until the wire starts producing. -(>--) :: a -> Wire a b -> Wire a b+(>--) :: Monad m => a -> Wire m a b -> Wire m a b x' >-- w' =     WGen $ \ws _ -> do         (mx, w) <- toGen w' ws x'-        return (mx, maybe (x' >-- w) (const w) mx)+        return (mx, either (const $ x' >-- w) (const w) mx)   -- | Apply a function to the wire's output at the first non-inhibited -- instant. -(-=>) :: (b -> b) -> Wire a b -> Wire a b+(-=>) :: Monad m => (b -> b) -> Wire m a b -> Wire m a b f -=> w' =     WGen $ \ws x' -> do         (mx, w) <- toGen w' ws x'         case mx of-          Nothing -> return (Nothing, f -=> w)-          Just x  -> return (Just (f x), w)+          e@(Left _) -> return (e, f -=> w)+          Right x    -> return (Right (f x), w)   -- | Apply a function to the wire's input, until the wire starts -- producing. -(>=-) :: (a -> a) -> Wire a b -> Wire a b+(>=-) :: Monad m => (a -> a) -> Wire m a b -> Wire m a b f >=- w' =     WGen $ \ws x' -> do         (mx, w) <- toGen w' ws (f x')         case mx of-          Nothing -> return (Nothing, f >=- w)-          Just x  -> return (Just x, w)+          e@(Left _) -> return (e, f >=- w)+          Right _    -> return (mx, w)   -- | The constant wire.  Please use this function instead of @arr (const -- c)@. -constant :: b -> Wire a b+constant :: b -> Wire m a b constant = WConst   -- | Produce the value of the second argument at the first instant. -- Then produce the second value forever. -constantAfter :: b -> b -> Wire a b+constantAfter :: Monad m => b -> b -> Wire m a b constantAfter x1 x0 =-    mkGen $ \_ _ -> return (Just x0, constant x1)+    mkGen $ \_ _ -> return (Right x0, constant x1)   -- | Turn a continuous signal into a discrete one.  This transformer@@ -119,19 +120,19 @@ -- The interval length is followed in real time.  If it's zero, then -- this wire acts like @second id@. -discrete :: forall a. Wire (DTime, a) a+discrete :: forall a m. Monad m => Wire m (Time, a) a discrete =     mkGen $ \(wsDTime -> dt) (_, x0) ->-        return (Just x0, discrete' dt x0)+        return (Right x0, discrete' dt x0)      where-    discrete' :: Time -> a -> Wire (DTime, a) a+    discrete' :: Time -> a -> Wire m (Time, a) a     discrete' t' x' =         mkGen $ \(wsDTime -> dt) (int, x) ->             let t = t' + dt in             if t >= int-              then return (Just x, discrete' (fmod t int) x)-              else return (Just x', discrete' t x')+              then return (Right x, discrete' (fmod t int) x)+              else return (Right x', discrete' t x')   -- | Duplicate a value to a tuple.@@ -143,11 +144,11 @@ -- | This function corresponds to 'try' for exceptions, allowing you to -- observe inhibited signals. -exhibit :: Wire a b -> Wire a (Maybe b)+exhibit :: Monad m => Wire m a b -> Wire m a (Output b) exhibit w' =     WGen $ \ws x' -> do         (mx, w) <- toGen w' ws x'-        return (Just mx, exhibit w)+        return (Right mx, exhibit w)   -- | Floating point modulo operation.  Note that @fmod n 0@ = 0.@@ -164,7 +165,7 @@ -- Note:  This function should not be used normally.  Use it only, if -- you know exactly what you're doing. -freeze :: Wire a b -> Wire a b+freeze :: Monad m => Wire m a b -> Wire m a b freeze w =     WGen $ \ws x' -> do         (mx, _) <- toGen w ws x'@@ -173,28 +174,29 @@  -- | Identity signal transformer.  Outputs its input. -identity :: Wire a a+identity :: Monad m => Wire m a a identity = id  --- | Unconditional inhibition.  Equivalent to 'zeroArrow'.+-- | Unconditional inhibition with the given inhibition exception. -inhibit :: Wire a b-inhibit = zeroArrow+inhibit :: (Exception e, Monad m) => Wire m e b+inhibit =+    WGen $ \_ ex -> return (Left (toException ex), inhibit)   -- | Produce the argument value at the first instant.  Then act as the -- identity signal transformer forever. -initially :: a -> Wire a a+initially :: Monad m => a -> Wire m a a initially x0 =-    mkGen $ \_ _ -> return (Just x0, identity)+    mkGen $ \_ _ -> return (Right x0, identity)   -- | Keep the value in the first instant forever. -keep :: Wire a a-keep = mkGen $ \_ x -> return (Just x, constant x)+keep :: Monad m => Wire m a a+keep = mkGen $ \_ x -> return (Right x, constant x)   -- | Apply an arrow to a list of inputs.@@ -209,10 +211,11 @@  -- | Inhibit right signal, when the left signal is false. -require :: Wire (Bool, a) a+require :: Monad m => Wire m (Bool, a) a require =     mkGen $ \_ (b, x) ->-        return (if b then Just x else Nothing, require)+        return (if b then Right x else Left (inhibitEx "Required condition not met"),+                require)   -- | Sample the given wire at specific intervals.  Use this instead of@@ -222,14 +225,14 @@ -- The left signal interval is allowed to become zero, at which point -- the signal is passed through the wire at every instant. -sample :: Wire a b -> Wire (DTime, a) b+sample :: forall a b m. Monad m => Wire m a b -> Wire m (Time, a) b sample w' =     WGen $ \ws@(wsDTime -> dt) (_, x') -> do         (mx, w) <- toGen w' ws x'         return (mx, sample' dt mx w)      where-    sample' :: Time -> Maybe b -> Wire a b -> Wire (DTime, a) b+    sample' :: Time -> Output b -> Wire m a b -> Wire m (Time, a) b     sample' t' mx' w' =         WGen $ \ws@(wsDTime -> dt) (int, x'') ->             let t = t' + dt in@@ -237,23 +240,18 @@               then do                   (mx, w) <- toGen w' ws x''                   let nextT = fmod t int-                  case mx of-                    Nothing -> nextT `seq` return (mx', sample' nextT mx' w)-                    Just _  -> nextT `seq` return (mx, sample' nextT mx w)+                  nextT `seq` return (either (const mx') (const mx) mx, sample' nextT mx' w)               else                   return (mx', sample' t mx' w')   -- | Wait for the first signal from the given wire and keep it forever. -swallow :: Wire a b -> Wire a b+swallow :: Monad m => Wire m a b -> Wire m a b swallow w' =     WGen $ \ws x' -> do         (mx, w) <- toGen w' ws x'-        case mx of-          Nothing -> return (Nothing, swallow w)-          Just x  -> do-              return (Just x, constant x)+        return (mx, either (const (swallow w)) constant mx)   -- | Swap the values in a tuple.@@ -264,14 +262,14 @@  -- | Get the local time. -time :: Wire a Time+time :: Monad m => Wire m a Time time = timeFrom 0   -- | Get the local time, assuming it starts from the given value. -timeFrom :: Time -> Wire a Time+timeFrom :: Monad m => Time -> Wire m a Time timeFrom t' =     mkGen $ \ws _ ->         let t = t' + wsDTime ws-        in t `seq` return (Just t, timeFrom t)+        in t `seq` return (Right t, timeFrom t)
FRP/NetWire/Wire.hs view
@@ -12,12 +12,15 @@       WireState(..),        -- * Auxilliary types-      DTime,       Event,+      InhibitException,+      Output,+      SF,       Time,        -- * Utilities       cleanupWireState,+      inhibitEx,       initWireState,       mkGen,       toGen@@ -28,22 +31,42 @@ import Control.Arrow import Control.Category import Control.Concurrent.STM+import Control.Exception (Exception(..), SomeException)+import Control.Monad.IO.Class+import Data.Functor.Identity+import Data.Typeable import Prelude hiding ((.), id) import System.Random.Mersenne  --- | Derivative of time.  In English:  It's the time between two--- instants of an FRP session.--type DTime = Double-- -- | Events are signals, which can be absent.  They usually denote -- discrete occurences of certain events.  type Event = Maybe  +-- | Inhibition exception with an informative message.  This exception+-- is the result of signal inhibition, where no further exception+-- information is available.++data InhibitException =+    InhibitException String+    deriving (Read, Show, Typeable)++instance Exception InhibitException+++-- | The output of a wire.  When the wire inhibits, then this will be a+-- 'Left' value with an exception.++type Output = Either SomeException+++-- | Signal functions are wires over the identity monad.++type SF = Wire Identity++ -- | Time.  type Time = Double@@ -51,19 +74,19 @@  -- | A wire is a network of signal transformers. -data Wire a b where-    WArr   :: (a -> b) -> Wire a b-    WConst :: b -> Wire a b-    WGen   :: (WireState -> a -> IO (Maybe b, Wire a b)) -> Wire a b-    WId    :: Wire a a+data Wire :: (* -> *) -> * -> * -> * where+    WArr   :: (a -> b) -> Wire m a b+    WConst :: b -> Wire m a b+    WGen   :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b+    WId    :: Wire m a a  -instance Alternative (Wire a) where+instance Monad m => Alternative (Wire m a) where     empty = zeroArrow     (<|>) = (<+>)  -instance Applicative (Wire a) where+instance Monad m => Applicative (Wire m a) where     pure = WConst      wf' <*> wx' =@@ -73,7 +96,7 @@             return (mf <*> mx, wf <*> wx)  -instance Arrow Wire where+instance Monad m => Arrow (Wire m) where     arr = WArr      first (WGen f) =@@ -107,7 +130,7 @@             return (liftA2 (,) mx1 mx2, wf &&& wg)  -instance ArrowChoice Wire where+instance Monad m => ArrowChoice (Wire m) where     left w' = wl         where         wl =@@ -116,7 +139,7 @@                   Left x' -> do                       (mx, w) <- toGen w' ws x'                       return (fmap Left mx, left w)-                  Right x -> return (Just (Right x), wl)+                  Right x -> return (Right (Right x), wl)      right w' = wl         where@@ -126,7 +149,7 @@                   Right x' -> do                       (mx, w) <- toGen w' ws x'                       return (fmap Right mx, right w)-                  Left x -> return (Just (Left x), wl)+                  Left x -> return (Right (Left x), wl)      wf' +++ wg' =         WGen $ \ws mx' ->@@ -149,28 +172,28 @@                   return (mx, wf' ||| wg)  -instance ArrowPlus Wire where+instance Monad m => ArrowPlus (Wire m) where     WGen f <+> wg =         WGen $ \ws x' -> do             (mx, w1) <- f ws x'             case mx of-              Just _  -> return (mx, w1 <+> wg)-              Nothing -> do+              Right _ -> return (mx, w1 <+> wg)+              Left _  -> do                   (mx2, w2) <- toGen wg ws x'                   return (mx2, w1 <+> w2) -    wf <+> WGen _ = WGen (toGen wf)-     wa@(WArr _)   <+> _ = wa     wc@(WConst _) <+> _ = wc     WId           <+> _ = WId  -instance ArrowZero Wire where-    zeroArrow = mkGen $ \_ _ -> return (Nothing, zeroArrow)+instance Monad m => ArrowZero (Wire m) where+    zeroArrow =+        mkGen $ \_ _ ->+            return (Left (inhibitEx "Signal inhibited"), zeroArrow)  -instance Category Wire where+instance Monad m => Category (Wire m) where     id = WId      -- Combining two general wires.@@ -178,8 +201,8 @@         WGen $ \ws x'' -> do             (mx', w1) <- g ws x''             case mx' of-              Nothing -> return (Nothing, wf . w1)-              Just x' -> do+              Left ex  -> return (Left ex, wf . w1)+              Right x' -> do                   (mx, w2) <- f ws x'                   return (mx, w2 . w1) @@ -212,7 +235,7 @@     w1 . WId = w1  -instance Functor (Wire a) where+instance Monad m => Functor (Wire m a) where     fmap f (WGen w') =         WGen $ \ws x' -> do             (x, w) <- w' ws x'@@ -224,25 +247,34 @@  -- | The state of the wire. -data WireState =-    WireState {-      wsDTime  :: Double,   -- ^ Time difference for current instant.-      wsRndGen :: MTGen,    -- ^ Random number generator.-      wsReqVar :: TVar Int  -- ^ Request counter.-    }+data WireState :: (* -> *) -> * where+    ImpureState ::+        MonadIO m =>+        { wsDTime  :: Double,   -- ^ Time difference for current instant.+          wsRndGen :: MTGen,    -- ^ Random number generator.+          wsReqVar :: TVar Int  -- ^ Request counter.+        } -> WireState m +    PureState :: { wsDTime :: Double } -> WireState m + -- | Clean up wire state. -cleanupWireState :: WireState -> IO ()+cleanupWireState :: WireState m -> IO () cleanupWireState _ = return ()  +-- | Construct an 'InhibitException' wrapped in a 'SomeException'.++inhibitEx :: String -> SomeException+inhibitEx = toException . InhibitException++ -- | Initialize wire state. -initWireState :: IO WireState+initWireState :: MonadIO m => IO (WireState m) initWireState =-    WireState+    ImpureState     <$> pure 0     <*> getStdGen     <*> newTVarIO 0@@ -251,14 +283,14 @@ -- | Create a generic wire from the given function.  This is a smart -- constructor.  Please use it instead of the 'WGen' constructor. -mkGen :: (WireState -> a -> IO (Maybe b, Wire a b)) -> Wire a b+mkGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b mkGen = WGen   -- | Extract the transition function of a wire. -toGen :: Wire a b -> WireState -> a -> IO (Maybe b, Wire a b)+toGen :: Monad m => Wire m a b -> WireState m -> a -> m (Output b, Wire m a b) toGen (WGen f)      ws x = f ws x-toGen wf@(WArr f)   _  x = return (Just (f x), wf)-toGen wc@(WConst c) _  _ = return (Just c, wc)-toGen wi@WId        _  x = return (Just x, wi)+toGen wf@(WArr f)   _  x = return (Right (f x), wf)+toGen wc@(WConst c) _  _ = return (Right c, wc)+toGen wi@WId        _  x = return (Right x, wi)
netwire.cabal view
@@ -1,5 +1,5 @@ Name:          netwire-Version:       1.0.0+Version:       1.1.0 Category:      FRP, Network Synopsis:      Arrowized FRP implementation Maintainer:    Ertugrul Söylemez <es@ertes.de>@@ -8,7 +8,7 @@ License:       BSD3 License-file:  LICENSE Build-type:    Simple-Stability:     experimental+Stability:     beta Cabal-version: >= 1.8 Description: @@ -22,12 +22,16 @@         containers >= 0.4.0,         deepseq >= 1.1.0,         mersenne-random >= 1.0.0,+        monad-control >= 0.2.0,+        random >= 1.0.0,         stm >= 2.2.0,         time >= 1.2.0,+        transformers >= 0.2.2,         vector >= 0.7.1,         vector-space >= 0.7.3     Extensions:         Arrows+        DeriveDataTypeable         GADTs         RankNTypes         ScopedTypeVariables@@ -39,9 +43,10 @@         FRP.NetWire         FRP.NetWire.Analyze         FRP.NetWire.Calculus-        -- FRP.NetWire.Concurrent+        FRP.NetWire.Concurrent         FRP.NetWire.Event         FRP.NetWire.IO+        FRP.NetWire.Pure         FRP.NetWire.Random         FRP.NetWire.Request         FRP.NetWire.Session@@ -52,6 +57,7 @@ -- Executable netwire-test --     Build-depends: --         base >= 4 && <= 5,+--         gloss, --         netwire, --         time --     Extensions: