packages feed

wires 0.1.0 → 0.2.0

raw patch · 9 files changed

+194/−47 lines, 9 filesdep +mtldep ~deepseqdep ~profunctorsdep ~semigroupoidsnew-component:exe:wires-feedback

Dependencies added: mtl

Dependency ranges changed: deepseq, profunctors, semigroupoids, these

Files

CHANGELOG.md view
@@ -1,3 +1,20 @@+# 0.2.0++  * **Breaking change**: Safer API for `manage` and `manage'`.++  * Fix: Wire strictness.  Strict value recursion like the following+    works now:++        rec x <- scan x0 -< x `seq` ev++  * Change: Tighter version bounds.++  * Add: `splitE`, `unalignE`, `unlessE`.++  * Add: `hoistW`.++  * Add: `asksW`, `askW`, `runReaderW`.+ # 0.1.0    * Initial version.
Control/Wire.hs view
@@ -8,10 +8,12 @@     ( -- * Wires       module Control.Category,       module Control.Wire.Core,+      module Control.Wire.Trans,       module Control.Wire.Utils     )     where  import Control.Category import Control.Wire.Core+import Control.Wire.Trans import Control.Wire.Utils
Control/Wire/Core.hs view
@@ -22,17 +22,30 @@       unfoldE,        -- * Switching+      Switch(..),       manage,       manage',       sequenceW,       switch,-      switch'+      switch',++      -- * Monad transformers+      hoistW     )     where  import Control.Wire.Internal  +-- | Functions to be applied to the current set of wires managed by+-- 'manage'.++newtype Switch f m a b =+    Switch {+      fromSwitch :: forall s. (Wire m a b -> s) -> f s -> f s+    }++ -- | Map and filter event occurrences using the given function.  catMapE :: (a -> Maybe b) -> Event a -> Event b@@ -46,6 +59,17 @@ evalWith strat = let w = Wire (\x -> x `strat` pure (x, w)) in w  +-- | Map the underlying monad using the given function.++hoistW :: (Functor m) => (a -> a') -> (forall x. a -> m' x -> m x) -> Wire m' a' b -> Wire m a b+hoistW f trans = go+    where+    go w' =+        Wire $ \x ->+            (\(y, w) -> (y, go w))+            <$> trans x (stepWire w' (f x))++ -- | Hold the latest occurrence of the given event starting with the -- given initial value.  The value switch occurs in the next frame. @@ -66,34 +90,34 @@ initial = Wire $ fmap (\y -> (y, pure y))  --- | Sequence each of the given wires and collect their results.  If the--- given event occurs, the its function is applied to the current set of--- wires.  Changes are applied in the next frame.+-- | Sequence each of the given wires and collect their results.+-- Whenever the given event occurs its function is applied to the+-- current set of wires.  Changes are applied in the next frame.  manage     :: (Traversable f, Applicative m)     => f (Wire m a b)-    -> Wire m (a, Event (f (Wire m a b) -> f (Wire m a b))) (f b)+    -> Wire m (a, Event (Switch f m a b)) (f b) manage ws' =     Wire $ \(x, mf) ->         (\ys -> (fst <$> ys,-                 manage (event id id mf (snd <$> ys))))+                 manage (event id (\(Switch f) -> f id) mf (snd <$> ys))))         <$> traverse (`stepWire` x) ws'  --- | Sequence each of the given wires and collect their results.  If the--- given event occurs, the its function is applied to the current set of--- wires.  Changes are applied immediately.+-- | Sequence each of the given wires and collect their results.+-- Whenever the given event occurs its function is applied to the+-- current set of wires.  Changes are applied immediately.  manage'     :: (Traversable f, Applicative m)     => f (Wire m a b)-    -> Wire m (a, Event (f (Wire m a b) -> f (Wire m a b))) (f b)+    -> Wire m (a, Event (Switch f m a b)) (f b) manage' ws' =     Wire $ \(x, mf) ->         (\ys -> (fst <$> ys,-                 manage (snd <$> ys)))-        <$> traverse (`stepWire` x) (event id id mf ws')+                 manage' (snd <$> ys)))+        <$> traverse (`stepWire` x) (event id (\(Switch f) -> f id) mf ws')   -- | The event that never occurs.@@ -131,7 +155,7 @@     Wire $ \x -> do         ((y, mw), w) <- stepWire w' x         case mw of-          NotNow -> pure (y, switch w)+          NotNow -> pure (y, switch' w)           Now nw -> stepWire nw x
Control/Wire/Internal.hs view
@@ -1,5 +1,5 @@ -- |--- Copyright:  (c) 2016 Ertugrul Söylemez+-- Copyright:  (c) 2017 Ertugrul Söylemez -- License:    BSD3 -- Maintainer: Ertugrul Söylemez <esz@posteo.de> -- Stability:  experimental@@ -91,7 +91,7 @@      wf' <*> wx' =         Wire $ \x' ->-            (\(f, wf) (x, wx) -> (f x, wf <*> wx))+            (\ ~(f, wf) ~(x, wx) -> (f x, wf <*> wx))             <$> stepWire wf' x'             <*> stepWire wx' x' @@ -102,7 +102,7 @@      wx' &&& wy' =         Wire $ \x' ->-            (\(x, wx) (y, wy) -> ((x, y), wx &&& wy))+            (\ ~(x, wx) ~(y, wy) -> ((x, y), wx &&& wy))             <$> stepWire wx' x'             <*> stepWire wy' x' @@ -118,13 +118,13 @@      wl' +++ wr' =         Wire $-        either (\x -> (\(y, wl) -> (Left y,  wl +++ wr')) <$> stepWire wl' x)-               (\x -> (\(y, wr) -> (Right y, wl' +++ wr)) <$> stepWire wr' x)+        either (\x -> (\ ~(y, wl) -> (Left y,  wl +++ wr')) <$> stepWire wl' x)+               (\x -> (\ ~(y, wr) -> (Right y, wl' +++ wr)) <$> stepWire wr' x)      wl' ||| wr' =         Wire $-        either (\x -> (\(y, wl) -> (y, wl ||| wr')) <$> stepWire wl' x)-               (\x -> (\(y, wr) -> (y, wl' ||| wr)) <$> stepWire wr' x)+        either (\x -> (\ ~(y, wl) -> (y, wl ||| wr')) <$> stepWire wl' x)+               (\x -> (\ ~(y, wr) -> (y, wl' ||| wr)) <$> stepWire wr' x)  instance (MonadFix m) => ArrowLoop (Wire m) where     loop = unfirst@@ -134,52 +134,52 @@      w2' . w1' =         Wire $ \x0 -> do-            (x1, w1) <- stepWire w1' x0-            (x2, w2) <- stepWire w2' x1+            ~(x1, w1) <- stepWire w1' x0+            ~(x2, w2) <- stepWire w2' x1             pure (x2, w2 . w1)  instance (Applicative m) => Choice (Wire m) where     left' w' =         Wire $-        either (\x -> (\(y, w) -> (Left y, left' w)) <$> stepWire w' x)+        either (\x -> (\ ~(y, w) -> (Left y, left' w)) <$> stepWire w' x)                (\x -> pure (Right x, left' w'))      right' w' =         Wire $         either (\x -> pure (Left x, right' w'))-               (\x -> (\(y, w) -> (Right y, right' w)) <$> stepWire w' x)+               (\x -> (\ ~(y, w) -> (Right y, right' w)) <$> stepWire w' x)  instance (MonadFix m) => Costrong (Wire m) where     unfirst w' =         Wire $ \x' ->-            (\((x, _), w) -> (x, unfirst w))+            (\ ~(x, w) -> (fst x, unfirst w))             <$> mfix (\r -> stepWire w' (x', snd (fst r)))      unsecond w' =         Wire $ \x' ->-            (\((_, x), w) -> (x, unsecond w))+            (\ ~(x, w) -> (snd x, unsecond w))             <$> mfix (\r -> stepWire w' (fst (fst r), x'))  instance (Functor m) => Profunctor (Wire m) where     dimap fl fr = go         where-        go w' = Wire (fmap (\(y, w) -> (fr y, go w)) . stepWire w' . fl)+        go w' = Wire (fmap (\ ~(y, w) -> (fr y, go w)) . stepWire w' . fl)      lmap f = go         where-        go w' = Wire (fmap (\(y, w) -> (y, go w)) . stepWire w' . f)+        go w' = Wire (fmap (\ ~(y, w) -> (y, go w)) . stepWire w' . f)      rmap = fmap  instance (Functor m) => Strong (Wire m) where     first' w' =-        Wire $ \(x', y) ->-            (\(x, w) -> ((x, y), first' w))+        Wire $ \ ~(x', y) ->+            (\ ~(x, w) -> ((x, y), first' w))             <$> stepWire w' x'      second' w' =-        Wire $ \(x, y') ->-            (\(y, w) -> ((x, y), second' w))+        Wire $ \ ~(x, y') ->+            (\ ~(y, w) -> ((x, y), second' w))             <$> stepWire w' y'  @@ -187,9 +187,9 @@  delayW :: (Functor m) => b -> Wire m a b -> Wire m a b delayW y' w' =-    Wire $ \x ->-        (\(y, w) -> (y', delayW y w))-        <$> stepWire w' x+    Wire $+        fmap (\(y, w) -> (y', delayW y w)) .+        stepWire w'   -- | Fold the given event.
+ Control/Wire/Trans.hs view
@@ -0,0 +1,36 @@+-- |+-- Copyright:  (c) 2016 Ertugrul Söylemez+-- License:    BSD3+-- Maintainer: Ertugrul Söylemez <esz@posteo.de>++module Control.Wire.Trans+    ( -- * Monad transformers+      -- ** Reader+      asksW,+      askW,+      runReaderW+    )+    where++import Control.Monad.Reader+import Control.Wire.Controller+import Control.Wire.Core+import Data.Profunctor+++-- | Get the given function applied to the environment value.++asksW :: (MonadReader a m) => Wire m (a -> b) b+asksW = lmap asks animate+++-- | Get the environment value.++askW :: (MonadReader b m) => Wire m a b+askW = lmap (\_ -> ask) animate+++-- | Embed the given 'ReaderT'-transformed monad.++runReaderW :: (Functor m) => Wire (ReaderT e m) a b -> Wire m (e, a) b+runReaderW = hoistW snd (\(env, _) c -> runReaderT c env)
Control/Wire/Utils.hs view
@@ -1,5 +1,5 @@ -- |--- Copyright:  (c) 2016 Ertugrul Söylemez+-- Copyright:  (c) 2017 Ertugrul Söylemez -- License:    BSD3 -- Maintainer: Ertugrul Söylemez <esz@posteo.de> -- Stability:  experimental@@ -12,13 +12,19 @@       filterE,       scan,       scan',-      scanE+      scanE,+      splitE,+      unalignE,+      unlessE     )     where  import Control.Category import Control.Wire.Core+import Control.Wire.Internal+import Data.Align import Data.Profunctor+import Data.These import Prelude hiding ((.), id)  @@ -45,6 +51,32 @@  scanE :: (Applicative m) => a -> Wire m (Event (a -> a)) (Event a) scanE = lmap (fmap $ \f x -> let y = f x in (y, y)) . unfoldE+++-- | Split the given event++splitE :: Event (Either a b) -> (Event a, Event b)+splitE NotNow          = (NotNow, NotNow)+splitE (Now (Left x))  = (Now x,  NotNow)+splitE (Now (Right y)) = (NotNow, Now y)+++-- | Split the given event+--+-- Inverse of 'align'.++unalignE :: Event (These a b) -> (Event a, Event b)+unalignE NotNow            = (NotNow, NotNow)+unalignE (Now (This x))    = (Now x,  NotNow)+unalignE (Now (That y))    = (NotNow, Now y)+unalignE (Now (These x y)) = (Now x,  Now y)+++-- | Event difference: like the left event, but only when the right+-- event doesn't occur at the same time.++unlessE :: Event a -> Event b -> Event a+unlessE mx my = catMapE justThis (align mx my)   -- | Run the given action to initialise the given wire.  Simplified
examples/Utils.hs view
@@ -20,8 +20,7 @@ -- occurrences.  average :: (Fractional a, Monad m) => Int -> Wire m (Event a) (Event a)-average n =-    lmap (fmap go) (unfoldE Seq.empty)+average n = lmap (fmap go) (unfoldE Seq.empty)     where     go x xs' =         let xs = Seq.take n (x Seq.<| xs')
+ examples/feedback.hs view
@@ -0,0 +1,23 @@+-- |+-- Copyright:  (c) 2017 Ertugrul Söylemez+-- License:    BSD3+-- Maintainer: Ertugrul Söylemez <esz@posteo.de>++{-# LANGUAGE Arrows #-}++module Main (main) where++import Control.Concurrent+import Control.Wire+import Control.Wire.Controller+++main :: IO ()+main =+    control $ proc _ -> do+        ev <- newEvent -< do+            Just () <$ threadDelay 500000++        rec x <- scan 1 -< x `seq` (+ x) <$ ev++        animate -< never <$ print x
wires.cabal view
@@ -1,11 +1,11 @@ name:     wires-version:  0.1.0+version:  0.2.0 category: Control, FRP synopsis: Functional reactive programming library  maintainer:   Ertugrul Söylemez <esz@posteo.de> author:       Ertugrul Söylemez <esz@posteo.de>-copyright:    Copyright 2016 Ertugrul Söylemez+copyright:    Copyright 2017 Ertugrul Söylemez homepage:     https://github.com/esoeylemez/wires bug-reports:  https://github.com/esoeylemez/wires/issues license:      BSD3@@ -29,20 +29,34 @@  library     build-depends:-        base                >= 4.8 && < 5,-        deepseq             >= 1.4 && < 2,-        profunctors         >= 5.2 && < 6,-        semigroupoids       >= 5.1 && < 6,-        these               >= 0.7 && < 1+        base >= 4.8 && < 5,+        deepseq == 1.4.*,+        mtl >= 2.0 && < 2.3,+        profunctors >= 5.0 && < 5.3,+        semigroupoids >= 5.0 && < 5.2,+        these == 0.7.*     default-language: Haskell2010-    ghc-options: -W -fdefer-typed-holes+    ghc-options: -W     exposed-modules:         Control.Wire         Control.Wire.Controller         Control.Wire.Core         Control.Wire.Internal+        Control.Wire.Trans         Control.Wire.Utils         Control.Wire.Varying++executable wires-feedback+    if flag(examples)+        build-depends:+            base >= 4.8 && < 5,+            wires+    else+        buildable: False+    default-language: Haskell2010+    ghc-options: -threaded -fdefer-typed-holes+    hs-source-dirs: examples+    main-is: feedback.hs  executable wires-ping-pong     if flag(examples)