packages feed

netwire 1.2.3 → 1.2.4

raw patch · 6 files changed

+368/−137 lines, 6 files

Files

FRP/NetWire/Analyze.hs view
@@ -16,17 +16,25 @@       avgAll,       avgFps, +      -- ** Misc+      collect,+      lastSeen,+       -- ** Peak       highPeak,       lowPeak,-      peakBy,+      peakBy     )     where +import qualified Data.Map as M+import qualified Data.Set as S import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as UM import Control.DeepSeq import Control.Monad.ST+import Data.Map (Map)+import Data.Set (Set) import FRP.NetWire.Wire  @@ -98,6 +106,22 @@             return (fmap recip ma, avgFps' w)  +-- | Collects all the inputs ever received.  This wire uses O(n) memory+-- and runs in O(log n) time, where n is the number of inputs collected+-- so far.+--+-- Never inhibits.  Feedback by delay.++collect :: forall a m. (Ord a, Monad m) => Wire m a (Set a)+collect = collect' S.empty+    where+    collect' :: Set a -> Wire m a (Set a)+    collect' s' =+        mkGen $ \_ x ->+            let s = S.insert x s'+            in s `seq` return (Right s, collect' s)++ -- | Emits an event, whenever the input signal changes.  The event -- contains the last input value and the time elapsed since the last -- change.@@ -125,6 +149,26 @@  highPeak :: (Monad m, NFData a, Ord a) => Wire m a a highPeak = peakBy compare+++-- | Returns the time delta between now and when the input signal was+-- last seen.  This wire uses O(n) memory and runs in O(log n) time,+-- where n is the number of inputs collected so far.+--+-- Inhibits, when a signal is seen for the first time.++lastSeen :: forall a m. (Ord a, Monad m) => Wire m a Time+lastSeen = lastSeen' M.empty 0+    where+    lastSeen' :: Map a Time -> Time -> Wire m a Time+    lastSeen' tm' t' =+        mkGen $ \(wsDTime -> dt) x -> do+            let t = t' + dt+            let mx = case M.lookup x tm' of+                       Nothing -> Left (inhibitEx "Signal seen for the first time")+                       Just lt -> Right (t - lt)+            let tm = t `seq` M.insert x t tm'+            tm `seq` return (mx, lastSeen' tm t)   -- | Return the low peak.
FRP/NetWire/Request.hs view
@@ -7,16 +7,122 @@ -- Unique identifiers.  module FRP.NetWire.Request-    ( -- * Identifiers.+    ( -- * Context-sensitive time+      context,+      contextInt,+      contextLimited,+      contextLimitedInt,++      -- * Identifiers.       identifier     )     where +import qualified Data.IntMap as IM+import qualified Data.Map as M import Control.Monad.IO.Class import Control.Concurrent.STM+import Data.IntMap (IntMap)+import Data.Map (Map) import FRP.NetWire.Wire+import FRP.NetWire.Tools  +-- | Make the given wire context-sensitive.  The input signal is a+-- context and the argument wire will evolve individually for each such+-- context.+--+-- Inherits inhibition and feedback behaviour from the current context's+-- wire.++context :: forall a b m. (Ord a, Monad m) => Wire m a b -> Wire m a b+context w0 = context' M.empty 0+    where+    context' :: Map a (Time, Wire m a b) -> Time -> Wire m a b+    context' tm' t' =+        mkGen $ \ws@(wsDTime -> dt') ctx -> do+            let t = t' + dt'+            let (dt, w') = case M.lookup ctx tm' of+                             Nothing       -> (t, w0)+                             Just (lt, w') -> (t - lt, w')+            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) ctx+            let tm = M.insert ctx (t, w) tm'+            return (mx, context' tm t)+++-- | Specialized version of 'context'.  Use this one, if your contexts+-- are 'Int's and you have a lot of them.+--+-- Inherits inhibition and feedback behaviour from the current context's+-- wire.++contextInt :: forall b m. Monad m => Wire m Int b -> Wire m Int b+contextInt w0 = context' IM.empty 0+    where+    context' :: IntMap (Time, Wire m Int b) -> Time -> Wire m Int b+    context' tm' t' =+        mkGen $ \ws@(wsDTime -> dt') ctx -> do+            let t = t' + dt'+            let (dt, w') = case IM.lookup ctx tm' of+                             Nothing       -> (t, w0)+                             Just (lt, w') -> (t - lt, w')+            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) ctx+            let tm = IM.insert ctx (t, w) tm'+            return (mx, context' tm t)+++-- | Same as 'context', but with a time limit.  The left signal+-- specifies a threshold and the middle signal specifies a maximum age.+-- If the current number of contexts exceeds the threshold, then all+-- contexts exceeding the maximum age are deleted.+--+-- Inherits inhibition and feedback behaviour from the current context's+-- wire.++contextLimited :: forall a b m. (Ord a, Monad m) => Wire m a b -> Wire m (Int, Time, a) b+contextLimited w0 = context' M.empty 0+    where+    context' :: Map a (Time, Wire m a b) -> Time -> Wire m (Int, Time, a) b+    context' tm'' t' =+        mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx) -> do+            let t = t' + dt'+            let (dt, w') = case M.lookup ctx tm'' of+                             Nothing       -> (t, w0)+                             Just (lt, w') -> (t - lt, w')+            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) ctx+            let tm' = M.insert ctx (t, w) tm''+                tm = if M.size tm' <= limit+                       then tm'+                       else M.filter (\(ct, _) -> t - ct <= maxAge) tm'++            return (mx, context' tm t)+++-- | Specialized version of 'contextLimited'.  Use this one, if your+-- contexts are 'Int's and you have a lot of them.+--+-- Inherits inhibition and feedback behaviour from the current context's+-- wire.++contextLimitedInt :: forall b m. Monad m => Wire m Int b -> Wire m (Int, Time, Int) b+contextLimitedInt w0 = context' IM.empty 0+    where+    context' :: IntMap (Time, Wire m Int b) -> Time -> Wire m (Int, Time, Int) b+    context' tm'' t' =+        mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx) -> do+            let t = t' + dt'+            let (dt, w') = case IM.lookup ctx tm'' of+                             Nothing       -> (t, w0)+                             Just (lt, w') -> (t - lt, w')+            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) ctx+            let tm' = IM.insert ctx (t, w) tm''+                tm = if IM.size tm' <= limit+                       then tm'+                       else IM.filter (\(ct, _) -> t - ct <= maxAge) tm'++            return (mx, context' tm t)++ -- | Choose a unique identifier when switching in and keep it. -- -- Never inhibits.@@ -30,4 +136,4 @@                    let req = succ req'                    req `seq` writeTVar reqVar (succ req')                    return req'-        return (Right req, WConst req)+        return (Right req, constant req)
FRP/NetWire/Session.hs view
@@ -13,7 +13,11 @@       stepWireDelta,       stepWireTime,       stepWireTime',-      withWire+      withWire,++      -- * Low level+      sessionStart,+      sessionStop     )     where @@ -40,6 +44,32 @@     }  +-- | Start a wire session.++sessionStart :: MonadIO m => Wire m a b -> m (Session m a b)+sessionStart w = do+    t@(UTCTime td tt) <- liftIO getCurrentTime+    ws <- liftIO initWireState++    sess <-+        td `seq` tt `seq` t `seq` ws `seq`+        liftIO $+        Session+        <$> newTVarIO True+        <*> newIORef ws+        <*> newIORef t+        <*> newIORef w++    sess `seq` return sess+++-- | Clean up a wire session.++sessionStop :: MonadIO m => Session m a b -> m ()+sessionStop sess =+    liftIO $ readIORef (sessStateRef sess) >>= cleanupWireState++ -- | Feed the given input value into the reactive system performing the -- next instant using real time. @@ -138,18 +168,5 @@                                -- session data.     -> m c                     -- ^ Continuation's result. withWire w k = do-    t@(UTCTime td tt) <- liftIO getCurrentTime-    ws <- liftIO initWireState--    sess <--        td `seq` tt `seq` t `seq` ws `seq`-        liftIO $-        Session-        <$> newTVarIO True-        <*> newIORef ws-        <*> newIORef t-        <*> newIORef w--    seq sess (k sess)-        `finally`-        (liftIO $ readIORef (sessStateRef sess) >>= cleanupWireState)+    sess <- sessionStart w+    k sess `finally` sessionStop sess
FRP/NetWire/Tools.hs view
@@ -24,8 +24,11 @@        -- * Inhibitors       forbid,+      forbid_,       inhibit,+      inhibit_,       require,+      require_,        -- * Wire transformers       exhibit,@@ -47,6 +50,7 @@     )     where +import Control.Applicative import Control.Arrow import Control.Category hiding ((.)) import Control.Exception@@ -124,8 +128,8 @@ -- -- Never inhibits. -constant :: b -> Wire m a b-constant = WConst+constant :: Monad m => b -> Wire m a b+constant = pure   -- | One-instant delay.  Delay the signal for an instant returning the@@ -201,6 +205,17 @@                 forbid)  +-- | Inhibit, when the signal is true.+--+-- Inhibits on true signal.  No feedback.++forbid_ :: Monad m => Wire m Bool ()+forbid_ =+    mkGen $ \_ b ->+        return (if b then Left (inhibitEx "Forbidden condition met") else Right (),+                forbid_)++ -- | Effectively prevent a wire from rewiring itself.  This function -- will turn any stateful wire into a stateless wire, rendering most -- wires useless.@@ -258,6 +273,14 @@     WGen $ \_ ex -> return (Left (toException ex), inhibit)  +-- | Unconditional inhibition with default inhibition exception.+--+-- Always inhibits.++inhibit_ :: Monad m => Wire m a b+inhibit_ = zeroArrow++ -- | Keep the value in the first instant forever. -- -- Never inhibits.  Feedback by delay.@@ -287,6 +310,17 @@                 require)  +-- | Inhibit, when the signal is false.+--+-- Inhibits on false signal.  No feedback.++require_ :: Monad m => Wire m Bool ()+require_ =+    mkGen $ \_ b ->+        return (if b then Right () else Left (inhibitEx "Required condition not met"),+                require_)++ -- | Sample the given wire at specific intervals.  Use this instead of -- 'discrete', if you want to prevent the signal from passing through -- the wire all the time.  Returns the most recent result.@@ -350,6 +384,6 @@  timeFrom :: Monad m => Time -> Wire m a Time timeFrom t' =-    mkGen $ \ws _ ->-        let t = t' + wsDTime ws+    mkGen $ \(wsDTime -> dt) _ ->+        let t = t' + dt         in t `seq` return (Right t, timeFrom t)
FRP/NetWire/Wire.hs view
@@ -41,12 +41,6 @@ import System.Random.Mersenne  --- | 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.@@ -77,9 +71,7 @@  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   -- | This instance corresponds to the 'ArrowPlus' and 'ArrowZero'@@ -93,13 +85,8 @@ -- | Applicative interface to signal networks.  instance Monad m => Applicative (Wire m a) where-    pure = WConst--    wf' <*> wx' =-        WGen $ \ws x' -> do-            (cf, wf) <- toGen wf' ws x'-            (cx, wx) <- toGen wx' ws x'-            return (cf <*> cx, wf <*> wx)+    pure = arr . const+    wf <*> wx = wf &&& wx >>> arr (uncurry ($))   -- | Arrow interface to signal networks.@@ -109,64 +96,72 @@      first (WGen f) = WGen $ \ws (x', y) -> liftM (fmap (, y) *** first) (f ws x')     first (WArr f) = WArr (first f)-    first (WConst c) = WArr (first (const c))-    first WId = WId      second (WGen f) = WGen $ \ws (x, y') -> liftM (fmap (x,) *** second) (f ws y')     second (WArr f) = WArr (second f)-    second (WConst c) = WArr (second (const c))-    second WId = WId -    wf *** WId = first wf-    WId *** wg = second wg-    wf' *** wg' =-        WGen $ \ws (x', y') -> do-            (cx, wf) <- toGen wf' ws x'-            (cy, wg) <- toGen wg' ws y'-            return (liftA2 (,) cx cy, wf *** wg)--    wf' &&& wg' =-        WGen $ \ws x' -> do-            (cx1, wf) <- toGen wf' ws x'-            (cx2, wg) <- toGen wg' ws x'-            return (liftA2 (,) cx1 cx2, wf &&& wg)+    (***) = wsidebyside 0+    (&&&) = wboth 0   -- | Signal routing.  Unused routes are frozen, until they are put back -- into use.  instance Monad m => ArrowChoice (Wire m) where-    left w' = wl+    left w' = wl 0         where-        wl =-            WGen $ \ws mx' ->+        wl t' =+            WGen $ \ws@(wsDTime -> dt) mx' ->+                let t = t' + dt in+                t `seq`                 case mx' of-                  Left x' -> liftM (fmap Left *** left) (toGen w' ws x')-                  Right x -> return (pure (Right x), wl)+                  Left x' -> liftM (fmap Left *** left) (toGen w' (ws { wsDTime = t }) x')+                  Right x -> return (pure (Right x), wl t) -    right w' = wl+    right w' = wl 0         where-        wl =-            WGen $ \ws mx' ->+        wl t' =+            WGen $ \ws@(wsDTime -> dt) mx' ->+                let t = t' + dt in+                t `seq`                 case mx' of-                  Right x' -> liftM (fmap Right *** right) (toGen w' ws x')-                  Left x   -> return (pure (Left x), wl)+                  Right x' -> liftM (fmap Right *** right) (toGen w' (ws { wsDTime = t }) x')+                  Left x   -> return (pure (Left x), wl t) -    wf' +++ wg' =-        WGen $ \ws mx' ->-            case mx' of-              Left x'  -> liftM (fmap Left *** (+++ wg')) (toGen wf' ws x')-              Right x' -> liftM (fmap Right *** (wf' +++)) (toGen wg' ws x')+    wf' +++ wg' = wl 0 0 wf' wg'+        where+        wl tf' tg' wf' wg' =+            WGen $ \ws@(wsDTime -> dt) mx' ->+                let tf = tf' + dt+                    tg = tg' + dt in+                tf `seq` tg `seq`+                case mx' of+                  Left x'  -> do+                      (mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'+                      return (fmap Left mx, wl 0 tg wf wg')+                  Right x' -> do+                      (mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'+                      return (fmap Right mx, wl tf 0 wf' wg) -    wf' ||| wg' =-        WGen $ \ws mx' ->-            case mx' of-              Left x'  -> liftM (second (||| wg')) (toGen wf' ws x')-              Right x' -> liftM (second (wf' |||)) (toGen wg' ws x')+    wf' ||| wg' = wl 0 0 wf' wg'+        where+        wl tf' tg' wf' wg' =+            WGen $ \ws@(wsDTime -> dt) mx' ->+                let tf = tf' + dt+                    tg = tg' + dt in+                tf `seq` tg `seq`+                case mx' of+                  Left x'  -> do+                      (mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'+                      return (mx, wl 0 tg wf wg')+                  Right x' -> do+                      (mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'+                      return (mx, wl tf 0 wf' wg)   -- | Value recursion.  Warning: Recursive signal networks must never--- inhibit.  Use 'FRP.NetWire.Tools.exhibit' or 'FRP.NetWire.Event.event'.+-- inhibit.  Make use of 'FRP.NetWire.Tools.exhibit' or+-- 'FRP.NetWire.Event.event'.  instance MonadFix m => ArrowLoop (Wire m) where     loop w' =@@ -180,18 +175,19 @@ -- combination inhibits.  instance Monad m => ArrowPlus (Wire m) where-    WGen f <+> wg =-        WGen $ \ws x' -> do-            (mx, w1) <- f ws x'-            case mx of-              Right _ -> return (mx, w1 <+> wg)-              Left _  -> do-                  (mx2, w2) <- toGen wg ws x'-                  return (mx2, w1 <+> w2)+    wf'@(WGen _) <+> wg' = wl 0 wf' wg'+        where+        wl t' wf' wg' =+            WGen $ \ws@(wsDTime -> dt) x' -> do+                let t = t' + dt+                (mx, wf) <- toGen wf' ws x'+                case mx of+                  Right _ -> t `seq` return (mx, wl t wf wg')+                  Left _  -> do+                    (mx2, wg) <- t `seq` toGen wg' (ws { wsDTime = t }) x'+                    return (mx2, wl 0 wf wg)      wa@(WArr _)   <+> _ = wa-    wc@(WConst _) <+> _ = wc-    WId           <+> _ = WId   -- | The zero arrow always inhibits.@@ -203,57 +199,14 @@ -- | Identity signal network and signal network sequencing.  instance Monad m => Category (Wire m) where-    id = WId--    -- Combining two general wires.-    wf@(WGen f) . WGen g =-        WGen $ \ws x'' -> do-            (mx', w1) <- g ws x''-            case mx' of-              Left ex  -> return (Left ex, wf . w1)-              Right x' -> do-                  (mx, w2) <- f ws x'-                  return (mx, w2 . w1)--    -- Combining a special wire with a general wire.-    wf@(WArr f) . WGen g =-        WGen $ \ws x' -> do-            (mx, w) <- g ws x'-            return (fmap f mx, wf . w)-    wc@(WConst c) . WGen g =-        WGen $ \ws x' -> do-            (mx, w) <- g ws x'-            return (fmap (const c) mx, wc . w)-    WGen f . wg@(WArr g) =-        WGen $ \ws x' -> do-            (mx, w) <- f ws (g x')-            return (mx, w . wg)-    WGen f . wc@(WConst c) =-        WGen $ \ws _ -> do-            (mx, w) <- f ws c-            return (mx, w . wc)--    -- Combining special wires.-    WArr f . WArr g = WArr (f . g)-    WArr f . WConst c = WArr (const (f c))--    WConst c . WArr _ = WConst c-    WConst c . WConst _ = WConst c--    WId . w2 = w2-    w1 . WId = w1+    id = WArr id+    (.) = flip (wcompose 0)   -- | Map over the result of a signal network.  instance Monad m => Functor (Wire m a) where-    fmap f (WGen w') =-        WGen $ \ws x' -> do-            (x, w) <- w' ws x'-            return (fmap f x, fmap f w)-    fmap f (WArr g) = WArr (f . g)-    fmap f (WConst c) = WConst (f c)-    fmap f WId = WArr f+    fmap f = (>>> arr f)   -- | The state of the wire.@@ -308,7 +261,83 @@ -- | Extract the transition function of 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-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)+toGen (WGen f)    ws x = f ws x+toGen wf@(WArr f) _  x = return (Right (f x), wf)+++-- | Efficient signal sharing.++wboth :: Monad m => Time -> Wire m a b -> Wire m a c -> Wire m a (b, c)+wboth t' (WGen f) wg'@(WGen g) =+    WGen $ \ws@(wsDTime -> dt) x' -> do+        let t = t' + dt+        (mx1, wf) <- t `seq` f ws x'+        case mx1 of+          Left ex -> return (Left ex, wboth t wf wg')+          Right _ -> do+              (mx2, wg) <- g ws x'+              return (liftA2 (,) mx1 mx2, wboth 0 wf wg)++wboth t' wf@(WArr f) (WGen g) =+    WGen $ \ws x' -> do+        (mx2, wg) <- g ws x'+        return (fmap (f x',) mx2, wboth t' wf wg)++wboth t' (WGen f) wg@(WArr g) =+    WGen $ \ws x' -> do+        (mx1, wf) <- f ws x'+        return (fmap (, g x') mx1, wboth t' wf wg)++wboth _ (WArr f) (WArr g) = WArr (f &&& g)+++-- | Efficient forward-composition of two wires.++wcompose :: Monad m => Time -> Wire m a b -> Wire m b c -> Wire m a c+wcompose t' (WGen f) wg'@(WGen g) =+    WGen $ \ws@(wsDTime -> dt) x'' -> do+        let t = t' + dt+        (mx', wf) <- t `seq` f ws x''+        case mx' of+          Left ex  -> return (Left ex, wcompose t wf wg')+          Right x' -> do+              (mx, wg) <- g (ws { wsDTime = t }) x'+              return (mx, wcompose 0 wf wg)++wcompose t' wf@(WArr f) (WGen g) =+    WGen $ \ws x' -> do+        (mx, wg) <- g ws (f x')+        return (mx, wcompose t' wf wg)++wcompose t' (WGen f) wg@(WArr g) =+    WGen $ \ws x' -> do+        (mx, wf) <- f ws x'+        return (fmap g mx, wcompose t' wf wg)++wcompose _ (WArr f) (WArr g) = WArr (g . f)+++-- | Run two signals through two signal networks.++wsidebyside :: Monad m => Time -> Wire m a c -> Wire m b d -> Wire m (a, b) (c, d)+wsidebyside t' (WGen f) wg'@(WGen g) =+    WGen $ \ws@(wsDTime -> dt) (x', y') -> do+        let t = t' + dt+        (mx, wf) <- t `seq` f ws x'+        case mx of+          Left ex -> return (Left ex, wsidebyside t wf wg')+          Right _ -> do+              (my, wg) <- g ws y'+              return (liftA2 (,) mx my, wsidebyside 0 wf wg)++wsidebyside t' wf@(WArr f) (WGen g) =+    WGen $ \ws (x', y') -> do+        (my, wg) <- g ws y'+        return (fmap (f x',) my, wsidebyside t' wf wg)++wsidebyside t' (WGen f) wg@(WArr g) =+    WGen $ \ws (x', y') -> do+        (mx, wf) <- f ws x'+        return (fmap (, g y') mx, wsidebyside t' wf wg)++wsidebyside _ (WArr f) (WArr g) = WArr (f *** g)
netwire.cabal view
@@ -1,5 +1,5 @@ Name:          netwire-Version:       1.2.3+Version:       1.2.4 Category:      FRP, Network Synopsis:      Arrowized FRP implementation Maintainer:    Ertugrul Söylemez <es@ertes.de>@@ -59,6 +59,7 @@ -- Executable netwire-test --     Build-depends: --         base >= 4 && <= 5,+--         containers, --         netwire, --         transformers --     Extensions: