glazier-pipes 0.1.1.0 → 0.1.4.0

raw patch · 4 files changed

+130/−9 lines, 4 filesdep +mmorphdep +pipes-concurrencydep +stmdep ~glazierdep ~pipes-miscPVP ok

version bump matches the API change (PVP)

Dependencies added: mmorph, pipes-concurrency, stm, stm-extras

Dependency ranges changed: glazier, pipes-misc

API changes (from Hackage documentation)

Files

• glazier-pipes.cabal +8/−3
• src/Glazier/Pipes/Lazy.hs +23/−3
• src/Glazier/Pipes/Strict.hs +26/−3
• src/Glazier/Pipes/Ui.hs +73/−0

@@ -1,5 +1,5 @@ name:                glazier-pipes-version:             0.1.1.0+version:             0.1.4.0 synopsis:            Converts Glazier widgets into a Pipe. description:         Please see README.md homepage:            https://github.com/louispan/glazier-pipes#readme@@ -18,12 +18,17 @@   hs-source-dirs:      src   exposed-modules:     Glazier.Pipes.Lazy                        Glazier.Pipes.Strict+                       Glazier.Pipes.Ui   build-depends:       base >= 4.7 && < 5-                     , glazier >= 0.6 && < 1+                     , glazier >= 0.7 && < 1                      , lens >= 4 && < 5+                     , mmorph >= 1 && < 2                      , mtl >= 2 && < 3                      , pipes >= 4 && < 5-                     , pipes-misc >= 0.2 && < 1+                     , pipes-concurrency >= 2 && < 3+                     , pipes-misc >= 0.2.3 && < 1+                     , stm >= 2.4 && < 3+                     , stm-extras > 0.1 &&  < 1                      , transformers >= 0.4 && < 0.6   ghc-options:         -Wall   default-language:    Haskell2010

@@ -1,15 +1,35 @@+{-# LANGUAGE RankNTypes #-}+ module Glazier.Pipes.Lazy where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TMVar.Extras as STE+import Control.Lens+import Control.Monad.Morph import Control.Monad.State.Lazy-import qualified Glazier.Lazy as G+import Control.Monad.Trans.Maybe+import qualified Glazier.Gadget.Lazy as G import qualified Pipes as P-import Control.Lens+import qualified Pipes.Concurrent as PC+import qualified Pipes.Lift as PL+import qualified Pipes.Misc.Concurrent as PM+import qualified Pipes.Misc.State.Lazy as PM --- | Converts a Gadget into a Pipe+-- | Converts a 'Glazier.Gadget' into a 'Pipes.Pipe' gadgetToPipe :: (Monad m, MonadTrans t, MonadState s (t m)) => G.Gadget s m a c -> P.Pipe a c (t m) r gadgetToPipe g = forever $ do     a <- P.await     s <- get+    -- This is the only line that is different between the Strict and Lazy version     ~(c, s') <- lift . lift $ view G._Gadget g a s     put s'     P.yield c+{-# INLINABLE gadgetToPipe #-}++-- | Convert a 'Pipes.Concurrent.Input' and a 'Glazier.Gadget' into a stateful 'Pipes.Producer' of commands to interpret.+gadgetToProducer ::+  (MonadState s (t STM), MonadTrans t) =>+  PC.Input a -> G.Gadget s STM a c -> P.Producer' c (t STM) ()+gadgetToProducer input g = hoist lift (PM.fromInputSTM input) P.>-> gadgetToPipe g+{-# INLINABLE gadgetToProducer #-}

@@ -1,15 +1,38 @@+{-# LANGUAGE RankNTypes #-}+ module Glazier.Pipes.Strict where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TMVar.Extras as STE+import Control.Lens+import Control.Monad.Morph import Control.Monad.State.Strict-import qualified Glazier.Strict as G+import Control.Monad.Trans.Maybe+import qualified Glazier.Gadget.Strict as G import qualified Pipes as P-import Control.Lens+import qualified Pipes.Concurrent as PC+import qualified Pipes.Lift as PL+import qualified Pipes.Misc.Concurrent as PM+import qualified Pipes.Misc.State.Strict as PM+import qualified Pipes.Prelude as PP+import qualified Pipes.Internal as PI --- | Converts a Gadget into a Pipe++-- | Converts a 'Glazier.Gadget' into a 'Pipes.Pipe' gadgetToPipe :: (Monad m, MonadTrans t, MonadState s (t m)) => G.Gadget s m a c -> P.Pipe a c (t m) r gadgetToPipe g = forever $ do     a <- P.await     s <- get+    -- This is the only line that is different between the Strict and Lazy version     (c, s') <- lift . lift $ view G._Gadget g a s     put s'     P.yield c+{-# INLINABLE gadgetToPipe #-}++-- | Convert a 'Pipes.Concurrent.Input' and a 'Glazier.Gadget' into a stateful 'Pipes.Producer' of commands to interpret.+gadgetToProducer ::+  (MonadState s (t STM), MonadTrans t) =>+  PC.Input a -> G.Gadget s STM a c -> P.Producer' c (t STM) ()+gadgetToProducer input g = hoist lift (PM.fromInputSTM input) P.>-> gadgetToPipe g+{-# INLINABLE gadgetToProducer #-}

@@ -0,0 +1,73 @@+{-# LANGUAGE RankNTypes #-}++module Glazier.Pipes.Ui where++import Control.Concurrent.STM+import Control.Concurrent.STM.TMVar.Extras as STE+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Morph+import Control.Monad.Trans.Maybe+import qualified Pipes as P+import qualified Pipes.Prelude as PP++-- | This is similar to part of the Elm startApp.+-- This is responsible for running the Glazier Gadget update tick until it quits.+-- This is also responsible for rendering the frame.+runUi :: (MonadIO io) =>+     Int+  -> (s -> IO ()) -- render+  -> P.Producer s io s+  -> io s+runUi refreshDelay render appSignal = do+    -- framerate thread+    -- TMVar to indicate that the render thread can render, start non empty so we can render straight away.+    triggerRender <- liftIO $ newTMVarIO ()+    frameRateThread <-+        liftIO $+        forkIO . void . forever $+        -- The will ensure a refreshDelay in between times when value in canRender is taken.+        -- wait until canRender is empty (ie taken by the render thread)+         do+            atomically $ STE.waitTillEmptyTMVar triggerRender ()+            -- if empty, then wait delay before filling TMVar with next canRender value+            threadDelay refreshDelay+            atomically $ putTMVar triggerRender ()++    -- render thread+    enableRenderThread <- liftIO $ newTMVarIO ()+    finishedRenderThread <- liftIO newEmptyTMVarIO+    latestState <- liftIO newEmptyTMVarIO+    void . liftIO $+        forkFinally+            (void . runMaybeT . forever $+              -- check if we can start render+              do+                 liftIO . atomically . void $ takeTMVar triggerRender+                 -- to allow rendering of last frame before quitting+                 -- if there is no state to render, check if rendering is disabled+                 s <-+                     MaybeT . liftIO . atomically $+                     (Just <$> takeTMVar latestState) `orElse` do+                         r <- tryReadTMVar enableRenderThread+                         case r of+                             Nothing -> pure Nothing -- breaks (runMaybeT . forever) loop+                             Just _ -> retry+                 lift $ render s)+            (const . atomically $ putTMVar finishedRenderThread ())++    -- This is different between the Strict and Lazy version+    s' <- P.runEffect $+        appSignal P.>-> PP.mapM+            (liftIO . atomically . void . STE.forceSwapTMVar latestState) P.>-> PP.drain+    -- cleanup+    -- allow rendering of the frame one last time+    liftIO . atomically $ takeTMVar enableRenderThread+    -- wait for render thread to finish before exiting+    liftIO . atomically $ takeTMVar finishedRenderThread+    -- kill frameRateThread only after render thread has finished+    -- since renderThread waits on triggers from frameRateThread+    liftIO $ killThread frameRateThread+    -- return final state+    liftIO $ pure s'