diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -1,5 +1,5 @@ name: Plot-ho-matic -version: 0.11.0.0 +version: 0.11.1.0 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE diff --git a/examples/SetExample.hs b/examples/SetExample.hs --- a/examples/SetExample.hs +++ b/examples/SetExample.hs @@ -38,19 +38,19 @@ main :: IO () main = do - upMsg <- CC.newEmptyMVar :: IO (CC.MVar (Maybe DTree)) - downMsg <- CC.newEmptyMVar :: IO (CC.MVar DTree) + upMsg <- CC.newEmptyMVar :: IO (CC.MVar (Maybe (Int, DTree))) + downMsg <- CC.newEmptyMVar :: IO (CC.MVar (Int, DTree)) counterVar <- CC.newMVar (0::Int) let upstreamProcess = do - upValue <- CC.newMVar (Left (initialFoo {foo2 = 999})) :: IO (CC.MVar (Either (Foo Bar) (Foo Int))) + upValue <- CC.newMVar (0, Left (initialFoo {foo2 = 999})) :: IO (CC.MVar (Int, Either (Foo Bar) (Foo Int))) let sendState = do - x <- CC.readMVar upValue :: IO (Either (Foo Bar) (Foo Int)) + (k, x) <- CC.readMVar upValue :: IO (Int, Either (Foo Bar) (Foo Int)) putStrLn " upstream sending state" let d = case x of Left r -> toDData r Right r -> toDData r - CC.putMVar downMsg d + CC.putMVar downMsg (k, d) forever $ do putStrLn " upstream waiting for message" @@ -64,45 +64,48 @@ putStrLn $ " upstream count: " ++ show count when (mod count 3 == 0) $ do putStrLn " upstream swapping data" - let swapData (Left _) = Right initialBar - swapData (Right _) = Left initialFoo + let swapData (k, Left _) = (k, Right initialBar) + swapData (k, Right _) = (k, Left initialFoo) CC.modifyMVar_ upValue (return . swapData) sendState - Just newDVal -> do + Just (newK, newDVal) -> do putStrLn " upstream got commit request" CC.threadDelay 500000 - let modify (Left oldVal) = case updateLookupable oldVal newDVal of - Right newVal -> return (Left newVal) + let modify (oldK, Left oldVal) = case updateLookupable oldVal newDVal of + Right newVal -> return (newK, Left newVal) Left err -> do putStrLn $ " upstream got update error:\n" ++ " " ++ err putStrLn "newDVal:" print newDVal - return (Left oldVal) - modify (Right oldVal) = case updateLookupable oldVal newDVal of - Right newVal -> return (Right newVal) + return (oldK, Left oldVal) + modify (oldK, Right oldVal) = case updateLookupable oldVal newDVal of + Right newVal -> return (newK, Right newVal) Left err -> do putStrLn $ " upstream got update error:\n" ++ " " ++ err - return (Right oldVal) + return (oldK, Right oldVal) CC.modifyMVar_ upValue modify sendState void $ CC.forkIO upstreamProcess - let refresh = do + let refresh :: IO () + refresh = do putStrLn "downstream sending refresh request" CC.putMVar upMsg Nothing - commit x = void $ do + commit :: Int -> DTree -> IO () + commit k x = void $ do putStrLn "downstream starting to commit" CC.threadDelay 500000 - void $ CC.putMVar upMsg (Just x) + void $ CC.putMVar upMsg (Just (k, x)) putStrLn "downstream finished commit" + pollForNewMessage :: IO (Maybe (Int, DTree)) pollForNewMessage = do mx <- CC.tryTakeMVar downMsg case mx of diff --git a/src/PlotHo/OptionsWidget.hs b/src/PlotHo/OptionsWidget.hs --- a/src/PlotHo/OptionsWidget.hs +++ b/src/PlotHo/OptionsWidget.hs @@ -96,10 +96,13 @@ resetXHistoryButton <- Gtk.buttonNewWithLabel "reset X range" resetYHistoryButton <- Gtk.buttonNewWithLabel "reset Y range" - void $ on resetXHistoryButton Gtk.buttonActivated $ - CC.modifyMVar_ largestRangeMVar (\xy -> return (xy {xaxis = defaultHistoryRange})) - void $ on resetYHistoryButton Gtk.buttonActivated $ - CC.modifyMVar_ largestRangeMVar (\xy -> return (xy {yaxis = defaultHistoryRange})) + on resetXHistoryButton Gtk.buttonActivated $ do + void $ CC.modifyMVar_ largestRangeMVar (\xy -> return (xy {xaxis = defaultHistoryRange})) + redraw + + on resetYHistoryButton Gtk.buttonActivated $ do + void $ CC.modifyMVar_ largestRangeMVar (\xy -> return (xy {yaxis = defaultHistoryRange})) + redraw -- vbox to hold the little window on the left vbox <- Gtk.vBoxNew False 4 diff --git a/src/PlotHo/SignalSelector.hs b/src/PlotHo/SignalSelector.hs --- a/src/PlotHo/SignalSelector.hs +++ b/src/PlotHo/SignalSelector.hs @@ -269,7 +269,8 @@ } - +-- TODO(greg): tests +-- swashRotorCommands.c{ollective, yclicPitch, yclicRoll} -- The greatest common prefix will be the title. -- Everything after that is the field name. gettersAndTitle :: forall a . [([String], a)] -> ([(String, a)], Maybe String) diff --git a/src/SetHo.hs b/src/SetHo.hs --- a/src/SetHo.hs +++ b/src/SetHo.hs @@ -14,6 +14,7 @@ import qualified Control.Concurrent as CC import Control.Monad.IO.Class ( liftIO ) import qualified Data.ByteString.Lazy as BSL +import Data.IORef ( newIORef, readIORef, writeIORef ) import Data.Serialize ( encodeLazy, decodeLazy ) import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified "gtk3" Graphics.UI.Gtk as Gtk @@ -23,10 +24,13 @@ import SetHo.LookupTree ( newLookupTreeview ) -- | fire up the the GUI -runSetter :: String -> DTree -> IO (Maybe DTree) -> IO () -> (DTree -> IO ()) -> IO () -runSetter rootName initialValue userPollForNewMessage sendRequest commit = do +runSetter :: String -> DTree -> IO (Maybe (Int, DTree)) -> IO () -> (Int -> DTree -> IO ()) -> IO () +runSetter rootName initialValue userPollForNewMessage sendRequest userCommit = do statsEnabled <- GHC.Stats.getGCStatsEnabled + counterRef <- newIORef 0 + upstreamCounterRef <- newIORef Nothing + _ <- Gtk.initGUI _ <- Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50 @@ -37,15 +41,25 @@ ] statsLabel <- Gtk.labelNew (Nothing :: Maybe String) - let statsWorker = do - CC.threadDelay 500000 - msg <- if statsEnabled + let makeStatsMessage = do + statsMsg <- if statsEnabled then do stats <- GHC.Stats.getGCStats return $ printf "The current memory usage is %.2f MB" ((realToFrac (GHC.Stats.currentBytesUsed stats) :: Double) /(1024*1024)) else return "(enable GHC statistics with +RTS -T)" - Gtk.postGUISync $ Gtk.labelSetText statsLabel ("Welcome to set-ho-matic!\n" ++ msg) + counter <- readIORef counterRef + mupstreamCounter <- readIORef upstreamCounterRef + let upstreamCount = case mupstreamCounter of + Nothing -> "?" + Just r -> show r + counterMsg = "editing: " ++ show counter ++ " | upstream: " ++ upstreamCount + return $ "Welcome to set-ho-matic!\n" ++ statsMsg ++ "\n" ++ counterMsg + + statsWorker = do + CC.threadDelay 500000 + msg <- makeStatsMessage + Gtk.postGUISync $ Gtk.labelSetText statsLabel msg statsWorker statsThread <- CC.forkIO statsWorker @@ -82,6 +96,14 @@ ] + -- how to commit + let commit val = do + counter <- readIORef counterRef + putStrLn $ "sending settings update " ++ show counter + writeIORef counterRef (1 + counter) + makeStatsMessage >>= Gtk.labelSetText statsLabel + userCommit counter val + -- the signal selector (treeview, getLatestStaged, receiveNewUpstream, takeLatestUpstream, loadFromFile) <- newLookupTreeview rootName initialValue (Gtk.toggleButtonGetActive buttonAutoCommit) commit @@ -132,11 +154,12 @@ , Gtk.boxChildPacking treeviewExpander := Gtk.PackGrow ] - _ <- on buttonCommit Gtk.buttonActivated $ do - val <- getLatestStaged - commit val + _ <- on buttonCommit Gtk.buttonActivated $ (getLatestStaged >>= commit) - _ <- on buttonRefresh Gtk.buttonActivated sendRequest + _ <- on buttonRefresh Gtk.buttonActivated $ do + counter <- readIORef counterRef + putStrLn $ "sending settings request " ++ show counter + sendRequest _ <- on buttonTakeUpstream Gtk.buttonActivated takeLatestUpstream @@ -144,7 +167,11 @@ mmsg <- userPollForNewMessage case mmsg of Nothing -> return () - Just newVal -> receiveNewUpstream newVal + Just (upstreamCounter, newVal) -> do + putStrLn $ "received settings update " ++ show upstreamCounter + writeIORef upstreamCounterRef (Just upstreamCounter) + makeStatsMessage >>= Gtk.labelSetText statsLabel + receiveNewUpstream newVal _ <- Gtk.timeoutAddFull (pollForNewMessage >> return True) Gtk.priorityDefault 300