packages feed

reactive-banana 1.2.1.0 → 1.2.2.0

raw patch · 13 files changed

+162/−76 lines, 13 filesdep +thesedep ~hashabledep ~semigroups

Dependencies added: these

Dependency ranges changed: hashable, semigroups

Files

CHANGELOG.md view
@@ -1,6 +1,28 @@ Changelog for the `reactive-banana** package ------------------------------------------- +**Version 1.2.2.0**++* Optimize the implementation of `Graph.listParents` [#209][]+* Replace a use of `foldl` with `foldl'`. [#212][]+* Simplify the internal `mkWeakIORef` function. [#154][]+* Add `merge` and `mergeWith` combinators. [#163][], [#220][]+* Make internal SCC pragmas compatible with the GHC 9.0 parser. [#208][]+* Change `insertWith (flip (++))` to `insertWith (++)` in `insertEdge`. [#211][]+* Add `Semigroup a => Semigroup (Behavior a)` and `Monoid a => Monoid (Behavior a)` instances. [#185][]+* Loosen the upper-bound for `hashable` and `semigroups`. [#205][]++  [#154]: https://github.com/HeinrichApfelmus/reactive-banana/pull/154+  [#163]: https://github.com/HeinrichApfelmus/reactive-banana/pull/163+  [#185]: https://github.com/HeinrichApfelmus/reactive-banana/pull/185+  [#205]: https://github.com/HeinrichApfelmus/reactive-banana/pull/205+  [#208]: https://github.com/HeinrichApfelmus/reactive-banana/pull/208+  [#209]: https://github.com/HeinrichApfelmus/reactive-banana/pull/209+  [#211]: https://github.com/HeinrichApfelmus/reactive-banana/pull/211+  [#212]: https://github.com/HeinrichApfelmus/reactive-banana/pull/212+  [#220]: https://github.com/HeinrichApfelmus/reactive-banana/pull/219++ **version 1.2.1.0**  * Add `Num`, `Floating`, `Fractional`, and `IsString` instances for `Behavior`. [#34][]
reactive-banana.cabal view
@@ -1,5 +1,5 @@ Name:                reactive-banana-Version:             1.2.1.0+Version:             1.2.2.0 Synopsis:            Library for functional reactive programming (FRP). Description:     Reactive-banana is a library for Functional Reactive Programming (FRP).@@ -36,7 +36,7 @@  Source-repository head     type:               git-    location:           git://github.com/HeinrichApfelmus/reactive-banana.git+    location:           https://github.com/HeinrichApfelmus/reactive-banana     subdir:             reactive-banana/  Library@@ -44,13 +44,14 @@     hs-source-dirs:     src      build-depends:      base >= 4.2 && < 5,-                        semigroups >= 0.13 && < 0.19,+                        semigroups >= 0.13 && < 0.20,                         containers >= 0.5 && < 0.7,                         transformers >= 0.2 && < 0.6,                         vault == 0.3.*,                         unordered-containers >= 0.2.1.0 && < 0.3,-                        hashable >= 1.1 && < 1.3,-                        pqueue >= 1.0 && < 1.5+                        hashable >= 1.1 && < 1.4,+                        pqueue >= 1.0 && < 1.5,+                        these >= 0.2 && < 1.2      exposed-modules:                         Control.Event.Handler,@@ -89,4 +90,4 @@                         test-framework-hunit >= 0.2 && < 0.4,                         reactive-banana, vault, containers,                         semigroups, transformers,-                        unordered-containers, hashable, psqueues, pqueue+                        unordered-containers, hashable, psqueues, pqueue, these
src/Reactive/Banana/Combinators.hs view
@@ -40,12 +40,15 @@     -- ** Accumulation     -- $Accumulation.     unions, accumB, mapAccum,+    -- ** Merging events+    merge, mergeWith     ) where  import Control.Applicative import Control.Monad import Data.Maybe          (isJust, catMaybes) import Data.Semigroup+import Data.These (These(..), these)  import qualified Reactive.Banana.Internal.Combinators as Prim import           Reactive.Banana.Types@@ -110,7 +113,23 @@ -- >    | timex >  timey = (timey,y)     : unionWith f ((timex,x):xs) ys -- >    | timex == timey = (timex,f x y) : unionWith f xs ys unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a-unionWith f e1 e2 = E $ Prim.unionWith f (unE e1) (unE e2)+unionWith f = mergeWith id id f++-- | Merge two event streams of any type.+merge :: Event a -> Event b -> Event (These a b)+merge = mergeWith This That These++-- | Merge two event streams of any type.+--+-- This function generalizes 'unionWith'.+mergeWith+  :: (a -> c) -- ^ The function called when only the first event emits a value.+  -> (b -> c) -- ^ The function called when only the second event emits a value.+  -> (a -> b -> c) -- ^ The function called when both events emit values simultaneously.+  -> Event a+  -> Event b+  -> Event c+mergeWith f g h e1 e2 = E $ Prim.mergeWith f g h (unE e1) (unE e2)  -- | Allow all event occurrences that are 'Just' values, discard the rest. -- Variant of 'filterE'.
src/Reactive/Banana/Internal/Combinators.hs view
@@ -16,6 +16,7 @@ import           Data.IORef import qualified Reactive.Banana.Prim        as Prim import           Reactive.Banana.Prim.Cached+import           Data.These (These(..), these)  type Build   = Prim.Build type Latch a = Prim.Latch a@@ -115,9 +116,16 @@ never :: Event a never = don'tCache  $ liftBuild $ Prim.neverP -unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a-unionWith f = liftCached2 $ (liftBuild .) . Prim.unionWithP f+mergeWith+  :: (a -> c)+  -> (b -> c)+  -> (a -> b -> c)+  -> Event a+  -> Event b+  -> Event c+mergeWith f g h = liftCached2 $ (liftBuild .) . Prim.mergeWithP (Just . f) (Just . g) (\x y -> Just (h x y)) + filterJust :: Event (Maybe a) -> Event a filterJust  = liftCached1 $ liftBuild . Prim.filterJustP @@ -137,7 +145,7 @@  applyB :: Behavior (a -> b) -> Behavior a -> Behavior b applyB = liftCached2 $ \(~(l1,p1)) (~(l2,p2)) -> liftBuild $ do-    p3 <- Prim.unionWithP const p1 p2+    p3 <- Prim.mergeWithP Just Just (const . Just) p1 p2     let l3 = Prim.applyL l1 l2     return (l3,p3) @@ -235,4 +243,4 @@         return (lr, pr)  merge :: Pulse () -> Pulse () -> Build (Pulse ())-merge = Prim.unionWithP (\_ _ -> ())+merge = Prim.mergeWithP Just Just (\_ _ -> Just ())
src/Reactive/Banana/Model.hs view
@@ -16,7 +16,7 @@     interpret,     -- ** First-order     module Control.Applicative,-    never, unionWith, filterJust, apply,+    never, unionWith, mergeWith, filterJust, apply,     -- ** Moment and accumulation     Moment(..), accumE, stepper,     -- ** Higher-order@@ -26,6 +26,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Fix+import Data.These (These(..), these)  {-$overview @@ -95,12 +96,24 @@ never = E $ repeat Nothing  unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a-unionWith f (E xs) (E ys) = E $ zipWith combine xs ys+unionWith = mergeWith id id++mergeWith+  :: (a -> c)+  -> (b -> c)+  -> (a -> b -> c)+  -> Event a+  -> Event b+  -> Event c+mergeWith f g h xs ys = these f g h <$> merge xs ys++merge :: Event a -> Event b -> Event (These a b)+merge (E xs) (E ys) = E $ zipWith combine xs ys     where-    combine (Just x) (Just y) = Just $ f x y-    combine (Just x) Nothing  = Just x-    combine Nothing  (Just y) = Just y     combine Nothing  Nothing  = Nothing+    combine (Just x) Nothing  = Just (This x)+    combine Nothing  (Just y) = Just (That y)+    combine (Just x) (Just y) = Just (These x y)  filterJust :: Event (Maybe a) -> Event a filterJust = E . fmap join . unE
src/Reactive/Banana/Prim.hs view
@@ -8,34 +8,34 @@     -- implemented your own FRP library.     -- If you just want to use FRP in your project,     -- have a look at "Reactive.Banana" instead.-    +     -- * Evaluation     Step, Network, emptyNetwork,-    +     -- * Build FRP networks     Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,     module Control.Monad.IO.Class,-    +     -- * Caching     module Reactive.Banana.Prim.Cached,-    +     -- * Testing     interpret, mapAccumM, mapAccumM_, runSpaceProfile,-    +     -- * IO     newInput, addHandler, readLatch,-    +     -- * Pulse     Pulse,-    neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, unionWithP,-    +    neverP, alwaysP, mapP, Future, tagFuture, unsafeMapIOP, filterJustP, mergeWithP,+     -- * Latch     Latch,     pureL, mapL, applyL, accumL, applyP,-    +     -- * Dynamic event switching     switchL, executeP, switchP-    +     -- * Notes     -- $recursion   ) where
src/Reactive/Banana/Prim/Combinators.hs view
@@ -26,7 +26,7 @@ ------------------------------------------------------------------------------} mapP :: (a -> b) -> Pulse a -> Build (Pulse b) mapP f p1 = do-    p2 <- newPulse "mapP" $ {-# SCC mapP #-} fmap f <$> readPulseP p1+    p2 <- newPulse "mapP" $ ({-# SCC mapP #-} fmap f <$> readPulseP p1)     p2 `dependOn` p1     return p2 @@ -43,14 +43,14 @@  filterJustP :: Pulse (Maybe a) -> Build (Pulse a) filterJustP p1 = do-    p2 <- newPulse "filterJustP" $ {-# SCC filterJustP #-} join <$> readPulseP p1+    p2 <- newPulse "filterJustP" $ ({-# SCC filterJustP #-} join <$> readPulseP p1)     p2 `dependOn` p1     return p2  unsafeMapIOP :: forall a b. (a -> IO b) -> Pulse a -> Build (Pulse b) unsafeMapIOP f p1 = do         p2 <- newPulse "unsafeMapIOP" $-            {-# SCC unsafeMapIOP #-} eval =<< readPulseP p1+            ({-# SCC unsafeMapIOP #-} eval =<< readPulseP p1)         p2 `dependOn` p1         return p2     where@@ -58,25 +58,30 @@     eval (Just x) = Just <$> liftIO (f x)     eval Nothing  = return Nothing -unionWithP :: forall a. (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)-unionWithP f px py = do-        p <- newPulse "unionWithP" $-            {-# SCC unionWithP #-} eval <$> readPulseP px <*> readPulseP py-        p `dependOn` px-        p `dependOn` py-        return p-    where-    eval :: Maybe a -> Maybe a -> Maybe a-    eval (Just x) (Just y) = Just (f x y)-    eval (Just x) Nothing  = Just x-    eval Nothing  (Just y) = Just y+mergeWithP+  :: (a -> Maybe c)+  -> (b -> Maybe c)+  -> (a -> b -> Maybe c)+  -> Pulse a+  -> Pulse b+  -> Build (Pulse c)+mergeWithP f g h px py = do+  p <- newPulse "mergeWithP" $+       ({-# SCC mergeWithP #-} eval <$> readPulseP px <*> readPulseP py)+  p `dependOn` px+  p `dependOn` py+  return p+  where     eval Nothing  Nothing  = Nothing+    eval (Just x) Nothing  = f x+    eval Nothing  (Just y) = g y+    eval (Just x) (Just y) = h x y  -- See note [LatchRecursion] applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b) applyP f x = do     p <- newPulse "applyP" $-        {-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x+        ({-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x)     p `dependOn` x     return p @@ -85,11 +90,11 @@  -- specialization of   mapL f = applyL (pureL f) mapL :: (a -> b) -> Latch a -> Latch b-mapL f lx = cachedLatch $ {-# SCC mapL #-} f <$> getValueL lx+mapL f lx = cachedLatch $ ({-# SCC mapL #-} f <$> getValueL lx)  applyL :: Latch (a -> b) -> Latch a -> Latch b applyL lf lx = cachedLatch $-    {-# SCC applyL #-} getValueL lf <*> getValueL lx+    ({-# SCC applyL #-} getValueL lf <*> getValueL lx)  accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a) accumL a p1 = do@@ -115,7 +120,7 @@  executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a) executeP p1 b = do-        p2 <- newPulse "executeP" $ {-# SCC executeP #-} eval =<< readPulseP p1+        p2 <- newPulse "executeP" $ ({-# SCC executeP #-} eval =<< readPulseP p1)         p2 `dependOn` p1         return p2     where
src/Reactive/Banana/Prim/Graph.hs view
@@ -5,7 +5,14 @@ ------------------------------------------------------------------------------} {-# language ScopedTypeVariables#-} -module Reactive.Banana.Prim.Graph where+module Reactive.Banana.Prim.Graph+  ( Graph+  , emptyGraph+  , insertEdge+  , getChildren+  , listParents+  , dfs+  ) where  import           Control.Monad import           Data.Functor.Identity@@ -18,8 +25,19 @@     Graphs and topological sorting ------------------------------------------------------------------------------} data Graph a = Graph-    { children :: Map.HashMap a [a]+    { -- | The mapping from each node to the set of nodes reachable by an out-edge. If a node has no out-edges, it is+      -- not a member of this map.+      --+      -- Invariant: the values are non-empty lists.+      children :: Map.HashMap a [a]+      -- | The Mapping from each node to the set of nodes reachable by an in-edge. If a node has no in-edges, it is not+      -- a member of this map.+      --+      -- Invariant: the values are non-empty lists.     , parents  :: Map.HashMap a [a]+      -- | The set of nodes.+      --+      -- Invariant: equals (key children `union` keys parents)     , nodes    :: Set.HashSet a     } @@ -30,8 +48,8 @@ -- | Insert an edge from the first node to the second node into the graph. insertEdge :: (Eq a, Hashable a) => (a,a) -> Graph a -> Graph a insertEdge (x,y) gr = gr-    { children = Map.insertWith (flip (++)) x [y] (children gr)-    , parents  = Map.insertWith (flip (++)) y [x] (parents  gr)+    { children = Map.insertWith (\new old -> new ++ old) x [y] (children gr)+    , parents  = Map.insertWith (\new old -> new ++ old) y [x] (parents  gr)     , nodes    = Set.insert x $ Set.insert y $ nodes gr     } @@ -47,9 +65,11 @@ listParents :: forall a. (Eq a, Hashable a) => Graph a -> [a] listParents gr = list     where-    -- all nodes without children+    -- all nodes without parents     ancestors :: [a]-    ancestors = [x | x <- Set.toList $ nodes gr, null (getParents gr x)]+    -- We can filter from `children`, because a node without incoming edges can only be in the graph if it has outgoing edges.+    ancestors    = [x | x <- Map.keys (children gr), not (hasParents x)]+    hasParents x = Map.member x (parents gr)     -- all nodes in topological order "parents before children"     list :: [a]     list = runIdentity $ dfs' ancestors (Identity . getChildren gr)
src/Reactive/Banana/Prim/OrderedBag.hs view
@@ -1,6 +1,6 @@ {-----------------------------------------------------------------------------     reactive-banana-    +     Implementation of a bag whose elements are ordered by arrival time. ------------------------------------------------------------------------------} {-# LANGUAGE TupleSections #-}@@ -34,7 +34,7 @@ -- comes after all elements in the bag, -- but before the other elements in the sequence. inserts :: (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a-inserts bag xs = foldl insert bag xs+inserts = foldl' insert  -- | Reorder a list of elements to appear as they were inserted into the bag. -- Remove any elements from the list that do not appear in the bag.
src/Reactive/Banana/Prim/Util.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-----------------------------------------------------------------------------     reactive-banana ------------------------------------------------------------------------------}@@ -50,17 +49,9 @@ {-----------------------------------------------------------------------------     Weak pointers ------------------------------------------------------------------------------}-mkWeakIORefValueFinalizer :: IORef a -> value -> IO () -> IO (Weak value)-#if MIN_VERSION_base(4,9,0)-mkWeakIORefValueFinalizer r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->-  case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)-#else-mkWeakIORefValueFinalizer r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->-  case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)-#endif- mkWeakIORefValue :: IORef a -> value -> IO (Weak value)-mkWeakIORefValue a b = mkWeakIORefValueFinalizer a b (return ())+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) val = GHC.IO $ \s ->+  case GHC.mkWeakNoFinalizer# r# val s of (# s1, w #) -> (# s1, GHC.Weak w #)  mkWeakRefValue :: MonadIO m => Ref a -> value -> m (Weak value) mkWeakRefValue (Ref ref _) v = liftIO $ mkWeakIORefValue ref v
src/Reactive/Banana/Test.hs view
@@ -3,7 +3,7 @@      Test cases and examples ------------------------------------------------------------------------------}-{-# LANGUAGE Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}+{-# LANGUAGE FlexibleContexts, Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}  import Control.Arrow import Control.Monad (when, join)@@ -33,7 +33,7 @@         [ testModelMatchM "counter"     counter         , testModelMatch "double"      double         , testModelMatch "sharing"     sharing-        , testModelMatch "unionFilter" unionFilter+        , testModelMatch "mergeFilter" mergeFilter         , testModelMatchM "recursive1A"  recursive1A         , testModelMatchM "recursive1B"  recursive1B         , testModelMatchM "recursive2"  recursive2@@ -111,14 +111,14 @@     bcounter <- accumB 0 $ fmap (\_ -> (+1)) e     return $ applyE (pure const <*> bcounter) e -merge e1 e2 = unionWith (++) (list e1) (list e2)+merge e1 e2 = mergeWith id id (++) (list e1) (list e2)     where list = fmap (:[])  double e  = merge e e sharing e = merge e1 e1     where e1 = filterE (< 3) e -unionFilter e1 = unionWith (+) e2 e3+mergeFilter e1 = mergeWith id id (+) e2 e3     where     e3 = fmap (+1) $ filterE even e1     e2 = fmap (+1) $ filterE odd  e1@@ -245,9 +245,9 @@         fmappedEvent  = fmap id (filteredEvent)     lastValue <- stepper 1 $ fmappedEvent -    let outputEvent = unionWith (++)+    let outputEvent = mergeWith id id (++)             (const "filtered event" <$> filteredEvent)-            (((" and " ++) . show) <$> unionWith (+) appliedEvent fmappedEvent)+            (((" and " ++) . show) <$> mergeWith id id (+) appliedEvent fmappedEvent)      return $ outputEvent
src/Reactive/Banana/Test/Plumbing.hs view
@@ -41,11 +41,11 @@ {-----------------------------------------------------------------------------     Primitive combinators ------------------------------------------------------------------------------}-never                           = E X.never Y.never-filterJust (E x y)              = E (X.filterJust x) (Y.filterJust y)-unionWith f (E x1 y1) (E x2 y2) = E (X.unionWith f x1 x2) (Y.unionWith f y1 y2)-mapE f (E x y)                  = E (fmap f x) (Y.mapE f y)-applyE ~(B x1 y1) (E x2 y2)     = E (X.apply x1 x2) (Y.applyE y1 y2)+never                               = E X.never Y.never+filterJust (E x y)                  = E (X.filterJust x) (Y.filterJust y)+mergeWith f g h (E x1 y1) (E x2 y2) = E (X.mergeWith f g h x1 x2) (Y.mergeWith f g h y1 y2)+mapE f (E x y)                      = E (fmap f x) (Y.mapE f y)+applyE ~(B x1 y1) (E x2 y2)         = E (X.apply x1 x2) (Y.applyE y1 y2)  instance Functor Event where fmap = mapE
src/Reactive/Banana/Types.hs view
@@ -52,7 +52,7 @@ -- > (<>) :: Event a -> Event a -> Event a -- > (<>) ex ey = unionWith (<>) ex ey instance Semigroup a => Semigroup (Event a) where-    x <> y = E $ Prim.unionWith (<>) (unE x) (unE y)+    x <> y = E $ Prim.mergeWith id id (<>) (unE x) (unE y)  -- | The combinator 'mempty' represents an event that never occurs. -- It is a synonym,@@ -93,6 +93,13 @@ -- > fmap f b = \time -> f (b time) instance Functor Behavior where     fmap = liftA++instance Semigroup a => Semigroup (Behavior a) where+  (<>) = liftA2 (<>)++instance (Semigroup a, Monoid a) => Monoid (Behavior a) where+  mempty = pure mempty+  mappend = (<>)  instance Num a => Num (Behavior a) where     (+) = liftA2 (+)