diff --git a/mvc-updates.cabal b/mvc-updates.cabal --- a/mvc-updates.cabal +++ b/mvc-updates.cabal @@ -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 diff --git a/src/MVC/Updates.hs b/src/MVC/Updates.hs --- a/src/MVC/Updates.hs +++ b/src/MVC/Updates.hs @@ -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 -> 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 -> Example (Just "ABC") 2 -> Example (Just "ABC") 3 -> quit -> $ +> 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: +-- +-- +-- -- 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 -}