netwire 1.2.6 → 1.2.7
raw patch · 7 files changed
+172/−128 lines, 7 files
Files
- FRP/NetWire.hs +5/−2
- FRP/NetWire/Concurrent.hs +0/−91
- FRP/NetWire/Session.hs +50/−0
- FRP/NetWire/Switch.hs +6/−1
- FRP/NetWire/Tools.hs +14/−19
- FRP/NetWire/Wire.hs +95/−13
- netwire.cabal +2/−2
FRP/NetWire.hs view
@@ -11,6 +11,7 @@ module FRP.NetWire ( -- * Wires Wire, Output, Time,+ WireState(..), mkGen, toGen, -- * Reactive sessions@@ -20,6 +21,10 @@ stepWireTime, withWire, + -- * Testing wires+ testWire,+ testWireStr,+ -- * Pure wires SF, stepSF,@@ -33,7 +38,6 @@ -- * Netwire Reexports module FRP.NetWire.Analyze, module FRP.NetWire.Calculus,- module FRP.NetWire.Concurrent, module FRP.NetWire.Event, module FRP.NetWire.IO, module FRP.NetWire.Random,@@ -53,7 +57,6 @@ import Data.Functor.Identity import FRP.NetWire.Analyze import FRP.NetWire.Calculus-import FRP.NetWire.Concurrent import FRP.NetWire.Event import FRP.NetWire.IO import FRP.NetWire.Pure
− FRP/NetWire/Concurrent.hs
@@ -1,91 +0,0 @@--- |--- 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/Session.hs view
@@ -15,6 +15,10 @@ stepWireTime', withWire, + -- * Testing wires+ testWire,+ testWireStr,+ -- * Low level sessionStart, sessionStop@@ -22,13 +26,16 @@ where import Control.Applicative+import Control.Arrow import Control.Concurrent.STM import Control.Exception.Control+import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Control import Data.IORef import Data.Time.Clock import FRP.NetWire.Wire+import System.IO -- | Reactive sessions with the given input and output types over the@@ -143,6 +150,49 @@ w `seq` liftIO (writeIORef wRef w) return x+++-- | Interface to 'testWireStr' accepting all 'Show' instances as the+-- output type.++testWire ::+ forall a b m. (MonadControlIO m, Show b)+ => Int -- ^ Show output once each this number of frames.+ -> m a -- ^ Input generator.+ -> Wire m a b -- ^ Your wire.+ -> m ()+testWire fpp getInput w' = testWireStr fpp getInput (w' >>> arr show)+++-- | This function provides a convenient way to test wires. It wraps a+-- default loop around your wire, which just displays the output on your+-- stdout in a single line (it uses an ANSI escape sequence to clear the+-- line). It uses real time.++testWireStr ::+ forall a m. MonadControlIO m+ => Int -- ^ Show output once each this number of frames.+ -> m a -- ^ Input generator.+ -> Wire m a String -- ^ Wire to evolve.+ -> m ()+testWireStr fpp getInput w' =+ withWire w' (loop 0)++ where+ loop :: Int -> Session m a String -> m ()+ loop n' sess = do+ let n = let n = succ n' in if n >= fpp then 0 else n++ x' <- getInput+ mx <- stepWire x' sess+ when (n' == 0) . liftIO $ do+ putStr "\r\027[K"+ case mx of+ Left ex -> putStr (show ex)+ Right str -> putStr str+ hFlush stdout++ n `seq` loop n sess -- | Perform an interlocked step function.
FRP/NetWire/Switch.hs view
@@ -19,7 +19,12 @@ -- * Routers par,- rpSwitch, drpSwitch+ rpSwitch, drpSwitch,++ -- * Embedding wires+ appEvent,+ appFirst,+ appFrozen ) where
FRP/NetWire/Tools.hs view
@@ -202,9 +202,8 @@ forbid :: Monad m => Wire m (Bool, a) a forbid =- mkGen $ \_ (b, x) ->- return (if b then Left (inhibitEx "Forbidden condition met") else Right x,- forbid)+ mkFix $ \_ (b, x) ->+ return (if b then Left (inhibitEx "Forbidden condition met") else Right x) -- | Inhibit, when the signal is true.@@ -213,9 +212,8 @@ forbid_ :: Monad m => Wire m Bool () forbid_ =- mkGen $ \_ b ->- return (if b then Left (inhibitEx "Forbidden condition met") else Right (),- forbid_)+ mkFix $ \_ b ->+ return (if b then Left (inhibitEx "Forbidden condition met") else Right ()) -- | Effectively prevent a wire from rewiring itself. This function@@ -230,9 +228,9 @@ freeze :: Monad m => Wire m a b -> Wire m a b freeze w =- WGen $ \ws x' -> do+ mkFix $ \ws x' -> do (mx, _) <- toGen w ws x'- return (mx, w)+ return mx -- | Keep the latest output.@@ -272,7 +270,7 @@ inhibit :: (Exception e, Monad m) => Wire m e b inhibit =- WGen $ \_ ex -> return (Left (toException ex), inhibit)+ mkFix $ \_ ex -> return (Left (toException ex)) -- | Unconditional inhibition with default inhibition exception.@@ -288,7 +286,7 @@ -- Inhibits on 'Left' signals. inject :: forall a e m. (Exception e, Monad m) => Wire m (Either e a) a-inject = mkGen $ \_ mx -> return (leftToEx mx, inject)+inject = mkFix $ \_ mx -> return (leftToEx mx) where leftToEx :: Either e a -> Either SomeException a leftToEx (Right x) = Right x@@ -301,9 +299,8 @@ injectMaybe :: Monad m => Wire m (Maybe a) a injectMaybe =- mkGen $ \_ mx ->- return (maybe (Left (inhibitEx "No signal to inject")) Right mx,- injectMaybe)+ mkFix $ \_ mx ->+ return (maybe (Left (inhibitEx "No signal to inject")) Right mx) -- | Keep the value in the first instant forever.@@ -330,9 +327,8 @@ require :: Monad m => Wire m (Bool, a) a require =- mkGen $ \_ (b, x) ->- return (if b then Right x else Left (inhibitEx "Required condition not met"),- require)+ mkFix $ \_ (b, x) ->+ return (if b then Right x else Left (inhibitEx "Required condition not met")) -- | Inhibit, when the signal is false.@@ -341,9 +337,8 @@ require_ :: Monad m => Wire m Bool () require_ =- mkGen $ \_ b ->- return (if b then Right () else Left (inhibitEx "Required condition not met"),- require_)+ mkFix $ \_ b ->+ return (if b then Right () else Left (inhibitEx "Required condition not met")) -- | Sample the given wire at specific intervals. Use this instead of
FRP/NetWire/Wire.hs view
@@ -4,7 +4,9 @@ -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> ----- The module contains the main 'Wire' type.+-- The module contains the main 'Wire' type and its type class+-- instances. It also provides convenience functions for wire+-- developers. module FRP.NetWire.Wire ( -- * Wires@@ -21,9 +23,15 @@ cleanupWireState, inhibitEx, initWireState,+ mkFix, mkGen, noEvent,- toGen+ toGen,++ -- * Wire transformers+ appEvent,+ appFirst,+ appFrozen ) where @@ -70,8 +78,8 @@ -- | A wire is a network of signal transformers. data Wire :: (* -> *) -> * -> * -> * where- WArr :: (a -> b) -> Wire m a b- WGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b+ WArr :: (a -> b) -> Wire m a b+ WGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b -- | This instance corresponds to the 'ArrowPlus' and 'ArrowZero'@@ -104,9 +112,18 @@ (&&&) = wboth 0 --- | Signal routing. Unused routes are frozen, until they are put back--- into use.+-- | The 'app' combinator has the behaviour of 'appFrozen'. Note that+-- this effectively keeps a wire bound by the "-<<" syntax from+-- evolving. For alternative embedding combinators see also 'appEvent'+-- and 'appFirst'. +instance Monad m => ArrowApply (Wire m) where+ app = appFrozen+++-- | Signal routing. Unused routes are ignored. Note that they still+-- run in real time, i.e. the time deltas passed are accumulated.+ instance Monad m => ArrowChoice (Wire m) where left w' = wl 0 where@@ -161,7 +178,7 @@ -- | Value recursion. Warning: Recursive signal networks must never -- inhibit. Make use of 'FRP.NetWire.Tools.exhibit' or--- 'FRP.NetWire.Event.event'.+-- 'FRP.NetWire.Event.event' for wires that may inhibit. instance MonadFix m => ArrowLoop (Wire m) where loop w' =@@ -172,7 +189,8 @@ -- | Left-biased signal network combination. If the left arrow -- inhibits, the right arrow is tried. If both inhibit, their--- combination inhibits.+-- combination inhibits. Ignored wire networks still run in real time,+-- i.e. passed time deltas are accumulated. instance Monad m => ArrowPlus (Wire m) where wf'@(WGen _) <+> wg' = wl 0 wf' wg'@@ -193,7 +211,7 @@ -- | The zero arrow always inhibits. instance Monad m => ArrowZero (Wire m) where- zeroArrow = mkGen $ \_ _ -> return (Left (inhibitEx "Signal inhibited"), zeroArrow)+ zeroArrow = mkFix $ \_ _ -> return (Left (inhibitEx "Signal inhibited")) -- | Identity signal network and signal network sequencing.@@ -203,7 +221,7 @@ (.) = flip (wcompose 0) --- | Map over the result of a signal network.+-- | Map over the output of a signal network. instance Monad m => Functor (Wire m a) where fmap f = (>>> arr f)@@ -222,6 +240,60 @@ PureState :: { wsDTime :: Double } -> WireState m +-- | Embeds the input wire (left signal) into the network with the given+-- input signal (right signal). Each time the input wire is a 'Just',+-- the current state of the last wire is discarded and the new wire is+-- evolved instead. New wires can be generated by an event wire and+-- catched via 'FRP.NetWire.Event.event'. The initial wire is given by+-- the argument.+--+-- Inhibits whenever the embedded wire inhibits. Same feedback+-- behaviour as the embedded wire.++appEvent ::+ forall a b m. Monad m+ => Wire m a b+ -> Wire m (Maybe (Wire m a b), a) b+appEvent cw' =+ mkGen $ \ws (mw, x') -> do+ let w' = maybe cw' id mw+ (mx, w) <- toGen w' ws x'+ return (mx, appEvent w)+++-- | Embeds the first received input wire (left signal) into the+-- network, feeding it the right signal. This wire respects its left+-- signal only in the first instant, after which it wraps that wire's+-- evolution.+--+-- Inhibits whenever the embedded wire inhibits. Same feedback+-- behaviour as the embedded wire.++appFirst :: forall a b m. Monad m => Wire m (Wire m a b, a) b+appFirst =+ mkGen $ \ws (w', x') -> do+ (mx, w) <- toGen w' ws x'+ return (mx, embed w)++ where+ embed :: Wire m a b -> Wire m (Wire m a b, a) b+ embed w' =+ mkGen $ \ws (_, x') -> do+ (mx, w) <- toGen w' ws x'+ return (mx, embed w)+++-- | Embeds the first instant of the input wire (left signal) into the+-- network, feeding it the right signal. This wire respects its left+-- signal in all instances, such that the embedded wire cannot evolve.+--+-- Inhibits whenever the embedded wire inhibits. Same feedback+-- behaviour as the embedded wire.++appFrozen :: Monad m => Wire m (Wire m a b, a) b+appFrozen = mkFix $ \ws (w, x') -> liftM fst (toGen w ws x')++ -- | Clean up wire state. cleanupWireState :: WireState m -> IO ()@@ -244,9 +316,17 @@ <*> newTVarIO 0 --- | Create a generic wire from the given function. This is a smart--- constructor. Please use it instead of the 'WGen' constructor.+-- | Create a fixed wire from the given function. This is a smart+-- constructor. It creates a stateless wire. +mkFix :: Monad m => (WireState m -> a -> m (Output b)) -> Wire m a b+mkFix f = let w = WGen $ \ws -> liftM (, w) . f ws in w+++-- | Create a generic (i.e. possibly stateful) wire from the given+-- function. This is a smart constructor. Please use it instead of the+-- 'WGen' constructor for creating generic wires.+ mkGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b mkGen = WGen @@ -258,7 +338,9 @@ noEvent = inhibitEx "No event" --- | Extract the transition function of a wire.+-- | Extract the transition function of a wire. Unless there is reason+-- (like optimization) to pattern-match against the 'Wire' constructors,+-- this function is the recommended way to evolve a wire. 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
netwire.cabal view
@@ -1,5 +1,5 @@ Name: netwire-Version: 1.2.6+Version: 1.2.7 Category: FRP, Network Synopsis: Arrowized FRP implementation Maintainer: Ertugrul Söylemez <es@ertes.de>@@ -21,6 +21,7 @@ base >= 4 && <= 5, containers >= 0.4.0, deepseq >= 1.1.0,+-- forkable-monad >= 0.1.1, mersenne-random >= 1.0.0, monad-control >= 0.2.0, random >= 1.0.0,@@ -45,7 +46,6 @@ FRP.NetWire FRP.NetWire.Analyze FRP.NetWire.Calculus- FRP.NetWire.Concurrent FRP.NetWire.Event FRP.NetWire.IO FRP.NetWire.Pure