mvc-updates 1.0.0 → 1.1.0
raw patch · 2 files changed
+153/−90 lines, 2 filesdep −transformersdep ~foldldep ~mvc
Dependencies removed: transformers
Dependency ranges changed: foldl, mvc
Files
- mvc-updates.cabal +7/−8
- src/MVC/Updates.hs +146/−82
mvc-updates.cabal view
@@ -1,5 +1,5 @@ Name: mvc-updates-Version: 1.0.0+Version: 1.1.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3@@ -9,8 +9,8 @@ Maintainer: Gabriel439@gmail.com Bug-Reports: https://github.com/Gabriel439/Haskell-MVC-Updates-Library/issues Synopsis: Concurrent and combinable updates-Description: Use the @mvc-updates@ library to build programs with continously- updating inputs.+Description: Use the @mvc-updates@ library to build programs with multiple+ continously updating inputs where you can attach listeners to updates. . Key features include: .@@ -27,10 +27,9 @@ Library Hs-Source-Dirs: src Build-Depends:- base >= 4 && < 5 ,- async >= 2.0.0 && < 2.1,- foldl >= 1.0.0 && < 1.1,- mvc >= 1.0.0 && < 1.1,- transformers >= 0.2.0.0 && < 0.5+ base >= 4 && < 5 ,+ async >= 2.0.0 && < 2.1,+ foldl >= 1.0.6 && < 1.1,+ mvc < 1.1 Exposed-Modules: MVC.Updates GHC-Options: -O2 -Wall
src/MVC/Updates.hs view
@@ -9,6 +9,8 @@ * data visualizations. + * build systems+ This library builds on top of the @mvc@ library, so you may want to read the documentation in the "MVC" module if you haven't already. @@ -16,33 +18,26 @@ > import Control.Applicative ((<$>), (<*>)) > import Control.Foldl (last, length)-> import MVC-> import MVC.Updates+> import MVC.Updates (Updatable, on, listen, runUpdatable) > import MVC.Prelude (stdinLines, tick)-> import qualified Pipes.Prelude as Pipes > import Prelude hiding (last, length)-> +> > data Example = Example (Maybe String) Int deriving (Show) >+> debug :: Show a => String -> Updatable a -> Updatable a+> debug label = listen (\x -> putStrLn (label ++ ": " ++ show x))+> > lastLine :: Updatable (Maybe String)-> lastLine = On last stdinLines+> lastLine = debug "lastLine" (on last stdinLines) >-> seconds :: Updatable Int-> seconds = On length (tick 1.0)+> seconds :: Updatable Int+> seconds = debug "seconds " (on length (tick 1.0)) >-> example :: Updatable Example-> example = Example <$> lastLine <*> seconds-> -> viewController :: Managed (View Example, Controller Example)-> viewController = do-> controller <- updates Unbounded example-> return (asSink print, controller)-> -> model :: Model () Example Example-> model = asPipe $ Pipes.takeWhile (\(Example str _) -> str /= Just "quit")-> +> example :: Updatable Example+> example = debug "example " (Example <$> lastLine <*> seconds)+> > main :: IO ()-> main = runMVC () model viewController+> main = runUpdatable example First we build two simple `Updatable` values: @@ -50,27 +45,40 @@ * @seconds@ increments every second - Then we assemble them into a derived `Updatable` value using `Applicative`- operations. This derived value updates every time one of the two primitive- values updates:+ Additionally, the `debug` function attaches a listener to each value that+ prints updates to the console. Every listener triggers once at the+ beginning of the program and once for each update to the attached value. + Then we assemble these two `Updatable` values into a derived `Updatable`+ value using `Applicative` operations. This derived value updates every+ time one of the two original values updates:+ > $ ./example-> Example Nothing 0+> lastLine: Nothing+> seconds : 0+> example : Example Nothing 0 > Test<Enter>-> Example (Just "Test") 0-> Example (Just "Test") 1-> Example (Just "Test") 2+> lastLine: Just "Test"+> example : Example (Just "Test") 0+> seconds : 1+> example : Example (Just "Test") 1+> seconds : 2+> example : Example (Just "Test") 2 > ABC<Enter>-> Example (Just "ABC") 2-> Example (Just "ABC") 3-> quit<Enter>-> $+> lastLine: Just "ABC"+> example : Example (Just "ABC") 2+> seconds : 3+> example : Example (Just "ABC") 3+> ... - Every time the user types in a new line of input the @controller@ emits a- new @Example@ value that overrides the first field. Similarly, every time- one second passes the @controller@ emits a new @Example@ value that- overrides the second field.+ At the beginning of the program we see one debug output for each value's+ initialization. Afterwards, we see updates every time the user enters a+ line of input or one second passes. + Updates are efficient. When the user enters a new line, the `Example` value+ reuses the cached value for seconds. Similarly, when one second passes, the+ `Example` reuses the cached value for the last line.+ The Example section at the bottom of this module contains an extended example for how to build a GTK-based spreadsheet using this library. -}@@ -79,6 +87,10 @@ -- * Updates -- $updates Updatable(..)+ , on+ , listen+ , transform+ , runUpdatable , updates -- * Example@@ -90,11 +102,14 @@ ) where import Control.Applicative (Applicative(pure, (<*>)), (<*))+import Control.Category (id) import Control.Concurrent.Async (withAsync)-import Control.Foldl (Fold(..))-import Control.Monad (forever)-import Control.Monad.Trans.State.Strict (get, put)+import Control.Foldl (FoldM(..), Fold(..))+import qualified Control.Foldl as Foldl+import Control.Monad ((>=>))+import Data.IORef (newIORef, readIORef, writeIORef) import MVC+import Prelude hiding (id) {- $updates You can combine smaller updates into larger updates using `Applicative`@@ -113,10 +128,9 @@ This caching behavior transitively works for any number of updates that you combine using `Applicative` operations. Also, the internal code is- efficient and only introduces one extra thread no matter how many updates- you combine. You can even skip the extra thread if you unpack the `Fold`- type and use the fields directly within your @mvc@ program. Study the- source code for `updates` to see this in action.+ efficient and does not introduce any new threads no matter how many updates+ you combine. (Note: the `updates` function does introduce one additional+ thread) Tip: To efficiently merge a large number of updates, store them in a `Data.Sequence.Seq` and use `Data.Foldable.sequenceA` to merge them:@@ -125,67 +139,113 @@ -} -- | A concurrent, updatable value-data Updatable a = forall e . On (Fold e a) (Managed (Controller e))+data Updatable a = forall e . On (FoldM IO e a) (Managed (Controller e)) instance Functor Updatable where fmap f (On fold mController) = On (fmap f fold) mController -{--> onLeft (f <*> x) = onLeft f <*> onLeft x->-> onLeft (pure r) = pure r--}-onLeft :: Fold a b -> Fold (Either a x) b-onLeft (Fold step begin done) = Fold step' begin done- where- step' x (Left a) = step x a- step' x _ = x+-- _Left :: Traversable' (Either a b) a+_Left :: Applicative f => (a -> f a) -> (Either a b -> f (Either a b))+_Left k e = case e of+ Left a -> fmap Left (k a)+ Right b -> pure (Right b) -{--> onRight (f <*> x) = onRight f <*> onRight x->-> onRight (pure r) = pure r--}-onRight :: Fold a b -> Fold (Either x a) b-onRight (Fold step begin done) = Fold step' begin done- where- step' x (Right a) = step x a- step' x _ = x+-- _Right :: Traversable' (Either a b) b+_Right :: Applicative f => (b -> f b) -> (Either a b -> f (Either a b))+_Right k e = case e of+ Left a -> pure (Left a)+ Right b -> fmap Right (k b) instance Applicative Updatable where pure a = On (pure a) mempty (On foldL mControllerL) <*> (On foldR mControllerR) = On foldT mControllerT where- foldT = onLeft foldL <*> onRight foldR+ foldT =+ Foldl.pretraverseM _Left foldL <*> Foldl.pretraverseM _Right foldR mControllerT = fmap (fmap Left) mControllerL <> fmap (fmap Right) mControllerR +-- | Create an `Updatable` value using a pure `Fold`+on :: Fold e a -> Managed (Controller e) -> Updatable a+on fold = On (Foldl.generalize fold)+{-# INLINABLE on #-}++{-| Attach a listener that runs every time an `Updatable` value updates++> -- Treating `a -> IO ()` as the `View a` `Monoid`:+>+> listen mempty = id+>+> listen (f <> g) = listen g . listen f+-}+listen :: (a -> IO ()) -> Updatable a -> Updatable a+listen f = transform (\a -> do+ f a+ return a )+{-# INLINABLE listen #-}++{-| Transform an `Updatable` value using an impure function++> transform return = id+>+> transform (f >=> g) = transform g . transform f+-}+transform :: (a -> IO b) -> Updatable a -> Updatable b+transform f (On (FoldM step begin done ) mController) =+ On (FoldM step begin (done >=> f)) mController+{-# INLINABLE transform #-}++{-| Run an `Updatable` value, discarding the result++ Use this if you only care about running the associated listeners+-}+runUpdatable :: Updatable a -> IO ()+runUpdatable (On (FoldM step begin done) mController) = runMVC () id $ do+ controller <- mController++ ioref <- liftIO $ do+ x <- begin+ _ <- done x+ newIORef x++ let view = asSink $ \e -> do+ x <- readIORef ioref+ x' <- step x e+ _ <- done x'+ writeIORef ioref x'++ return (view, controller)+{-# INLINABLE runUpdatable #-}+ {-| Convert an `Updatable` value to a `Managed` `Controller` that emits updates You must specify how to `Buffer` the updates -} updates :: Buffer a -> Updatable a -> Managed (Controller a)-updates buffer (On (Fold step begin done) mController) = do+updates buffer (On (FoldM step begin done) mController) = do controller <- mController managed $ \k -> do (o, i, seal) <- spawn' buffer- - let model_ = asPipe $ forever $ do- x <- lift get- yield (done x)- e <- await- lift $ put $! step x e- - view_ = asSink $ \a -> do- _ <- atomically (send o a)- return ()- ++ ioref <- liftIO $ do+ x <- begin+ a <- done x+ _ <- atomically $ send o a+ newIORef x++ let view = asSink $ \e -> do+ x <- readIORef ioref+ x' <- step x e+ a <- done x'+ _ <- atomically $ send o a+ writeIORef ioref x'+ let io = do- _ <- runMVC begin model_ (pure (view_, controller))+ _ <- runMVC begin id (pure (view, controller)) atomically seal- + withAsync io $ \_ -> k (asInput i) <* atomically seal -- $example@@ -193,6 +253,10 @@ -- The following example program shows how to build a spreadsheet with input and -- output cells using the @gtk@, @mvc@ and @mvc-updates@ libraries. --+-- You can find this and other examples on:+--+-- <https://github.com/Gabriel439/Haskell-MVC-Updates-Examples-Library>+-- -- The first half of the program contains all the @gtk@-specific logic. The -- key function is @spreadsheet@, which returns high-level commands to build -- multiple input and output cells.@@ -205,13 +269,13 @@ -- > import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -- > import Control.Concurrent.Async (async, wait) -- > import Control.Foldl (lastDef)--- > import Graphics.UI.Gtk+-- > import Graphics.UI.Gtk as GTK -- > import Lens.Family.TH (makeLenses) -- > import MVC--- > import MVC.Updates+-- > import MVC.Updates as MVC -- > -- > makeInCell :: VBox -> Updatable Double--- > makeInCell vBox = On (lastDef 0) $ managed $ \k -> do+-- > makeInCell vBox = MVC.on (lastDef 0) $ managed $ \k -> do -- > (output, input) <- spawn Unbounded -- > spinButton <- spinButtonNewWithRange 0 100 1 -- > onValueSpinned spinButton $ do@@ -243,7 +307,7 @@ -- > a <- async $ k (makeInCell vBoxL, makeOutCell vBoxR, putMVar mvar ()) -- > takeMVar mvar -- > --- > on window deleteEvent $ do+-- > GTK.on window deleteEvent $ do -- > liftIO mainQuit -- > return False -- > widgetShowAll window@@ -289,5 +353,5 @@ -- will automatically update all output cells. {- $reexports- "Control.Foldl" re-exports the `Fold` type+ "Control.Foldl" re-exports the `Fold` and `FoldM` types -}