Plot-ho-matic 0.9.0.10 → 0.10.0.0
raw patch · 14 files changed
+1318/−1095 lines, 14 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- PlotHo: addChannel :: String -> (a -> a -> Bool) -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))]) -> ((a -> IO ()) -> IO ()) -> Plotter ()
- PlotHo: addHistoryChannel :: Lookup a => String -> XAxisType -> ((a -> Bool -> IO ()) -> IO ()) -> Plotter ()
- PlotHo: addHistoryChannel' :: String -> ((Double -> Vector Double -> Maybe Meta -> IO ()) -> IO ()) -> Plotter ()
- PlotHo: data Plotter a
+ PlotHo: PlotterOptions :: Double -> PlotterOptions
+ PlotHo: [maxDrawRate] :: PlotterOptions -> Double
+ PlotHo: data Channel
+ PlotHo: data PlotterOptions
+ PlotHo: def :: Default a => a
+ PlotHo: newChannel :: forall a. String -> (a -> a -> Bool) -> (a -> SignalTree a) -> IO (Channel, a -> IO ())
+ PlotHo: newHistoryChannel :: forall a. Lookup a => String -> XAxisType -> IO (Channel, a -> Bool -> IO ())
+ PlotHo: newHistoryChannel' :: String -> IO (Channel, Double -> Vector Double -> Maybe Meta -> IO ())
- PlotHo: runPlotter :: Plotter () -> IO ()
+ PlotHo: runPlotter :: Maybe PlotterOptions -> [Channel] -> IO ()
- PlotHo: type Meta = [Tree ([String], Either String Int)]
+ PlotHo: type Meta = Tree ([String], Either String Int)
Files
- CHANGELOG.md +9/−0
- Plot-ho-matic.cabal +13/−8
- examples/PlotExample.hs +12/−6
- src/PlotHo.hs +32/−21
- src/PlotHo/Channel.hs +102/−0
- src/PlotHo/Channels.hs +0/−417
- src/PlotHo/ChartRender.hs +12/−10
- src/PlotHo/GraphWidget.hs +179/−519
- src/PlotHo/HistoryChannel.hs +206/−0
- src/PlotHo/OptionsWidget.hs +151/−0
- src/PlotHo/PlotTypes.hs +93/−40
- src/PlotHo/Plotter.hs +119/−59
- src/PlotHo/SignalSelector.hs +343/−0
- src/SetHo/LookupTree.hs +47/−15
CHANGELOG.md view
@@ -1,3 +1,12 @@+0.10.0.0+---+* Better error messages when the "impossible" happens :b+* Also combine partial common prefixes for plot titles/legends+* Replace the Plotter monad with a monomorphic (GADT) Channel type.+* Major reorganization to trigger off of GHC runtime instead of GTK events+* Require non-threaded RTS+* Plot all channels on each graph+ 0.9.0.10 --- * Fix a nasty space leak
Plot-ho-matic.cabal view
@@ -1,5 +1,5 @@ name: Plot-ho-matic-version: 0.9.0.10+version: 0.10.0.0 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE@@ -26,11 +26,14 @@ default-language: Haskell2010 exposed-modules: PlotHo, SetHo - other-modules: PlotHo.Channels,- PlotHo.ChartRender,- PlotHo.GraphWidget,- PlotHo.Plotter,- PlotHo.PlotTypes,+ other-modules: PlotHo.Channel+ PlotHo.ChartRender+ PlotHo.HistoryChannel+ PlotHo.GraphWidget+ PlotHo.OptionsWidget+ PlotHo.Plotter+ PlotHo.PlotTypes+ PlotHo.SignalSelector SetHo.LookupTree build-depends: base >= 4.6.0.0 && < 5@@ -70,8 +73,10 @@ , Plot-ho-matic , containers - ghc-options: -O2 -Wall -with-rtsopts=-T- ghc-prof-options: -O2 -Wall -with-rtsopts=-T+ ghc-options: -O2 -Wall -threaded "-with-rtsopts=-T -N1"+ ghc-prof-options: -O2 -Wall -threaded "-with-rtsopts=-T -N1"+-- ghc-options: -O2 -Wall -threaded "-with-rtsopts=-T -N1 -ls" -threaded -eventlog+-- ghc-prof-options: -O2 -Wall -threaded "-with-rtsopts=-T -N1 -ls" -threaded -eventlog executable set-example if flag(examples)
examples/PlotExample.hs view
@@ -7,7 +7,7 @@ import GHC.Generics ( Generic ) --import qualified System.Remote.Monitoring as EKG -import PlotHo ( Lookup, XAxisType(..), runPlotter, addHistoryChannel )+import PlotHo ( Lookup, XAxisType(..), runPlotter, newHistoryChannel ) data Foo a = MkFoo { x :: Double , y :: Double@@ -57,8 +57,14 @@ main = do -- ekgTid <- fmap EKG.serverThreadId $ EKG.forkServer "localhost" 8000 - runPlotter $ do- addHistoryChannel "Foo (XAxisTime)" XAxisTime $ channelWriter 0 50000 incrementFoo foo0- addHistoryChannel "Bar (XAxisCount)" XAxisCount $ channelWriter 0 60000 incrementBar bar0- addHistoryChannel "Foo (XAxisTime0)" XAxisTime0 $ channelWriter 0 50000 incrementFoo foo0- addHistoryChannel "Bar (XAxisCount0)" XAxisCount0 $ channelWriter 0 60000 incrementBar bar0+ (chan0, send0) <- newHistoryChannel "Foo (XAxisTime)" XAxisTime+ (chan1, send1) <- newHistoryChannel "Bar (XAxisCount)" XAxisCount+ (chan2, send2) <- newHistoryChannel "Foo (XAxisTime0)" XAxisTime0+ (chan3, send3) <- newHistoryChannel "Bar (XAxisCount0)" XAxisCount0++ _ <- CC.forkIO $ channelWriter 0 50000 incrementFoo foo0 send0+ _ <- CC.forkIO $ channelWriter 0 60000 incrementBar bar0 send1+ _ <- CC.forkIO $ channelWriter 0 50000 incrementFoo foo0 send2+ _ <- CC.forkIO $ channelWriter 0 60000 incrementBar bar0 send3++ runPlotter Nothing [chan0, chan1, chan2, chan3]
src/PlotHo.hs view
@@ -10,33 +10,40 @@ -- ** Dynamic data -- $dynamic - Plotter- , runPlotter+ runPlotter+ , PlotterOptions(..)+ , Channel , XAxisType(..)- , addHistoryChannel+ , newHistoryChannel , Meta- , addHistoryChannel'- , addChannel+ , newHistoryChannel'+ , newChannel -- * re-exported for convenience+ , def , Lookup ) where import Accessors ( Lookup )+import Data.Default.Class ( def ) -import PlotHo.Channels ( Meta, XAxisType(..), addHistoryChannel, addHistoryChannel', addChannel )-import PlotHo.Plotter ( Plotter, runPlotter )+import PlotHo.Channel ( newChannel )+import PlotHo.HistoryChannel ( Meta, XAxisType(..), newHistoryChannel, newHistoryChannel' )+import PlotHo.Plotter ( runPlotter )+import PlotHo.PlotTypes ( Channel, PlotterOptions(..) ) -- $simple ----- The easiest way to use this library is to use 'GHC.Generics.Generic' to derive an instance of 'Accessors.Lookup' for your data type, and then use 'addHistoryChannel' to create a time series.--- You need to pass 'addHistoryChannel' an action which periodically sends a new message.+-- The easiest way to use this library is to use 'GHC.Generics.Generic' to derive an instance of 'Accessors.Lookup' for your data type, and then use 'newHistoryChannel' to create a time series plot.+-- The 'newHistoryChannel' function will return an action which is used to send new data to the plotter. -- -- For example: -- -- > {-# LANGUAGE DeriveGeneric #-} -- > -- > import GHC.Generics ( Generic )+-- > -- > import Accessors ( Lookup )+-- > import Control.Concurrent ( forkIO ) -- > import PlotHo -- > -- > data Foo =@@ -46,21 +53,25 @@ -- > } deriving Generic -- > instance Lookup Foo -- >--- > messageSender :: (Foo -> True -> IO ()) -> IO ()--- > messageSender newMessage = forever $ do--- > CC.threadDelay 100000--- > foo <- receiveFooFromNetworkOrSomething :: IO Foo--- > let reset = False -- never reset in this example--- > newMessage foo reset+-- > messageSender :: (Foo -> Bool -> IO ()) -> IO ()+-- > messageSender newMessage = go True+-- > where+-- > go firstMessage = do+-- > CC.threadDelay 100000+-- > foo <- receiveFooFromNetworkOrSomething :: IO Foo+-- > let reset = firstMessage -- reset on the first message+-- > newMessage foo reset+-- > go False -- > -- > main :: IO ()--- > main = runPlotter $--- > addHistoryChannel "it's foo" XAxisCount messageSender+-- > main = do+-- > (channel, newMessage) <- addHistoryChannel "it's foo" XAxisCount+-- > _ <- forkIO (messageSender newMessage)+-- > runPlotter Nothing [channel] ----- When the plotter executes, @messageSender@ will be forked and will--- forever listen for new messages. Every time it receives a new message--- it will call the @newMessage@ action which instructs the plotter to--- add a data point and redraw.+-- When main is run, a new channel is created which returns the "new message" action.+-- @messageSender@ is then forked and periodically sends new messages to the plotter.+-- The plotter is then started with `runPlotter`. -- $dynamic
+ src/PlotHo/Channel.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-}++module PlotHo.Channel+ ( newChannel, newChannel'+ ) where++import qualified Control.Concurrent as CC+import qualified Data.IORef as IORef++import PlotHo.PlotTypes ( Channel(..), Channel'(..), GraphComms(..), SignalTree, debug )++-- | This is the general interface to plot whatever you want.+-- Use this when you want to give the whole time series in one go, rather than one at a time+-- such as with 'addHistoryChannel'.+-- Using types or data, you must encode the signal tree with the message so that+-- the plotter can build you the nice signal tree.+--+-- For examples of this, see the implementation of 'PlotHo.HistoryChannel.addHistoryChannel' and 'PlotHo.HistoryChannel.addHistoryChannel''.+newChannel ::+ forall a+ . String -- ^ channel name+ -> (a -> a -> Bool) -- ^ Is the signal tree the same? This is used for instance if signals have changed and the plotter needs to rebuild the signal tree. This lets you keep the plotter running and change other programs which send messages to the plotter.+ -> (a -> SignalTree a) -- ^ how to build the signal tree+ -> IO (Channel, a -> IO ()) -- ^ Return a channel and a "new message" function. You should for a thread which receives messages and calls this action.+newChannel name sameSignalTree toSignalTree = do+ (channel', newMessage) <- newChannel' name sameSignalTree toSignalTree+ return (Channel channel', newMessage)++-- | Monomorphic version of 'newChannel'. Must be wrapped in 'Channel' in order to plot.+--+-- For examples of this, see the implementation of 'PlotHo.HistoryChannel.addHistoryChannel' and 'PlotHo.HistoryChannel.addHistoryChannel''.+newChannel' ::+ forall a+ . String+ -> (a -> a -> Bool)+ -> (a -> SignalTree a)+ -> IO (Channel' a, a -> IO ())+newChannel' name sameSignalTree toSignalTree = do+ lastMsgMVar <- CC.newMVar Nothing+ graphCommsMapMVar <- CC.newMVar mempty+ maxHist <- IORef.newIORef 0++ let newMessage :: a -> IO ()+ newMessage newVal = do+ debug "newMessage(newChannel): got message"++ -- If it's the first message or if the signal tree has changed, return a signal tree.+ -- If it's a later message and the signal tree is unchanged, return Nothing.+ mlastMsg <- CC.takeMVar lastMsgMVar+ let (latestSignalTree, signalTreeNewOrChanged) = case mlastMsg of+ -- Not the first message.+ Just (oldVal, oldSignalTree)+ -- Signal tree is unchanged.+ | sameSignalTree oldVal newVal -> (oldSignalTree, False)+ -- Signal tree has changed.+ | otherwise -> (toSignalTree newVal, True)+ -- First message. Always build signal tree.+ Nothing -> (toSignalTree newVal, True)+ CC.putMVar lastMsgMVar (Just (newVal, latestSignalTree))+ -- Be careful not to keep a reference to oldVal around so that we don't build up a chain+ -- of references to all the old values.+ -- Evaluating signalTreeNewOrChanged should take care of that.+ signalTreeNewOrChanged `seq` return ()+++ -- now send the data to each graph+ let updateGraph :: GraphComms a -> IO ()+ updateGraph (GraphComms {gcRedrawSignal = redraw, gcMsgStore = graphMsgStore}) = do++ mmsgStore <- CC.takeMVar graphMsgStore++ case (mmsgStore, signalTreeNewOrChanged) of+ -- This graph hasn't gotten a message yet, give it the latest.+ (Nothing, _) -> CC.putMVar graphMsgStore (Just (newVal, Just latestSignalTree))+ -- If we have a new signal tree, force it on the graph no matter what.+ (_, True) ->+ CC.putMVar graphMsgStore (Just (newVal, Just latestSignalTree))+ -- If there is no new signal tree, but the new value and the graph's latest signal tree,+ -- processed or un processed.+ (Just (_, graphsLatestSignalTree), False) ->+ CC.putMVar graphMsgStore (Just (newVal, graphsLatestSignalTree))++ -- tell the graph it needs to redraw+ debug "newMessage(newChannel): signaling redraw"+ redraw++ -- call any redraw functions needed+ CC.readMVar graphCommsMapMVar >>= mapM_ updateGraph++ let retChan =+ Channel'+ { chanName = name+ , chanLatestValueMVar = lastMsgMVar+ , chanSameSignalTree = sameSignalTree+ , chanToSignalTree = toSignalTree+ , chanMaxHistory = maxHist+ , chanClearHistory = Nothing+ , chanGraphCommsMap = graphCommsMapMVar+ }++ return (retChan, newMessage)
− src/PlotHo/Channels.hs
@@ -1,417 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# Language ScopedTypeVariables #-}-{-# Language DeriveFunctor #-}-{-# LANGUAGE PackageImports #-}--module PlotHo.Channels- ( XAxisType(..)- , addHistoryChannel- , Meta- , addHistoryChannel'- , addChannel- ) where--import Control.Lens ( (^.) )-import Control.Monad ( void, when )-import Control.Monad.IO.Class ( MonadIO(..) )-import qualified Control.Concurrent as CC-import qualified Data.Foldable as F-import qualified Data.IORef as IORef-import Data.Time ( NominalDiffTime, getCurrentTime, diffUTCTime )-import Data.Tree ( Tree )-import qualified Data.Tree as Tree-import Data.Vector ( Vector )-import qualified Data.Vector as V-import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified "gtk3" Graphics.UI.Gtk as Gtk-import Text.Read ( readMaybe )-import System.Glib.Signals ( on )---import System.IO ( withFile, IOMode ( WriteMode ) )---import qualified Data.ByteString.Lazy as BSL-import qualified Data.Sequence as S--import Accessors--import PlotHo.GraphWidget ( newGraph )-import PlotHo.Plotter ( Plotter, ChannelStuff(..), tell )-import PlotHo.PlotTypes ( Channel(..), PlotterOptions(..) )---- hardcode options for now-plotterOptions :: PlotterOptions-plotterOptions =- PlotterOptions- { maxDrawRate = 40- }---- | Simplified time-series channel which passes a "send message" function to a worker and forks it using 'Control.Concurrent.forkIO'.--- The plotter will plot a time series of messages sent by the worker.--- The worker should pass True to reset the message history, so sending True the first message and False subsequent messages is a good starting place.--- You will have to recompile the plotter if the types change.--- If you don't want to do this, use the more generic 'addChannel' interface--- and use a type like a Tree to represent your data, or use the 'addHistoryChannel' function.-addHistoryChannel ::- Lookup a- => String -- ^ channel name- -> XAxisType -- ^ what to use for the X axis- -> ((a -> Bool -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'Control.Concurrent.forkIO'- -> Plotter ()-addHistoryChannel name xaxisType action = do- (chan, newMessage) <- liftIO $ newHistoryChannel name xaxisType- workerTid <- liftIO $ CC.forkIO (action newMessage)- tell ChannelStuff { csKillThreads = CC.killThread workerTid- , csMkChanEntry = newChannelWidget chan- }---- | Dynamic time-series channel which can change its signal tree without recompiling the plotter.-addHistoryChannel' ::- String -- ^ channel name- -> ((Double -> Vector Double -> Maybe Meta -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO'- -> Plotter ()-addHistoryChannel' name action = do- (chan, newMessage) <- liftIO $ newHistoryChannel' name- workerTid <- liftIO $ CC.forkIO (action newMessage)- tell ChannelStuff { csKillThreads = CC.killThread workerTid- , csMkChanEntry = newChannelWidget chan- }---- | This is the general interface to plot whatever you want.--- Use this when you want to give the whole time series in one go, rather than one at a time--- such as with 'addHistoryChannel'.--- Using types or data, you must encode the signal tree with the message so that--- the plotter can build you the nice message toggle tree.-addChannel ::- String -- ^ channel name- -> (a -> a -> Bool) -- ^ Is the signal tree the same? This is used for instance if signals have changed and the plotter needs to rebuild the signal tree. This lets you keep the plotter running and change other programs which send messages to the plotter.- -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))]) -- ^ how to build the signal tree- -> ((a -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO'- -> Plotter ()-addChannel name sameSignalTree toSignalTree action = do- (chan, newMessage) <- liftIO $ newChannel name sameSignalTree toSignalTree- workerTid <- liftIO $ CC.forkIO (action newMessage)- tell ChannelStuff { csKillThreads = CC.killThread workerTid- , csMkChanEntry = newChannelWidget chan- }---newChannel ::- forall a- . String- -> (a -> a -> Bool)- -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))])- -> IO (Channel a, a -> IO ())-newChannel name sameSignalTree toSignalTree = do- msgStore <- Gtk.listStoreNew []- maxHist <- IORef.newIORef 0-- let newMessage :: a -> IO ()- newMessage next = do- -- grab the time and counter- Gtk.postGUIAsync $ do- size <- Gtk.listStoreGetSize msgStore- if size == 0- then Gtk.listStorePrepend msgStore next- else Gtk.listStoreSetValue msgStore 0 next-- let retChan = Channel { chanName = name- , chanMsgStore = msgStore- , chanSameSignalTree = sameSignalTree- , chanToSignalTree = toSignalTree- , chanMaxHistory = maxHist- }-- return (retChan, newMessage)---data History a = History (S.Seq (a, Int, NominalDiffTime))-type HistorySignalTree a = Tree.Forest ([String], Either String (History a -> [[(Double, Double)]]))--data XAxisType =- XAxisTime -- ^ time since the first message- | XAxisTime0 -- ^ time since the first message, normalized to 0 (to reduce plot jitter)- | XAxisCount -- ^ message index- | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter)--historySignalTree :: forall a . Lookup a => XAxisType -> HistorySignalTree a-historySignalTree axisType = case accessors of- Left _ -> error "historySignalTree: got a Field right away"- acc -> Tree.subForest $ head $ makeSignalTree' [] acc- where- makeSignalTree' :: [String] -> AccessorTree a -> HistorySignalTree a- makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) =- [Tree.Node- (reverse myFieldName, Left cname)- (concatMap (\(getterName, child) -> makeSignalTree' (fromMName getterName:myFieldName) child) children)- ]- makeSignalTree' myFieldName (Right (GAData _ (GASum enum))) =- [Tree.Node (reverse myFieldName, Right (toHistoryGetter (fromIntegral . eToIndex enum))) []]- makeSignalTree' myFieldName (Left field) =- [Tree.Node (reverse myFieldName, Right (toHistoryGetter (toDoubleGetter field))) []]- fromMName (Just x) = x- fromMName Nothing = "()"-- toDoubleGetter :: GAField a -> (a -> Double)- toDoubleGetter (FieldDouble f) = (^. f)- toDoubleGetter (FieldFloat f) = realToFrac . (^. f)- toDoubleGetter (FieldInt f) = fromIntegral . (^. f)- toDoubleGetter (FieldString _) = const 0- toDoubleGetter FieldSorry = const 0-- toHistoryGetter :: (a -> Double) -> History a -> [[(Double, Double)]]- toHistoryGetter = case axisType of- XAxisTime -> timeGetter- XAxisTime0 -> timeGetter0- XAxisCount -> countGetter- XAxisCount0 -> countGetter0-- timeGetter get (History s) = [map (\(val, _, time) -> (realToFrac time, get val)) (F.toList s)]- timeGetter0 get (History s) = [map (\(val, _, time) -> (realToFrac time - time0, get val)) (F.toList s)]- where- time0 :: Double- time0 = case S.viewl s of- (_, _, time0') S.:< _ -> realToFrac time0'- S.EmptyL -> 0- countGetter get (History s) = [map (\(val, k, _) -> (fromIntegral k, get val)) (F.toList s)]- countGetter0 get (History s) = [map (\(val, k, _) -> (fromIntegral k - k0, get val)) (F.toList s)]- where- k0 :: Double- k0 = case S.viewl s of- (_, k0', _) S.:< _ -> realToFrac k0'- S.EmptyL -> 0---- | History channel which automatically generates the signal tree for you--- based on the Lookup instance. You have to recompile the plotter if--- the types change.--- This is the internal part which should be wrapped by 'addHistoryChannel'.-newHistoryChannel ::- forall a- . Lookup a- => String- -> XAxisType- -> IO (Channel (History a), a -> Bool -> IO ())-newHistoryChannel name xaxisType = do- time0 <- getCurrentTime >>= IORef.newIORef- counter <- IORef.newIORef 0- maxHist <- IORef.newIORef 500-- msgStore <- Gtk.listStoreNew []-- let newMessage :: a -> Bool -> IO ()- newMessage next reset = do- -- grab the time and counter- time <- getCurrentTime- when reset $ do- IORef.writeIORef time0 time- IORef.writeIORef counter 0-- k <- IORef.readIORef counter- time0' <- IORef.readIORef time0-- IORef.writeIORef counter (k+1)- Gtk.postGUIAsync $ do- let val = (next, k, diffUTCTime time time0')- size <- Gtk.listStoreGetSize msgStore- if size == 0- then Gtk.listStorePrepend msgStore (History (S.singleton val))- else do History vals0 <- Gtk.listStoreGetValue msgStore 0- maxHistory <- IORef.readIORef maxHist- let dropped = S.drop (1 + S.length vals0 - maxHistory) (vals0 S.|> val)- Gtk.listStoreSetValue msgStore 0 (History dropped)-- when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val))-- let tst :: History a -> [Tree ( [String]- , Either String (History a -> [[(Double, Double)]])- )]- tst = const (historySignalTree xaxisType)-- let retChan = Channel { chanName = name- , chanMsgStore = msgStore- , chanSameSignalTree = \_ _ -> True- , chanToSignalTree = tst- , chanMaxHistory = maxHist- }-- return (retChan, newMessage)--type Meta = [Tree ([String], Either String Int)]-data History' = History' Bool (S.Seq (Double, Vector Double)) Meta---- | History channel which does NOT automatically generates the signal tree for you.--- This is the internal part which should be wrapped by addHistoryChannel'.-newHistoryChannel' ::- String -> IO (Channel History', Double -> Vector Double -> Maybe Meta -> IO ())-newHistoryChannel' name = do- maxHist <- IORef.newIORef 500-- msgStore <- Gtk.listStoreNew []-- let newMessage :: Double -> Vector Double -> Maybe Meta -> IO ()- newMessage nextTime nextVal maybeMeta = do- Gtk.postGUIAsync $ do- let val = (nextTime, nextVal)- size <- Gtk.listStoreGetSize msgStore- if size == 0- then case maybeMeta of- Just meta -> Gtk.listStorePrepend msgStore (History' True (S.singleton val) meta)- Nothing -> error $ unlines- [ "error: History channel has size 0 message store but no reset."- , "This means that the first message the plotter saw didn't contain the meta-data."- , "This was probably caused by starting the plotter AFTER sending the first telemetry message."- ]- else do History' _ vals0 meta <- Gtk.listStoreGetValue msgStore 0- maxHistory <- IORef.readIORef maxHist- let dropped = S.drop (1 + S.length vals0 - maxHistory) (vals0 S.|> val)- Gtk.listStoreSetValue msgStore 0 (History' False dropped meta)-- -- reset on new meta- case maybeMeta of- Nothing -> return () -- no reset- Just meta -> Gtk.listStoreSetValue msgStore 0 (History' True (S.singleton val) meta)-- let toSignalTree :: History'- -> [Tree ( [String]- , Either String (History' -> [[(Double, Double)]])- )]- toSignalTree (History' _ _ meta) = map (fmap f) meta- where- f :: ([String], Either String Int)- -> ([String], Either String (History' -> [[(Double, Double)]]))- f (n0, Left n1) = (n0, Left n1)- f (n0, Right k) = (n0, Right g)- where- g :: History' -> [[(Double, Double)]]- g (History' _ vals _) = [map toVal (F.toList vals)]- where- toVal (t, x) = (t, x V.! k)-- sameSignalTree :: History' -> History' -> Bool- -- assume the signal trees are the same if it's not a reset- sameSignalTree (History' _ _ _) (History' False _ _) = True- -- if it's a reset, then compare the signal trees- sameSignalTree (History' _ _ old) (History' True _ new) = old == new-- let retChan = Channel { chanName = name- , chanMsgStore = msgStore- , chanSameSignalTree = sameSignalTree- , chanToSignalTree = toSignalTree- , chanMaxHistory = maxHist- }-- return (retChan, newMessage)---- the list of channels-newChannelWidget :: Channel a -> CC.MVar [Gtk.Window] -> IO Gtk.VBox-newChannelWidget channel graphWindowsToBeKilled = do- vbox <- Gtk.vBoxNew False 4-- nameBox' <- Gtk.hBoxNew False 4- nameBox <- labeledWidget (chanName channel) nameBox'-- buttonsBox <- Gtk.hBoxNew False 4-- -- button to clear history- buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing"--- void $ Gtk.onClicked buttonAlsoDoNothing $ do--- putStrLn "i promise, nothing happens"--- -- CC.modifyMVar_ logData (const (return S.empty))--- return ()- let triggerYo action = on buttonAlsoDoNothing Gtk.buttonActivated action >> return ()-- -- button to make a new graph- buttonNew <- Gtk.buttonNewWithLabel "new graph"- void $ on buttonNew Gtk.buttonActivated $ do- graphWin <-- newGraph plotterOptions triggerYo (chanName channel)- (chanSameSignalTree channel)- (chanToSignalTree channel)- (chanMsgStore channel)-- -- add this window to the list to be killed on exit- CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:))--- -- entry to set history length- maxHistoryEntryAndLabel <- Gtk.hBoxNew False 4- maxHistoryLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "max history:"- maxHistoryEntry <- Gtk.entryNew- Gtk.set maxHistoryEntry- [ Gtk.entryEditable := True- , Gtk.widgetSensitive := True- ]- Gtk.entrySetText maxHistoryEntry "500"- let updateMaxHistory = do- txt <- Gtk.get maxHistoryEntry Gtk.entryText- let reset = Gtk.entrySetText maxHistoryEntry "(max)"- case readMaybe txt :: Maybe Int of- Nothing ->- putStrLn ("max history: couldn't make an Int out of \"" ++ show txt ++ "\"") >> reset- Just 0 -> putStrLn ("max history: must be greater than 0") >> reset- Just k -> IORef.writeIORef (chanMaxHistory channel) k-- void $ on maxHistoryEntry Gtk.entryActivate updateMaxHistory- updateMaxHistory--- Gtk.set maxHistoryEntryAndLabel- [ Gtk.containerChild := maxHistoryLabel- , Gtk.boxChildPacking maxHistoryLabel := Gtk.PackNatural- , Gtk.containerChild := maxHistoryEntry- , Gtk.boxChildPacking maxHistoryEntry := Gtk.PackNatural- ]--- -- put all the buttons/entries together- Gtk.set buttonsBox- [ Gtk.containerChild := buttonNew- , Gtk.boxChildPacking buttonNew := Gtk.PackNatural- , Gtk.containerChild := buttonAlsoDoNothing- , Gtk.boxChildPacking buttonAlsoDoNothing := Gtk.PackNatural- , Gtk.containerChild := maxHistoryEntryAndLabel- , Gtk.boxChildPacking maxHistoryEntryAndLabel := Gtk.PackNatural- ]-- Gtk.set vbox- [ Gtk.containerChild := nameBox- , Gtk.boxChildPacking nameBox := Gtk.PackNatural- , Gtk.containerChild := buttonsBox- , Gtk.boxChildPacking buttonsBox := Gtk.PackNatural- ]-- return vbox------- -- save all channel data when this button is pressed----- void $ on renderer3 Gtk.cellToggled $ \pathStr -> do----- let (i:_) = Gtk.stringToTreePath pathStr----- lv <- Gtk.listStoreGetValue model i----- let writerThread = do----- bct <- chanGetByteStrings (lvChan lv)----- let filename = chanName (lvChan lv) ++ "_log.dat"----- blah _ sizes [] = return (reverse sizes)----- blah handle sizes ((x,_,_):xs) = do----- BSL.hPut handle x----- blah handle (BSL.length x : sizes) xs----- putStrLn $ "trying to write file \"" ++ filename ++ "\"..."----- sizes <- withFile filename WriteMode $ \handle -> blah handle [] bct----- putStrLn $ "finished writing file, wrote " ++ show (length sizes) ++ " protos"---------- putStrLn "writing file with sizes..."----- writeFile (filename ++ ".sizes") (unlines $ map show sizes)----- putStrLn "done"----- void $ CC.forkIO writerThread--- return ()------ return treeview----- helper to make an hbox with a label-labeledWidget :: Gtk.WidgetClass a => String -> a -> IO Gtk.HBox-labeledWidget name widget = do- label <- Gtk.labelNew (Just name)- hbox <- Gtk.hBoxNew False 4- Gtk.set hbox [ Gtk.containerChild := label- , Gtk.containerChild := widget- , Gtk.boxChildPacking label := Gtk.PackNatural--- , Gtk.boxChildPacking widget := Gtk.PackNatural- ]- return hbox
src/PlotHo/ChartRender.hs view
@@ -2,8 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module PlotHo.ChartRender- ( AxisScaling(..)- , toChartRender+ ( toChartRender ) where import Control.Lens ( (.~) )@@ -13,22 +12,23 @@ import Graphics.Rendering.Chart.Backend.Cairo ( runBackend, defaultEnv ) import qualified Graphics.Rendering.Cairo as Cairo -import PlotHo.PlotTypes ( AxisScaling(..) )+import PlotHo.PlotTypes (Axes(..), AxisType(..), XY(..)) -- take the data and use Chart to make a Renderable () toChartRender :: forall a . (Chart.PlotValue a, Show a, RealFloat a)- => (AxisScaling, AxisScaling)- -> ((a,a), (a,a))- -> ((a,a), (a,a))+ => Axes a+ -> XY (a, a) -> Maybe String -> [(String, [[(a,a)]])] -> Chart.RectSize -> Cairo.Render ()-toChartRender (xScaling, yScaling) (manualXRange, manualYRange) (historyXRange, historyYRange)- mtitle namePcs rectSize =+toChartRender axes (XY historyXRange historyYRange) mtitle namePcs rectSize = void $ runBackend (defaultEnv Chart.bitmapAlignmentFns) (Chart.render renderable rectSize) where+ XY xtype ytype = axesType axes+ XY manualXRange manualYRange = axesManualRange axes+ renderable :: Chart.Renderable () renderable = Chart.toRenderable layout @@ -41,7 +41,8 @@ allLines :: [Chart.PlotLines a a] allLines = zipWith drawOne namePcs Chart.defaultColorSeq - xscaleFun = case xScaling of+ xscaleFun :: Chart.Layout a a -> Chart.Layout a a+ xscaleFun = case xtype of LogScaling -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def LinearScalingAutoRange -> id LinearScalingManualRange ->@@ -50,7 +51,8 @@ Chart.layout_x_axis . Chart.laxis_generate .~ Chart.scaledAxis def historyXRange - yscaleFun = case yScaling of+ yscaleFun :: Chart.Layout a a -> Chart.Layout a a+ yscaleFun = case ytype of LogScaling -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def LinearScalingAutoRange -> id LinearScalingManualRange ->
src/PlotHo/GraphWidget.hs view
@@ -8,174 +8,103 @@ import Control.Concurrent ( MVar ) import qualified Control.Concurrent as CC-import Control.Monad ( forever, unless, void, when )-import Control.Monad.IO.Class ( MonadIO, liftIO )-import Data.Either ( isRight )-import qualified Data.IORef as IORef-import Data.List ( foldl', intercalate )-import qualified Data.Map as M-import Data.Maybe ( isNothing, fromJust )+import Control.Monad ( forever, void, when, zipWithM )+import Control.Monad.IO.Class ( liftIO )+import Data.IORef ( newIORef, writeIORef )+import Data.List ( foldl' )+import qualified Data.Map.Strict as M import Data.Time.Clock ( getCurrentTime, diffUTCTime )-import qualified Data.Tree as Tree+import Graphics.Rendering.Cairo ( Render, Surface ) import qualified Graphics.Rendering.Cairo as Cairo import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified "gtk3" Graphics.UI.Gtk as Gtk import System.Glib.Signals ( on )-import Text.Read ( readMaybe )-import qualified Data.Text as T-import qualified Graphics.Rendering.Chart as Chart+import Text.Printf ( printf )+import Graphics.Rendering.Chart ( RectSize ) -import PlotHo.ChartRender ( AxisScaling(..), toChartRender )-import PlotHo.PlotTypes ( GraphInfo(..), ListViewInfo(..), MarkedState(..), PlotterOptions(..) )+import PlotHo.ChartRender ( toChartRender )+import PlotHo.OptionsWidget ( OptionsWidget(..), makeOptionsWidget )+import PlotHo.PlotTypes+import PlotHo.SignalSelector ( SignalSelector(..), newSignalSelectorArea ) -debug :: MonadIO m => String -> m ()---debug = liftIO . putStrLn-debug = const (return ()) -defaultHistoryRange :: (Double, Double)-defaultHistoryRange = (read "Infinity", - read "Infinity")---- make a new graph window-newGraph ::- forall a- . PlotterOptions- -> (IO () -> IO ())- -> String- -> (a -> a -> Bool)- -> (a -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))])- -> Gtk.ListStore a -> IO Gtk.Window-newGraph options onButton channame sameSignalTree forestFromMeta msgStore = do- win <- Gtk.windowNew+toElement' :: Int -> Channel' a -> IO (Element' a)+toElement' index channel = do+ mlatestValue <- CC.readMVar (chanLatestValueMVar channel)+ let latestValue = case mlatestValue of+ Nothing -> Nothing+ Just (val, signalTree) -> Just (val, Just signalTree) - void $ Gtk.set win- [ Gtk.containerBorderWidth := 8- , Gtk.windowTitle := channame+ msgStore <- CC.newMVar latestValue+ plotValueRef <- newIORef $+ error $ unlines+ [ "The impossible happened."+ , "Element plot value reference is initially undefined until a signal tree and data come in."+ , "There is no getter. How was this accessed?" ] - -- mvar with all the user input- graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = LinearScalingAutoRange- , giYScaling = LinearScalingAutoRange- , giManualXRange = (-10, 10)- , giManualYRange = (-10, 10)- , giGetters = []- , giTitle = Nothing- , giHistoryXRange = defaultHistoryRange- , giHistoryYRange = defaultHistoryRange- } :: IO (CC.MVar (GraphInfo a))+ return+ Element'+ { eChannel = channel+ , eMsgStore = msgStore+ , eIndex = index+ , ePlotValueRef = plotValueRef+ } - let -- turn latest signals into a Chart render- prepareRenderFromLatestData :: IO (Chart.RectSize -> Cairo.Render ())- prepareRenderFromLatestData = do- -- get the latest signals- gi <- CC.readMVar graphInfoMVar- size <- Gtk.listStoreGetSize msgStore- namePcs <-- if size == 0- then return []- else do datalog <- Gtk.listStoreGetValue msgStore 0- return $ map (fmap (\g -> g datalog)) (giGetters gi)- :: IO [(String, [[(Double,Double)]])] - let f :: ((Double, Double), (Double, Double)) -> (Double, Double)- -> ((Double, Double), (Double, Double))- f ((minX, maxX), (minY, maxY)) (x, y) =- newMinX `seq` newMaxX `seq` newMinY `seq` newMaxY `seq`- ( (newMinX, newMaxX)- , (newMinY, newMaxY)- )- where- newMinX = min minX x- newMaxX = max maxX x- newMinY = min minY y- newMaxY = max maxY y-- pcs :: [(Double, Double)]- pcs = concatMap (concat . snd) namePcs-- newRanges = foldl' f (giHistoryXRange gi, giHistoryYRange gi) pcs- newGi =- gi- { giHistoryXRange = fst newRanges- , giHistoryYRange = snd newRanges- }- void $ CC.swapMVar graphInfoMVar newGi+-- make a new graph window+newGraph :: PlotterOptions -> [Channel] -> IO Gtk.Window+newGraph options channels = do+ win <- Gtk.windowNew - return $- toChartRender- (giXScaling gi, giYScaling gi)- (giManualXRange gi, giManualYRange gi)- newRanges- (giTitle gi)- namePcs+ elements <- zipWithM (\k (Channel c) -> Element <$> toElement' k c) [0..] channels + void $ Gtk.set win+ [ Gtk.containerBorderWidth := 8+ , Gtk.windowTitle := "plot-ho-graphic"+ ] - -- new chart drawing area+ -- chart drawing area chartCanvas <- Gtk.drawingAreaNew void $ Gtk.widgetSetSizeRequest chartCanvas 80 80 - -- some mvars for syncronizing rendering with drawing- needRedrawMVar <- CC.newMVar False- latestOneToRenderMVar <-- CC.newEmptyMVar :: IO (MVar (Chart.RectSize -> Cairo.Render (), (Int, Int)))- latestSurfaceMVar <-- CC.newMVar Nothing :: IO (MVar (Maybe (Cairo.Surface, (Int, Int))))+ -- mvars for drawing thread inputs/outputs+ latestOneToRenderMVar <- CC.newEmptyMVar :: IO (MVar (RectSize -> Render (), (Int, Int)))+ latestSurfaceMVar <- CC.newMVar Nothing :: IO (MVar (Maybe (Surface, (Int, Int)))) + -- fork the thread which continuously draws+ void $ CC.forkIO (renderWorker latestOneToRenderMVar latestSurfaceMVar chartCanvas options)++ -- Flag which marks if someone has called for a redraw.+ -- We have the MVar in addition to the GTK signal so that if multiple sources+ -- request a redraw and multiple signals are in the queue, we can draw once and then+ -- ignore the rest of the signals..+ needRedrawMVar <- CC.newMVar False let redraw :: IO () redraw = do debug "redraw called" void $ CC.swapMVar needRedrawMVar True- Gtk.widgetQueueDraw chartCanvas-- renderWorker :: IO ()- renderWorker = do- debug "renderWorker: waiting for new render"- -- block until we have to render something- (render, (width, height)) <- CC.takeMVar latestOneToRenderMVar- renderStartTime <- getCurrentTime- debug "renderWorker: starting render"-- -- create an image to draw on- surface <- liftIO $ Cairo.createImageSurface Cairo.FormatARGB32 width height-- -- do the drawing- Cairo.renderWith surface (render (realToFrac width, realToFrac height))-- -- put our new drawing in the latest surface variable- debug "renderWorker: putting finished surface"- void $ CC.swapMVar latestSurfaceMVar (Just (surface, (width, height)))-- -- queue another draw- debug "renderWorker: queing draw" Gtk.postGUIAsync (Gtk.widgetQueueDraw chartCanvas) - -- At this point the render worker will immediately start the next render if needed.- -- This could cause us to draw at an unneccesarily high rate which would could- -- overload the system. So we only draw at maximum rate given by 'maxDrawRate'.- -- If we are already slower than 'maxDrawRate' we don't sleep,- -- we just update as quickly as possible.- renderFinishTime <- getCurrentTime- let renderTime :: Double- renderTime = realToFrac $ diffUTCTime renderFinishTime renderStartTime-- sleepTime = 1 / maxDrawRate options - renderTime- when (sleepTime < 0) $- CC.threadDelay (round (1e6 * sleepTime))+ signalSelector <- newSignalSelectorArea elements redraw - -- fork that bad boy- void $ CC.forkIO (forever renderWorker)+ largestRangeMVar <- CC.newMVar (XY defaultHistoryRange defaultHistoryRange)+ optionsWidget <- makeOptionsWidget largestRangeMVar redraw - let handleDraw :: Cairo.Render ()+ let handleDraw :: Render () handleDraw = do debug "handleDraw: called" -- get the size of the surface we have to draw Gtk.Rectangle _ _ width height <- liftIO $ Gtk.widgetGetAllocation chartCanvas - -- handleDraw always immediately takes the last drawn surface and draws it+ -- handleDraw always immediately takes the last rendered surface and draws it -- this is just a copy and very efficient maybeLatestSurface <- liftIO $ CC.readMVar latestSurfaceMVar needFirstDrawOrResizeDraw <- case maybeLatestSurface of Just (latestSurface, (lastWidth, lastHeight)) -> do+ -- TODO(greg): Should we be drawing if the width/height don't match?+ -- I wonder if this could cause a buffer overrun. debug "handleDraw: painting latest surface" Cairo.setSourceSurface latestSurface 0 0 Cairo.paint@@ -184,7 +113,7 @@ debug "handleDraw: no surface yet" return True - -- then we determine if we actually need to re-generate a new surface+ -- then we determine if we need to re-generate a new surface needRedraw <- liftIO $ CC.swapMVar needRedrawMVar False when (needRedraw || needFirstDrawOrResizeDraw) $ liftIO $ do -- if we need to redraw for whatever reason@@ -197,9 +126,53 @@ "needFirstDrawOrResizeDraw" _ -> return () -- (impossible) - -- get the latest data to draw based on use messages and GUI signal selections- render <- prepareRenderFromLatestData + -- Now we have to take the latest data from the channels and put it in the IORefs+ -- so that the signal tree can apply the getters. Phew.+ let stageDataFromElement :: forall a . Element' a -> IO ()+ stageDataFromElement element = do+ let msgStore = eMsgStore element+ -- get the latest data, just block if they're not available+ mdatalog <- CC.takeMVar msgStore+ case mdatalog of+ -- no data yet, do nothing+ Nothing -> CC.putMVar msgStore mdatalog+ Just (datalog, msignalTree) -> do+ case msignalTree of+ -- No new signal tree, no action necessary+ Nothing -> return ()+ -- If there is a new signal tree, we have to merge it with the old one.+ Just newSignalTree -> case signalSelector of+ SignalSelector {ssRebuildSignalTree = rebuildSignalTree} ->+ rebuildSignalTree element newSignalTree++ -- write the data to the IORef so that the getters get the right stuff+ writeIORef (ePlotValueRef element) datalog++ -- Put the data back. Put Nothing to signify that the signal tree is up to date.+ CC.putMVar msgStore (Just (datalog, Nothing))++ -- stage the values+ mapM_ (\(Element e) -> stageDataFromElement e) elements++ -- get the latest plot points+ -- Now we have rebuild the signal tree if necessary, and staged the latest plot values+ -- To the geter IORefs. It is safe to get the plot points.+ (mtitle, namedPlotPoints) <- ssToPlotValues signalSelector++ debug "handleDraw: got title and plot points"+ let -- update the min/max plot ranges+ updateRanges :: XY (Double, Double) -> XY (Double, Double)+ updateRanges oldRanges =+ foldl' largestRange oldRanges (concatMap (concat . snd) namedPlotPoints)+ newRanges <- modifyMVar' largestRangeMVar updateRanges++ axes <- owGetAxes optionsWidget++ -- prepare the next render+ let render :: RectSize -> Render ()+ render = toChartRender axes newRanges mtitle namedPlotPoints+ -- Empty the mvar if it is full. -- If we are getting lots of messages quickly this -- will descard any undrawn requests.@@ -214,19 +187,16 @@ void $ on chartCanvas Gtk.draw handleDraw -- the options widget- optionsWidget <- makeOptionsWidget graphInfoMVar redraw optionsExpander <- Gtk.expanderNew "opt" Gtk.set optionsExpander- [ Gtk.containerChild := optionsWidget+ [ Gtk.containerChild := owVBox optionsWidget , Gtk.expanderExpanded := False ] -- the signal selector- treeview <- newSignalSelectorArea onButton sameSignalTree forestFromMeta graphInfoMVar msgStore redraw- treeviewScroll <- Gtk.scrolledWindowNew Nothing Nothing Gtk.set treeviewScroll [Gtk.widgetVExpand := True] -- make sure it expands vertically- Gtk.containerAdd treeviewScroll treeview+ Gtk.containerAdd treeviewScroll (ssTreeView signalSelector) Gtk.set treeviewScroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic@@ -258,400 +228,90 @@ void $ Gtk.set win [ Gtk.containerChild := hboxEverything ] + -- add this window to the set of windows that get redraw signals on new messages+ let registerElement :: Element' a -> IO ()+ registerElement element = do+ let graphComms =+ GraphComms+ { gcRedrawSignal = redraw+ , gcMsgStore = eMsgStore element+ }+ CC.modifyMVar_ (chanGraphCommsMap (eChannel element)) (return . M.insert win graphComms)+ mapM_ (\(Element e) -> registerElement e) elements++ -- when the window is closed, remove it from the set which get redraw signals on new messages+ void $ on win Gtk.deleteEvent $ do+ debug "removing window from redrawSignalMap"+ let removeElement :: Element' a -> IO ()+ removeElement element = do+ CC.modifyMVar_ (chanGraphCommsMap (eChannel element)) (return . M.delete win)+ liftIO $ mapM_ (\(Element e) -> removeElement e) elements+ return False++ -- show the window and return Gtk.widgetShowAll win return win --- The greatest common prefix will be the title.--- Everything after that is the field name.-gettersAndTitle :: forall a . [([String], a)] -> ([(String, a)], Maybe String)-gettersAndTitle getters0 = (getters2, titles'')- where- titles'' = case titles' of- [] -> Nothing- ts -> Just $ intercalate "." (reverse ts)- titles' :: [String] - (titles', getters1) = f [] getters0- getters2 = map (\(x,y) -> (intercalate "." x, y)) getters1 - extractHead (x:xs, y) = Just (x, (xs, y))- extractHead ([], _) = Nothing-- f titles xs0- | any isNothing xs = (titles, xs0)- | otherwise = case xs' of- [] -> (titles, xs0)- (prefix, _):others- -- if all prefixes match, do another recursion- | all ((prefix ==) . fst) others -> f (prefix:titles) (map snd xs')- -- otherwise we're done- | otherwise -> (titles, xs0)- where- xs :: [Maybe (String, ([String], a))]- xs = map extractHead xs0-- xs' :: [(String, ([String], a))]- xs' = map fromJust xs--newSignalSelectorArea ::- forall a- . (IO () -> IO ())- -> (a -> a -> Bool)- -> (a -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))])- -> CC.MVar (GraphInfo a)- -> Gtk.ListStore a- -> IO () -> IO Gtk.TreeView-newSignalSelectorArea onButton sameSignalTree forestFromMeta graphInfoMVar msgStore redraw = do- treeStore <- Gtk.treeStoreNew []- treeview <- Gtk.treeViewNewWithModel treeStore-- Gtk.treeViewSetHeadersVisible treeview True-- -- add some columns- colSignal <- Gtk.treeViewColumnNew- colVisible <- Gtk.treeViewColumnNew-- Gtk.treeViewColumnSetTitle colSignal "signal"- Gtk.treeViewColumnSetTitle colVisible "visible?"-- rendererSignal <- Gtk.cellRendererTextNew- rendererVisible <- Gtk.cellRendererToggleNew-- Gtk.treeViewColumnPackStart colSignal rendererSignal True- Gtk.treeViewColumnPackStart colVisible rendererVisible True-- let showName :: Either String (a -> [[(Double, Double)]]) -> [String] -> String- -- show a getter name- showName (Right _) (name:_) = name- showName (Right _) [] = error "showName on field got an empty list"- -- show a parent without type info- showName (Left "") (name:_) = name- -- show a parent with type info- showName (Left typeName) (name:_) = name ++ " (" ++ typeName ++ ")"- showName (Left _) [] = error "showName on parent got an empty list"-- Gtk.cellLayoutSetAttributes colSignal rendererSignal treeStore $- \(ListViewInfo {lviName = name, lviTypeOrGetter = typeOrGetter}) ->- [ Gtk.cellText := showName typeOrGetter (reverse name)- ]- Gtk.cellLayoutSetAttributes colVisible rendererVisible treeStore $ \lvi -> case lviMarked lvi of- On -> [ Gtk.cellToggleInconsistent := False- , Gtk.cellToggleActive := True- ]- Off -> [ Gtk.cellToggleInconsistent := False- , Gtk.cellToggleActive := False- ]- Inconsistent -> [ Gtk.cellToggleActive := False- , Gtk.cellToggleInconsistent := True- ]-- void $ Gtk.treeViewAppendColumn treeview colSignal- void $ Gtk.treeViewAppendColumn treeview colVisible--- let -- update the graph information- updateGraphInfo = do- -- first get all trees- let getTrees k = do- tree' <- Gtk.treeStoreLookup treeStore [k]- case tree' of Nothing -> return []- Just tree -> fmap (tree:) (getTrees (k+1))- theTrees <- getTrees 0- let fromRight (Right r) = r- fromRight (Left _) = error "PlotHo GraphWidget: fromRight got Left, this should be impossible"- newGetters0 :: [([String], a -> [[(Double, Double)]])]- newGetters0 = [ (lviName lvi, fromRight $ lviTypeOrGetter lvi)- | lvi <- concatMap Tree.flatten theTrees- , lviMarked lvi == On- , isRight (lviTypeOrGetter lvi)- ]- let newGetters :: [(String, a -> [[(Double, Double)]])]- newTitle :: Maybe String- (newGetters, newTitle) = gettersAndTitle newGetters0-- void $ CC.modifyMVar_ graphInfoMVar $- \gi0 -> return $ gi0 {giGetters = newGetters, giTitle = newTitle}-- i2p i = Gtk.treeModelGetPath treeStore i- p2i p = do- mi <- Gtk.treeModelGetIter treeStore p- case mi of Nothing -> error "no iter at that path"- Just i -> return i-- -- update which y axes are visible- _ <- on rendererVisible Gtk.cellToggled $ \pathStr -> do- let treePath = Gtk.stringToTreePath pathStr-- getChildrenPaths path' = do- iter' <- p2i path'- let getChildPath k = do- mc <- Gtk.treeModelIterNthChild treeStore (Just iter') k- case mc of- Nothing -> error "no child"- Just c -> i2p c- n <- Gtk.treeModelIterNChildren treeStore (Just iter')- mapM getChildPath (take n [0..])-- changeSelfAndChildren change path' = do- childrenPaths <- getChildrenPaths path'- ret <- Gtk.treeStoreChange treeStore path' change- when (not ret) $ error "treeStoreChange fail"- mapM_ (changeSelfAndChildren change) childrenPaths-- fixInconsistent path' = do- mparentIter <- p2i path' >>= Gtk.treeModelIterParent treeStore- case mparentIter of- Nothing -> return ()- Just parentIter -> do- parentPath <- i2p parentIter- siblingPaths <- getChildrenPaths parentPath- siblings <- mapM (Gtk.treeStoreGetValue treeStore) siblingPaths- let markedSiblings :: [MarkedState]- markedSiblings = map lviMarked siblings-- changeParent- | all (== On) markedSiblings =- Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = On})- | all (== Off) markedSiblings =- Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = Off})- | otherwise =- Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = Inconsistent})- ret <- changeParent- when (not ret) $ error "fixInconsistent couldn't change parent"- fixInconsistent parentPath- return ()-- -- toggle the check mark- val <- Gtk.treeStoreGetValue treeStore treePath- case val of- (ListViewInfo _ (Left _) Off) ->- changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath- (ListViewInfo _ (Left _) On) ->- changeSelfAndChildren (\lvi -> lvi {lviMarked = Off}) treePath- (ListViewInfo _ (Left _) Inconsistent) ->- changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath- lvi@(ListViewInfo _ (Right _) On) ->- Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = Off}- lvi@(ListViewInfo _ (Right _) Off) ->- Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = On}- (ListViewInfo _ (Right _) Inconsistent) -> error "cell getter can't be inconsistent"-- fixInconsistent treePath- updateGraphInfo- redraw-- let getTopForest = do- nTopLevelNodes <- Gtk.treeModelIterNChildren treeStore Nothing- mnodes <- mapM (Gtk.treeModelIterNthChild treeStore Nothing) (take nTopLevelNodes [0..])- let treeFromJust (Just x) = i2p x >>= Gtk.treeStoreGetTree treeStore- treeFromJust Nothing = error "missing top level node"- mapM treeFromJust mnodes-- -- rebuild the signal tree- let rebuildSignalTree :: [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))]- -> IO ()- rebuildSignalTree meta = do- putStrLn "rebuilding signal tree"-- oldTrees <- getTopForest- let _ = oldTrees :: [Tree.Tree (ListViewInfo a)]-- merge :: forall b- . [Tree.Tree (ListViewInfo b)]- -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))]- -> [Tree.Tree (ListViewInfo a)]- merge old new = map convert new- where- oldMap :: M.Map ([String], Maybe String) (ListViewInfo b, [Tree.Tree (ListViewInfo b)])- oldMap = M.fromList $ map f old- where- f (Tree.Node lvi lvis) = ((lviName lvi, maybeType), (lvi, lvis))- where- maybeType = case lviTypeOrGetter lvi of- Left typ -> Just typ- Right _ -> Nothing-- convert :: Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))- -> Tree.Tree (ListViewInfo a)- convert (Tree.Node (name, tog) others) = case M.lookup (name, maybeType) oldMap of- Nothing -> Tree.Node (ListViewInfo name tog Off) (merge [] others)- Just (lvi, oldOthers) -> Tree.Node (ListViewInfo name tog (lviMarked lvi)) (merge oldOthers others)- where- maybeType = case tog of- Left r -> Just r- Right _ -> Nothing-- newTrees = merge oldTrees meta-- Gtk.treeStoreClear treeStore- Gtk.treeStoreInsertForest treeStore [] 0 newTrees- updateGraphInfo-- oldMetaRef <- IORef.newIORef Nothing- let maybeRebuildSignalTree :: a -> IO ()- maybeRebuildSignalTree newMeta = do- oldMeta <- IORef.readIORef oldMetaRef- let sameSignalTree' Nothing _ = False- sameSignalTree' (Just x) y = sameSignalTree x y- unless (sameSignalTree' oldMeta newMeta) $ do- IORef.writeIORef oldMetaRef (Just newMeta)- rebuildSignalTree (forestFromMeta newMeta)-- -- on new message (insert or change), rebuild the signal tree and redraw- _ <- on msgStore Gtk.rowChanged $ \_ changedPath -> do- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)- maybeRebuildSignalTree newMsg- redraw- _ <- on msgStore Gtk.rowInserted $ \_ changedPath -> do- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)- maybeRebuildSignalTree newMsg- redraw-- -- rebuild the signal tree right now if it exists- size <- Gtk.listStoreGetSize msgStore- when (size > 0) $ do- newMsg <- Gtk.listStoreGetValue msgStore 0- maybeRebuildSignalTree newMsg- redraw+renderWorker+ :: MVar (RectSize -> Render (), (Int, Int))+ -> MVar (Maybe (Surface, (Int, Int)))+ -> Gtk.DrawingArea+ -> PlotterOptions+ -> IO ()+renderWorker latestOneToRenderMVar latestSurfaceMVar chartCanvas options = forever $ do+ debug "renderWorker: waiting for new render"+ -- block until we have to render something+ (render, (width, height)) <- CC.takeMVar latestOneToRenderMVar+ renderStartTime <- getCurrentTime+ debug "renderWorker: starting render" - -- for debugging- onButton $ do- newMsg <- Gtk.listStoreGetValue msgStore 0- rebuildSignalTree (forestFromMeta newMsg)- redraw+ -- create an image to draw on+ surface <- liftIO $ Cairo.createImageSurface Cairo.FormatARGB32 width height - return treeview+ -- do the drawing+ Cairo.renderWith surface (render (realToFrac width, realToFrac height)) + -- put our new drawing in the latest surface variable+ debug "renderWorker: putting finished surface"+ void $ CC.swapMVar latestSurfaceMVar (Just (surface, (width, height))) + -- queue another draw+ debug "renderWorker: queuing draw"+ Gtk.postGUIAsync (Gtk.widgetQueueDraw chartCanvas) -makeOptionsWidget :: CC.MVar (GraphInfo a) -> IO () -> IO Gtk.VBox-makeOptionsWidget graphInfoMVar redraw = do- -- user selectable range- xRange <- Gtk.entryNew- yRange <- Gtk.entryNew- Gtk.set xRange [ Gtk.entryEditable := True- , Gtk.widgetSensitive := True- ]- Gtk.set yRange [ Gtk.entryEditable := True- , Gtk.widgetSensitive := True- ]- xRangeBox <- labeledWidget "x range:" xRange- yRangeBox <- labeledWidget "y range:" yRange- Gtk.set xRange [Gtk.entryText := "(-10,10)"]- Gtk.set yRange [Gtk.entryText := "(-10,10)"]- let updateXRange = do- txt <- Gtk.get xRange Gtk.entryText- gi <- CC.readMVar graphInfoMVar- case readMaybe txt of- Nothing -> do- putStrLn $ "invalid x range entry: " ++ txt- Gtk.set xRange [Gtk.entryText := show (giManualXRange gi)]- Just (z0,z1) -> if z0 >= z1- then do- putStrLn $ "invalid x range entry (min >= max): " ++ txt- Gtk.set xRange [Gtk.entryText := show (giManualXRange gi)]- return ()- else do- _ <- CC.swapMVar graphInfoMVar (gi {giManualXRange = (z0, z1)})- redraw- let updateYRange = do- txt <- Gtk.get yRange Gtk.entryText- gi <- CC.readMVar graphInfoMVar- case readMaybe txt of- Nothing -> do- putStrLn $ "invalid y range entry: " ++ txt- Gtk.set yRange [Gtk.entryText := show (giManualYRange gi)]- Just (z0,z1) -> if z0 >= z1- then do- putStrLn $ "invalid y range entry (min >= max): " ++ txt- Gtk.set yRange [Gtk.entryText := show (giManualYRange gi)]- return ()- else do- _ <- CC.swapMVar graphInfoMVar (gi {giManualYRange = (z0, z1)})- redraw- _ <- on xRange Gtk.entryActivate updateXRange- _ <- on yRange Gtk.entryActivate updateYRange+ -- At this point the render worker would immediately start the next render if one was available.+ -- This could cause us to draw at an unneccesarily high rate which would could+ -- overload the system. So we only draw at maximum rate given by 'maxDrawRate'.+ -- If we are already slower than 'maxDrawRate' we don't sleep,+ -- we just update as quickly as possible.+ renderFinishTime <- getCurrentTime+ let renderTime :: Double+ renderTime = realToFrac $ diffUTCTime renderFinishTime renderStartTime - -- linear or log scaling on the x and y axis?- xScalingSelector <- Gtk.comboBoxNewText- yScalingSelector <- Gtk.comboBoxNewText- mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack)- ["linear (auto)", "linear (history)", "linear (manual)", "logarithmic (auto)"]- mapM_ (Gtk.comboBoxAppendText yScalingSelector . T.pack)- ["linear (auto)", "linear (history)", "linear (manual)", "logarithmic (auto)"]- Gtk.comboBoxSetActive xScalingSelector 0- Gtk.comboBoxSetActive yScalingSelector 0- xScalingBox <- labeledWidget "x scaling:" xScalingSelector- yScalingBox <- labeledWidget "y scaling:" yScalingSelector- let updateXScaling = do- k <- Gtk.comboBoxGetActive xScalingSelector- _ <- case k of- 0 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXScaling = LinearScalingAutoRange}- 1 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXScaling = LinearScalingHistoryRange}- 2 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXScaling = LinearScalingManualRange}- 3 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXScaling = LogScaling}- _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 4"- redraw- let updateYScaling = do- k <- Gtk.comboBoxGetActive yScalingSelector- _ <- case k of- 0 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giYScaling = LinearScalingAutoRange}- 1 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giYScaling = LinearScalingHistoryRange}- 2 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giYScaling = LinearScalingManualRange}- 3 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giYScaling = LogScaling}- _ -> error "the \"impossible\" happened: y scaling comboBox index should be < 4"- redraw- updateXScaling- updateYScaling- void $ on xScalingSelector Gtk.changed updateXScaling- void $ on yScalingSelector Gtk.changed updateYScaling+ sleepTime = 1 / maxDrawRate options - renderTime - resetXHistory <- Gtk.buttonNewWithLabel "reset X range"- resetYHistory <- Gtk.buttonNewWithLabel "reset Y range"- void $ on resetXHistory Gtk.buttonActivated $- CC.modifyMVar_ graphInfoMVar (\gi -> return (gi {giHistoryXRange = defaultHistoryRange}))- void $ on resetYHistory Gtk.buttonActivated $- CC.modifyMVar_ graphInfoMVar (\gi -> return (gi {giHistoryYRange = defaultHistoryRange}))+ debug $ printf "sleep time: %.2g\n" sleepTime+ when (sleepTime > 0) $+ CC.threadDelay (round (1e6 * sleepTime)) - -- vbox to hold the little window on the left- vbox <- Gtk.vBoxNew False 4-- Gtk.set vbox- [ Gtk.containerChild := xScalingBox- , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural- , Gtk.containerChild := xRangeBox- , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural- , Gtk.containerChild := resetXHistory- , Gtk.boxChildPacking resetXHistory := Gtk.PackNatural- , Gtk.containerChild := yScalingBox- , Gtk.boxChildPacking yScalingBox := Gtk.PackNatural- , Gtk.containerChild := yRangeBox- , Gtk.boxChildPacking yRangeBox := Gtk.PackNatural- , Gtk.containerChild := resetYHistory- , Gtk.boxChildPacking resetYHistory := Gtk.PackNatural- ]-- return vbox-+-- evaluate+forceRange :: XY (Double, Double) -> XY (Double, Double)+forceRange (XY (minX, maxX) (minY, maxY)) =+ minX `seq` maxX `seq` minY `seq` maxY `seq`+ (XY (minX, maxX) (minY, maxY)) +largestRange :: XY (Double, Double) -> (Double, Double) -> XY (Double, Double)+largestRange (XY (minX, maxX) (minY, maxY)) (x, y) =+ forceRange $ XY (min minX x, max maxX x) (min minY y, max maxY y) --- helper to make an hbox with a label-labeledWidget :: Gtk.WidgetClass a => String -> a -> IO Gtk.HBox-labeledWidget name widget = do- label <- Gtk.labelNew (Just name)- hbox <- Gtk.hBoxNew False 4- Gtk.set hbox [ Gtk.containerChild := label- , Gtk.containerChild := widget- , Gtk.boxChildPacking label := Gtk.PackNatural--- , Gtk.boxChildPacking widget := Gtk.PackNatural- ]- return hbox+-- same behavior as 'Control.Concurrent.modifyMVar' with a different interface+modifyMVar' :: forall a . MVar a -> (a -> a) -> IO a+modifyMVar' mvar f = CC.modifyMVar mvar g+ where+ g :: a -> IO (a, a)+ g x = return (y, y)+ where+ y = f x
+ src/PlotHo/HistoryChannel.hs view
@@ -0,0 +1,206 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-}+{-# Language DeriveFunctor #-}++module PlotHo.HistoryChannel+ ( Meta+ , XAxisType(..)+ , newHistoryChannel+ , newHistoryChannel'+ ) where++import qualified Control.Concurrent as CC+import Control.Lens ( (^.) )+import Control.Monad ( when )+import qualified Data.Foldable as F+import qualified Data.IORef as IORef+import Data.Time ( NominalDiffTime, getCurrentTime, diffUTCTime )+import Data.Tree ( Tree )+import qualified Data.Tree as Tree+import Data.Vector ( Vector )+import qualified Data.Vector as V+import qualified Data.Sequence as S++import Accessors++import PlotHo.Channel ( newChannel' )+import PlotHo.PlotTypes ( Channel(..), Channel'(..), SignalTree, debug )++type Meta = Tree ([String], Either String Int)++newtype History a = History (S.Seq (a, Int, NominalDiffTime))+data History' = History' !Bool !(S.Seq (Double, Vector Double)) !Meta++data XAxisType =+ XAxisTime -- ^ time since the first message+ | XAxisTime0 -- ^ time since the first message, normalized to 0 (to reduce plot jitter)+ | XAxisCount -- ^ message index+ | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter)++historySignalTree :: forall a . Lookup a => XAxisType -> String -> SignalTree (History a)+historySignalTree axisType topName = makeSignalTree' [topName] accessors+ where+ makeSignalTree' :: [String] -> AccessorTree a -> SignalTree (History a)+ makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) =+ Tree.Node+ (reverse myFieldName, Left cname)+ (map (\(getterName, child) -> makeSignalTree' (fromMName getterName:myFieldName) child) children)++ makeSignalTree' myFieldName (Right (GAData _ (GASum enum))) =+ Tree.Node (reverse myFieldName, Right (toHistoryGetter (fromIntegral . eToIndex enum))) []+ makeSignalTree' myFieldName (Left field) =+ Tree.Node (reverse myFieldName, Right (toHistoryGetter (toDoubleGetter field))) []++ fromMName (Just x) = x+ fromMName Nothing = "()"++ toDoubleGetter :: GAField a -> (a -> Double)+ toDoubleGetter (FieldDouble f) = (^. f)+ toDoubleGetter (FieldFloat f) = realToFrac . (^. f)+ toDoubleGetter (FieldInt f) = fromIntegral . (^. f)+ toDoubleGetter (FieldString _) = const 0+ toDoubleGetter FieldSorry = const 0++ toHistoryGetter :: (a -> Double) -> History a -> [[(Double, Double)]]+ toHistoryGetter = case axisType of+ XAxisTime -> timeGetter+ XAxisTime0 -> timeGetter0+ XAxisCount -> countGetter+ XAxisCount0 -> countGetter0++ timeGetter get (History s) = [map (\(val, _, time) -> (realToFrac time, get val)) (F.toList s)]+ timeGetter0 get (History s) = [map (\(val, _, time) -> (realToFrac time - time0, get val)) (F.toList s)]+ where+ time0 :: Double+ time0 = case S.viewl s of+ (_, _, time0') S.:< _ -> realToFrac time0'+ S.EmptyL -> 0+ countGetter get (History s) = [map (\(val, k, _) -> (fromIntegral k, get val)) (F.toList s)]+ countGetter0 get (History s) = [map (\(val, k, _) -> (fromIntegral k - k0, get val)) (F.toList s)]+ where+ k0 :: Double+ k0 = case S.viewl s of+ (_, k0', _) S.:< _ -> realToFrac k0'+ S.EmptyL -> 0++-- | Simplified time-series channel which automatically generates the signal tree+-- based on 'Accessors.Lookup'.+-- You have to recompile the plotter if the types change.+-- The plotter will plot a time series of messages put by the action returned by this function.+-- The worker should pass True to reset the message history, so sending True the first message and False subsequent messages is a good starting place.+-- If this is too restrictive, use the more generic 'newChannel'+-- and use a Tree-like type to represent your data, or use 'newHistoryChannel''.+newHistoryChannel ::+ forall a+ . Lookup a+ => String -- ^ channel name+ -> XAxisType -- ^ what to use for the X axis+ -> IO (Channel, a -> Bool -> IO ()) -- ^ return a channel and a "new message" action which can also reset the history+newHistoryChannel name xaxisType = do+ time0 <- getCurrentTime >>= IORef.newIORef+ counter <- IORef.newIORef 0+ let toSignalTree :: History a -> SignalTree (History a)+ toSignalTree = const (historySignalTree xaxisType name)++ sameSignalTree _ _ = True++ (channel', newHistoryMessage) <- newChannel' name sameSignalTree toSignalTree+ :: IO (Channel' (History a), History a -> IO ())++ -- Put the first message immediately in order to immediately build the signal tree+ -- so that the user can see it without waiting for the first message.+ newHistoryMessage (History mempty)++ let newMessage :: a -> Bool -> IO ()+ newMessage next reset = do+ debug "newMessage(newHistoryChannel): message received"+ -- grab the time and counter+ time <- getCurrentTime+ when reset $ do+ IORef.writeIORef time0 time+ IORef.writeIORef counter 0++ k <- IORef.readIORef counter+ time0' <- IORef.readIORef time0++ IORef.writeIORef counter (k+1)+ let val = (next, k, diffUTCTime time time0')++ latestChanValue <- CC.readMVar (chanLatestValueMVar channel')+ oldTimeSeries <- case latestChanValue of+ Just (History r, _) -> return r+ Nothing -> error "newMessage(newHistoryChannel): the 'impossible' happened: channel has no latest message"++ maxHistory <- IORef.readIORef (chanMaxHistory channel')+ let newTimeSeries+ | reset = S.singleton val+ | otherwise = S.drop (1 + S.length oldTimeSeries - maxHistory) (oldTimeSeries S.|> val)+ debug "newMessage(newHistoryChannel): new history message calling internal newMessage"+ newHistoryMessage (History newTimeSeries)++ clearHistory :: History a -> History a+ clearHistory = const (History mempty)++ return (Channel (channel' {chanClearHistory = Just clearHistory}) , newMessage)+++-- | History channel which supports data whose structure can change.+-- It does NOT automatically generate the signal tree like 'newHistoryChannel' does.+-- This returns a channel and an action which takes x-axis value, a vector of y axis values, and a tree which+-- indexes these y axis values.+-- If the data structure changes, a new tree should be sent, otherwise there could be indexing errors.+newHistoryChannel' ::+ String -- ^ channel name+ -> IO (Channel, Double -> Vector Double -> Maybe Meta -> IO ())+newHistoryChannel' name = do+ let toSignalTree :: History'+ -> Tree ( [String]+ , Either String (History' -> [[(Double, Double)]])+ )+ toSignalTree (History' _ _ meta) = fmap f meta+ where+ f :: ([String], Either String Int) -> ([String], Either String (History' -> [[(Double, Double)]]))+ f (n0, Left n1) = (n0, Left n1)+ f (n0, Right k) = (n0, Right g)+ where+ g :: History' -> [[(Double, Double)]]+ g (History' _ vals _) = [map toVal (F.toList vals)]+ where+ toVal (t, x) = (t, x V.! k)++ sameSignalTree :: History' -> History' -> Bool+ -- assume the signal trees are the same if it's not a reset+ sameSignalTree (History' _ _ _) (History' False _ _) = True+ -- if it's a reset, then compare the signal trees+ sameSignalTree (History' _ _ old) (History' True _ new) = old == new++ (channel', newHistoryMessage) <- newChannel' name sameSignalTree toSignalTree+ :: IO (Channel' History', History' -> IO ())++ let newMessage :: Double -> Vector Double -> Maybe Meta -> IO ()+ newMessage nextTime nextVal maybeMeta = do+ let val = (nextTime, nextVal)++ latestChannelValue <- CC.readMVar (chanLatestValueMVar channel')++ case (latestChannelValue, maybeMeta) of+ -- first message and no meta to go with it+ (Nothing, Nothing) ->+ putStr $ unlines+ [ "WARNING: First message seen by Plot-ho-matic doesn't have signal tree meta-data."+ , "This was probably caused by starting the plotter AFTER sending the first telemetry message."+ , "Try restarting the application sending messages."+ ]+ -- any message with meta is a reset+ (_, Just meta) -> newHistoryMessage (History' True (S.singleton val) meta)+ -- later message without meta - no reset+ (Just (History' _ oldTimeSeries meta, _), Nothing) -> do+ maxHistory <- IORef.readIORef (chanMaxHistory channel')+ let newTimeSeries =+ S.drop (1 + S.length oldTimeSeries - maxHistory) (oldTimeSeries S.|> val)+ newHistoryMessage (History' False newTimeSeries meta)++ clearHistory :: History' -> History'+ clearHistory (History' reset _ meta) = History' reset mempty meta++ return (Channel (channel' {chanClearHistory = Just clearHistory}) , newMessage)
+ src/PlotHo/OptionsWidget.hs view
@@ -0,0 +1,151 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}++module PlotHo.OptionsWidget+ ( OptionsWidget(..)+ , makeOptionsWidget+ ) where++import qualified Control.Concurrent as CC+import Control.Monad ( void )+import Data.IORef ( newIORef, readIORef, writeIORef )+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk+import System.Glib.Signals ( on )+import Text.Read ( readMaybe )+import qualified Data.Text as T++import PlotHo.PlotTypes++data OptionsWidget+ = OptionsWidget+ { owVBox :: Gtk.VBox+ , owGetAxes :: IO (Axes Double)+ }++makeOptionsWidget :: CC.MVar (XY (Double, Double)) -> IO () -> IO OptionsWidget+makeOptionsWidget largestRangeMVar redraw = do+ -- user selectable range+ xRangeEntry <- Gtk.entryNew+ yRangeEntry <- Gtk.entryNew+ Gtk.set xRangeEntry+ [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ Gtk.set yRangeEntry+ [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ xRangeBox <- labeledWidget "x range:" xRangeEntry+ yRangeBox <- labeledWidget "y range:" yRangeEntry++ let updateRange rangeEntry rangeRef name = do+ txt <- Gtk.get rangeEntry Gtk.entryText+ oldRange <- readIORef rangeRef++ case readMaybe txt of+ Nothing -> do+ putStrLn $ "invalid " ++ name ++ " range entry: " ++ txt+ Gtk.set rangeEntry [Gtk.entryText := show oldRange]+ Just (z0,z1)+ | z0 >= z1 -> do+ putStrLn $ "invalid " ++ name ++ " range entry (min >= max): " ++ txt+ Gtk.set rangeEntry [Gtk.entryText := show oldRange]+ | otherwise -> do+ writeIORef rangeRef (z0, z1)+ redraw++ Gtk.set xRangeEntry [Gtk.entryText := "(-10,10)"]+ Gtk.set yRangeEntry [Gtk.entryText := "(-10,10)"]++ xRangeRef <- newIORef (-10, 10)+ yRangeRef <- newIORef (-10, 10)++ _ <- on xRangeEntry Gtk.entryActivate (updateRange xRangeEntry xRangeRef "x")+ _ <- on yRangeEntry Gtk.entryActivate (updateRange yRangeEntry yRangeRef "y")+++ -- linear or log scaling on the x and y axis?+ let updateScaling scalingSelector scalingRef = do+ k <- Gtk.comboBoxGetActive scalingSelector+ _ <- case k of+ 0 -> writeIORef scalingRef LinearScalingAutoRange+ 1 -> writeIORef scalingRef LinearScalingHistoryRange+ 2 -> writeIORef scalingRef LinearScalingManualRange+ 3 -> writeIORef scalingRef LogScaling+ _ -> error "the \"impossible\" happened: scaling comboBox index should be < 4"+ redraw++ xScalingSelector <- Gtk.comboBoxNewText+ yScalingSelector <- Gtk.comboBoxNewText+ let scalingOptions =+ ["linear (auto)", "linear (history)", "linear (manual)", "logarithmic (auto)"]+ mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack) scalingOptions+ mapM_ (Gtk.comboBoxAppendText yScalingSelector . T.pack) scalingOptions+ Gtk.comboBoxSetActive xScalingSelector 0+ Gtk.comboBoxSetActive yScalingSelector 0+ xScalingBox <- labeledWidget "x scaling:" xScalingSelector+ yScalingBox <- labeledWidget "y scaling:" yScalingSelector++ xScalingRef <- newIORef LinearScalingAutoRange+ yScalingRef <- newIORef LinearScalingAutoRange+ updateScaling xScalingSelector xScalingRef+ updateScaling yScalingSelector yScalingRef+ void $ on xScalingSelector Gtk.changed (updateScaling xScalingSelector xScalingRef)+ void $ on yScalingSelector Gtk.changed (updateScaling yScalingSelector yScalingRef)++ 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}))++ -- vbox to hold the little window on the left+ vbox <- Gtk.vBoxNew False 4++ Gtk.set vbox+ [ Gtk.containerChild := xScalingBox+ , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural+ , Gtk.containerChild := xRangeBox+ , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural+ , Gtk.containerChild := resetXHistoryButton+ , Gtk.boxChildPacking resetXHistoryButton := Gtk.PackNatural+ , Gtk.containerChild := yScalingBox+ , Gtk.boxChildPacking yScalingBox := Gtk.PackNatural+ , Gtk.containerChild := yRangeBox+ , Gtk.boxChildPacking yRangeBox := Gtk.PackNatural+ , Gtk.containerChild := resetYHistoryButton+ , Gtk.boxChildPacking resetYHistoryButton := Gtk.PackNatural+ ]++ return+ OptionsWidget+ { owVBox = vbox+ , owGetAxes = do+ xRange <- readIORef xRangeRef+ yRange <- readIORef yRangeRef+ xScaling <- readIORef xScalingRef+ yScaling <- readIORef yScalingRef+ return+ Axes+ { axesType = XY xScaling yScaling+ , axesManualRange = XY xRange yRange+ }+ }++++-- helper to make an hbox with a label+labeledWidget :: Gtk.WidgetClass a => String -> a -> IO Gtk.HBox+labeledWidget name widget = do+ label <- Gtk.labelNew (Just name)+ hbox <- Gtk.hBoxNew False 4+ Gtk.set hbox [ Gtk.containerChild := label+ , Gtk.containerChild := widget+ , Gtk.boxChildPacking label := Gtk.PackNatural+-- , Gtk.boxChildPacking widget := Gtk.PackNatural+ ]+ return hbox
src/PlotHo/PlotTypes.hs view
@@ -1,65 +1,118 @@ {-# OPTIONS_GHC -Wall #-}---{-# Language ExistentialQuantification #-}---{-# Language GADTs #-}-{-# Language PackageImports #-}+{-# Language GADTs #-}+{-# LANGUAGE PackageImports #-} module PlotHo.PlotTypes- ( AxisScaling(..)+ ( AxisType(..)+ , Axes(..) , Channel(..)- , GraphInfo(..)+ , Channel'(..)+ , Element(..)+ , Element'(..)+ , GraphComms(..) , ListViewInfo(..) , MarkedState(..) , PlotterOptions(..)+ , SignalTree+ , XY(..)+ , debug+ , defaultHistoryRange ) where +import qualified Control.Concurrent as CC+import Control.Monad.IO.Class ( MonadIO ) -- , liftIO )+import Data.Default.Class ( Default(..) )+import Data.IORef ( IORef )+import qualified Data.Map.Strict as M import Data.Tree ( Tree ) import qualified "gtk3" Graphics.UI.Gtk as Gtk-import Data.IORef ( IORef ) +debug :: MonadIO m => String -> m ()+--debug = liftIO . putStrLn+debug = const (return ())+ data MarkedState = On | Off | Inconsistent deriving (Eq, Show) -data ListViewInfo a =- ListViewInfo- { lviName :: [String]- , lviTypeOrGetter :: Either String (a -> [[(Double,Double)]])- , lviMarked :: MarkedState- }+data Element where+ Element :: Element' a -> Element -instance Show (ListViewInfo a) where- show (ListViewInfo n (Left t) m) = "ListViewInfo " ++ show (n,t,m)- show (ListViewInfo n (Right _) m) = "ListViewInfo " ++ show (n,m)+data Element' a+ = Element'+ { eChannel :: Channel' a+ , eMsgStore :: CC.MVar (Maybe (a, Maybe (SignalTree a)))+ , ePlotValueRef :: IORef a+ , eIndex :: Int+ } -data AxisScaling = LogScaling- | LinearScalingAutoRange- | LinearScalingHistoryRange- | LinearScalingManualRange+data ListViewInfo where+ ListViewInfo ::+ { lviName :: ![String]+ , lviTypeOrGetter :: !(Either String (a -> [[(Double,Double)]]))+ , lviMarked :: !MarkedState+ , lviPlotValueRef :: IORef a+ } -> ListViewInfo --- what the graph should draw-data GraphInfo a =- GraphInfo { giXScaling :: AxisScaling- , giYScaling :: AxisScaling- , giManualXRange :: (Double,Double)- , giManualYRange :: (Double,Double)- , giHistoryXRange :: (Double, Double)- , giHistoryYRange :: (Double, Double)- , giGetters :: [(String, a -> [[(Double,Double)]])]- , giTitle :: Maybe String--- , giGetVal :: IO a- }+instance Show ListViewInfo where+ show (ListViewInfo n (Left t) m _) = "ListViewInfo " ++ show (n,t,m)+ show (ListViewInfo n (Right _) m _) = "ListViewInfo " ++ show (n,m) -data Channel a =- Channel { chanName :: String- , chanMsgStore :: Gtk.ListStore a- , chanSameSignalTree :: a -> a -> Bool- , chanToSignalTree :: a -> [Tree ( [String]- , Either String (a -> [[(Double, Double)]])- )]- , chanMaxHistory :: IORef Int- }+type SignalTree a =+ Tree ( [String]+ , Either String (a -> [[(Double, Double)]])+ ) +data AxisType+ = LogScaling+ | LinearScalingAutoRange+ | LinearScalingHistoryRange+ | LinearScalingManualRange++defaultHistoryRange :: (Double, Double)+defaultHistoryRange = (read "Infinity", - read "Infinity")++data XY a+ = XY+ { xaxis :: !a+ , yaxis :: !a+ }++data Axes a+ = Axes+ { axesType :: !(XY AxisType)+ , axesManualRange :: !(XY (a, a))+ }++data GraphComms a+ = GraphComms+ { gcRedrawSignal :: IO ()+ , gcMsgStore :: CC.MVar (Maybe (a, Maybe (SignalTree a)))+ -- ^ The MVar is always full, we use Maybe to decide if a first message has been received.+ -- If the signal tree is Just, a rebuild is needed.+ }++data Channel where+ Channel :: Channel' a -> Channel++data Channel' a+ = Channel'+ { chanName :: String+ , chanSameSignalTree :: a -> a -> Bool+ , chanToSignalTree :: a -> SignalTree a+ , chanMaxHistory :: IORef Int+ , chanClearHistory :: Maybe (a -> a)+ , chanGraphCommsMap :: CC.MVar (M.Map Gtk.Window (GraphComms a))+ , chanLatestValueMVar :: CC.MVar (Maybe (a, SignalTree a))+ }+ -- | Some options data PlotterOptions = PlotterOptions { maxDrawRate :: Double -- ^ limit the draw frequency to this number in Hz+ }++instance Default PlotterOptions where+ def =+ PlotterOptions+ { maxDrawRate = 40 }
src/PlotHo/Plotter.hs view
@@ -1,72 +1,46 @@ {-# OPTIONS_GHC -Wall #-} {-# Language ScopedTypeVariables #-}-{-# Language DeriveFunctor #-}-{-# Language MultiParamTypeClasses #-} {-# LANGUAGE PackageImports #-} module PlotHo.Plotter- ( Plotter(..)- , ChannelStuff(..)- , runPlotter- , execPlotter- , tell+ ( runPlotter ) where import qualified GHC.Stats -import Control.Applicative-import Control.Monad ( void )+import Control.Monad ( unless, void ) import Control.Monad.IO.Class ( MonadIO(..) ) import qualified Control.Concurrent as CC-import Data.Monoid+import Data.Default.Class ( def )+import Data.Maybe ( fromMaybe )+import qualified Data.IORef as IORef import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified "gtk3" Graphics.UI.Gtk as Gtk import Text.Printf ( printf )+import Text.Read ( readMaybe )+import System.Exit ( exitFailure ) import System.Glib.Signals ( on ) import Prelude --- | add channels to this, then run it with 'runPlotter'-newtype Plotter a = Plotter { unPlotter :: IO (a, [ChannelStuff]) } deriving Functor--instance Applicative Plotter where- pure x = Plotter $ pure (x, [])- f <*> v = Plotter $ liftA2 k (unPlotter f) (unPlotter v)- where k ~(a, w) ~(b, w') = (a b, w `mappend` w')--instance Monad Plotter where- return a = Plotter $ return (a, [])- m >>= k = Plotter $ do- ~(a, w) <- unPlotter m- ~(b, w') <- unPlotter (k a)- return (b, w `mappend` w')- fail msg = Plotter $ fail msg--instance MonadIO Plotter where- liftIO m = Plotter $ do- a <- m- return (a, mempty)--tell :: ChannelStuff -> Plotter ()-tell w = Plotter (return ((), [w]))--execPlotter :: Plotter a -> IO [ChannelStuff]-execPlotter m = do- ~(_, w) <- unPlotter m- return w--data ChannelStuff =- ChannelStuff- { csKillThreads :: IO ()- , csMkChanEntry :: CC.MVar [Gtk.Window] -> IO Gtk.VBox- }+import PlotHo.GraphWidget ( newGraph )+import PlotHo.PlotTypes ( Channel(..), Channel'(..), PlotterOptions(..) ) -- | fire up the the GUI-runPlotter :: Plotter () -> IO ()-runPlotter plotterMonad = do+runPlotter :: Maybe PlotterOptions -> [Channel] -> IO ()+runPlotter mplotterOptions channels = do+ let plotterOptions = fromMaybe def mplotterOptions statsEnabled <- GHC.Stats.getGCStatsEnabled + unless CC.rtsSupportsBoundThreads $ do+ putStr $ unlines+ [ "Plot-ho-matic requires the threaded RTS."+ , "Please recompile your program with the -threaded GHC option."+ , "Either add \"ghc-options: -threaded\" to your cabal file "+ , "or use the -threaded flag when calling GHC from the command line."+ ]+ void exitFailure+ void Gtk.initGUI- void $ Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50 -- start the main window win <- Gtk.windowNew@@ -91,26 +65,25 @@ -- on close, kill all the windows and threads graphWindowsToBeKilled <- CC.newMVar [] - channels <- execPlotter plotterMonad- let windows = map csMkChanEntry channels-- chanWidgets <- mapM (\x -> x graphWindowsToBeKilled) windows- let killEverything :: IO () killEverything = do CC.killThread statsThread gws <- CC.readMVar graphWindowsToBeKilled mapM_ Gtk.widgetDestroy gws- mapM_ csKillThreads channels Gtk.mainQuit void $ on win Gtk.deleteEvent $ liftIO (killEverything >> return False) --------------- main widget ------------------ -- button to clear history- buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing"- void $ on buttonDoNothing Gtk.buttonActivated $- putStrLn "seriously, it does nothing"+ -- button to spawn a new graph+ buttonSpawnGraph <- Gtk.buttonNewWithLabel "new graph"+ void $ on buttonSpawnGraph Gtk.buttonActivated $ do+ graphWin <- newGraph plotterOptions channels+ -- add this window to the list to be killed on exit+ CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:)) + -- clear history / max history widget for each channel+ chanWidgets <- mapM (\(Channel c) -> newChannelWidget c) channels+ -- box to hold list of channels channelBox <- Gtk.vBoxNew False 4 Gtk.set channelBox $@@ -130,8 +103,8 @@ Gtk.set vbox $ [ Gtk.containerChild := statsLabel , Gtk.boxChildPacking statsLabel := Gtk.PackNatural- , Gtk.containerChild := buttonDoNothing- , Gtk.boxChildPacking buttonDoNothing := Gtk.PackNatural+ , Gtk.containerChild := buttonSpawnGraph+ , Gtk.boxChildPacking buttonSpawnGraph := Gtk.PackNatural , Gtk.containerChild := scroll ] @@ -141,3 +114,90 @@ void $ Gtk.set win [ Gtk.containerChild := vbox ] Gtk.widgetShowAll win Gtk.mainGUI+++++-- the list of channels+newChannelWidget :: Channel' a -> IO Gtk.VBox+newChannelWidget channel = do+ vbox <- Gtk.vBoxNew False 4++ nameBox' <- Gtk.hBoxNew False 4+ nameBox <- labeledWidget (chanName channel) nameBox'++ buttonsBox <- Gtk.hBoxNew False 4++ -- button to clear history+ buttonClearHistory <- Gtk.buttonNewWithLabel "clear history"+ void $ on buttonClearHistory Gtk.buttonActivated $ case chanClearHistory channel of+ Nothing -> putStrLn "not clearing history because that doesn't make sense for this type of data"+ Just clearHistory -> do+ mlatestValue <- CC.takeMVar (chanLatestValueMVar channel)+ case mlatestValue of+ Nothing -> do+ putStrLn "not clearing history because no messages has been received"+ CC.putMVar (chanLatestValueMVar channel) mlatestValue+ Just (latestValue, signalTree) -> do+ putStrLn $ "clearing history for channel " ++ show (chanName channel)+ CC.putMVar (chanLatestValueMVar channel) (Just (clearHistory latestValue, signalTree))++ -- entry to set history length+ maxHistoryEntryAndLabel <- Gtk.hBoxNew False 4+ maxHistoryLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "max history:"+ maxHistoryEntry <- Gtk.entryNew+ Gtk.set maxHistoryEntry+ [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ Gtk.entrySetText maxHistoryEntry "500"+ let updateMaxHistory = do+ txt <- Gtk.get maxHistoryEntry Gtk.entryText+ let reset = Gtk.entrySetText maxHistoryEntry "(max)"+ case readMaybe txt :: Maybe Int of+ Nothing ->+ putStrLn ("max history: couldn't make an Int out of \"" ++ show txt ++ "\"") >> reset+ Just 0 -> putStrLn ("max history: must be greater than 0") >> reset+ Just k -> IORef.writeIORef (chanMaxHistory channel) k++ void $ on maxHistoryEntry Gtk.entryActivate updateMaxHistory+ updateMaxHistory+++ Gtk.set maxHistoryEntryAndLabel+ [ Gtk.containerChild := maxHistoryLabel+ , Gtk.boxChildPacking maxHistoryLabel := Gtk.PackNatural+ , Gtk.containerChild := maxHistoryEntry+ , Gtk.boxChildPacking maxHistoryEntry := Gtk.PackNatural+ ]+++ -- put all the buttons/entries together+ Gtk.set buttonsBox+ [ Gtk.containerChild := buttonClearHistory+ , Gtk.boxChildPacking buttonClearHistory := Gtk.PackNatural+ , Gtk.containerChild := maxHistoryEntryAndLabel+ , Gtk.boxChildPacking maxHistoryEntryAndLabel := Gtk.PackNatural+ ]++ Gtk.set vbox+ [ Gtk.containerChild := nameBox+ , Gtk.boxChildPacking nameBox := Gtk.PackNatural+ , Gtk.containerChild := buttonsBox+ , Gtk.boxChildPacking buttonsBox := Gtk.PackNatural+ ]++ return vbox+++-- helper to make an hbox with a label+labeledWidget :: Gtk.WidgetClass a => String -> a -> IO Gtk.HBox+labeledWidget name widget = do+ label <- Gtk.labelNew (Just name)+ hbox <- Gtk.hBoxNew False 4+ Gtk.set hbox [ Gtk.containerChild := label+ , Gtk.containerChild := widget+ , Gtk.boxChildPacking label := Gtk.PackNatural+-- , Gtk.boxChildPacking widget := Gtk.PackNatural+ ]+ return hbox
+ src/PlotHo/SignalSelector.hs view
@@ -0,0 +1,343 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}++module PlotHo.SignalSelector+ ( SignalSelector(..)+ , newSignalSelectorArea+ ) where++import qualified Control.Concurrent as CC+import Control.Monad ( unless, void, when )+import Data.IORef ( IORef, readIORef )+import Data.List ( foldl', intercalate )+import qualified Data.Map as M+import Data.Maybe ( isNothing, fromJust )+import Data.Tree ( Tree )+import qualified Data.Tree as Tree+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk+import System.Glib.Signals ( on )++import PlotHo.PlotTypes++data SignalSelector+ = SignalSelector+ { ssTreeView :: Gtk.TreeView+ , ssRebuildSignalTree :: forall a . Element' a -> SignalTree a -> IO ()+ , ssToPlotValues :: IO (Maybe String, [(String, [[(Double, Double)]])])+ }++newSignalSelectorArea :: [Element] -> IO () -> IO SignalSelector+newSignalSelectorArea elems redraw = do+ -- mvar with all the user input+ graphInfoMVar <- CC.newMVar (Nothing, [])++ let initialForest :: [Tree ListViewInfo]+ initialForest = map (\(Element e) -> toNode e) elems+ where+ toNode :: Element' a -> Tree ListViewInfo+ toNode element =+ Tree.Node+ { Tree.rootLabel =+ ListViewInfo+ { lviName = [chanName (eChannel element)]+ , lviMarked = Off+ , lviTypeOrGetter = Left ""+ , lviPlotValueRef = ePlotValueRef element+ }+ , Tree.subForest = []+ }+ treeStore <- Gtk.treeStoreNew initialForest+ treeview <- Gtk.treeViewNewWithModel treeStore++ Gtk.treeViewSetHeadersVisible treeview True++ -- add some columns+ colSignal <- Gtk.treeViewColumnNew+ colVisible <- Gtk.treeViewColumnNew++ Gtk.treeViewColumnSetTitle colSignal "signal"+ Gtk.treeViewColumnSetTitle colVisible "visible?"++ rendererSignal <- Gtk.cellRendererTextNew+ rendererVisible <- Gtk.cellRendererToggleNew++ Gtk.treeViewColumnPackStart colSignal rendererSignal True+ Gtk.treeViewColumnPackStart colVisible rendererVisible True++ let showName :: Either String b -> [String] -> String+ -- show a getter name+ showName (Right _) (name:_) = name+ showName (Right _) [] = error "showName on field got an empty list"+ -- show a parent without type info+ showName (Left "") (name:_) = name+ -- show a parent with type info+ showName (Left typeName) (name:_) = name ++ " (" ++ typeName ++ ")"+ showName (Left _) [] = error "showName on parent got an empty list"++ Gtk.cellLayoutSetAttributes colSignal rendererSignal treeStore $+ \(ListViewInfo {lviName = name, lviTypeOrGetter = typeOrGetter}) ->+ [ Gtk.cellText := showName typeOrGetter (reverse name)+ ]+ Gtk.cellLayoutSetAttributes colVisible rendererVisible treeStore $ \lvi -> case lviMarked lvi of+ On -> [ Gtk.cellToggleInconsistent := False+ , Gtk.cellToggleActive := True+ ]+ Off -> [ Gtk.cellToggleInconsistent := False+ , Gtk.cellToggleActive := False+ ]+ Inconsistent -> [ Gtk.cellToggleActive := False+ , Gtk.cellToggleInconsistent := True+ ]++ void $ Gtk.treeViewAppendColumn treeview colSignal+ void $ Gtk.treeViewAppendColumn treeview colVisible++ let -- traverse the whole graph and update the list of getters and the title+ updateGettersAndTitle = do+ -- first get all trees+ let getTrees k = do+ tree' <- Gtk.treeStoreLookup treeStore [k]+ case tree' of Nothing -> return []+ Just tree -> fmap (tree:) (getTrees (k+1))+ theTrees <- getTrees 0+ let newGetters0 :: [([String], IO [[(Double, Double)]])]+ newGetters0 =+ [ (name, getter <$> readIORef plotValueRef)+ | ListViewInfo+ { lviName = name+ , lviTypeOrGetter = Right getter+ , lviMarked = On+ , lviPlotValueRef = plotValueRef+ } <- concatMap Tree.flatten theTrees+ ]++ let newGetters :: [(String, IO [[(Double, Double)]])]+ newTitle :: Maybe String+ (newGetters, newTitle) = gettersAndTitle newGetters0++ void $ newTitle `seq` newGetters `seq`+ CC.swapMVar graphInfoMVar (newTitle, newGetters)++ i2p i = Gtk.treeModelGetPath treeStore i+ p2i p = do+ mi <- Gtk.treeModelGetIter treeStore p+ case mi of Nothing -> error "no iter at that path"+ Just i -> return i++ -- update which y axes are visible+ _ <- on rendererVisible Gtk.cellToggled $ \pathStr -> do+ let treePath = Gtk.stringToTreePath pathStr++ getChildrenPaths path' = do+ iter' <- p2i path'+ let getChildPath k = do+ mc <- Gtk.treeModelIterNthChild treeStore (Just iter') k+ case mc of+ Nothing -> error "no child"+ Just c -> i2p c+ n <- Gtk.treeModelIterNChildren treeStore (Just iter')+ mapM getChildPath (take n [0..])++ changeSelfAndChildren change path' = do+ childrenPaths <- getChildrenPaths path'+ ret <- Gtk.treeStoreChange treeStore path' change+ when (not ret) $ error "treeStoreChange fail"+ mapM_ (changeSelfAndChildren change) childrenPaths++ fixInconsistent path' = do+ mparentIter <- p2i path' >>= Gtk.treeModelIterParent treeStore+ case mparentIter of+ Nothing -> return ()+ Just parentIter -> do+ parentPath <- i2p parentIter+ siblingPaths <- getChildrenPaths parentPath+ siblings <- mapM (Gtk.treeStoreGetValue treeStore) siblingPaths+ let markedSiblings :: [MarkedState]+ markedSiblings = map lviMarked siblings++ changeParent+ | all (== On) markedSiblings =+ Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = On})+ | all (== Off) markedSiblings =+ Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = Off})+ | otherwise =+ Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = Inconsistent})+ ret <- changeParent+ when (not ret) $ error "fixInconsistent couldn't change parent"+ fixInconsistent parentPath+ return ()++ -- toggle the check mark+ val <- Gtk.treeStoreGetValue treeStore treePath+ case val of+ (ListViewInfo {lviTypeOrGetter = Left _, lviMarked = Off}) ->+ changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath+ (ListViewInfo {lviTypeOrGetter = Left _, lviMarked = On}) ->+ changeSelfAndChildren (\lvi -> lvi {lviMarked = Off}) treePath+ (ListViewInfo {lviTypeOrGetter = Left _, lviMarked =Inconsistent}) ->+ changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath+ lvi@(ListViewInfo {lviTypeOrGetter = Right _, lviMarked = On}) ->+ Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = Off}+ lvi@(ListViewInfo {lviTypeOrGetter = Right _, lviMarked = Off}) ->+ Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = On}+ (ListViewInfo {lviTypeOrGetter = Right _, lviMarked = Inconsistent}) ->+ error "cell getter can't be inconsistent"++ fixInconsistent treePath+ updateGettersAndTitle+ redraw++ let -- rebuild the signal tree+ rebuildSignalTree :: forall a . Element' a -> SignalTree a -> IO ()+ rebuildSignalTree element meta = do+ let channel = eChannel element+ elementIndex = eIndex element+ putStrLn $ "rebuilding signal tree for " ++ show (chanName channel)++ mtreeIter <- Gtk.treeModelIterNthChild treeStore Nothing elementIndex++ treePath <- case mtreeIter of+ Nothing -> error $ "rebuildSignalTree: error looking up channel index " ++ show elementIndex+ Just treeIter -> i2p treeIter++ unless (treePath == [elementIndex]) $ error "rebuildSignalTree: I don't understand tree paths"++ moldTree <- Gtk.treeStoreLookup treeStore treePath+ oldTree <- case moldTree of+ Nothing -> error "rebuildSignalTree: the old tree wasn't found"+ Just r -> return r+ let _ = oldTree :: Tree ListViewInfo++ plotValueRef :: IORef a+ plotValueRef = ePlotValueRef element++ merge :: [Tree ListViewInfo]+ -> [Tree ([String], Either String (a -> [[(Double, Double)]]))]+ -> [Tree ListViewInfo]+ merge old new = map convert new+ where+ oldMap :: M.Map ([String], Maybe String) (ListViewInfo, [Tree ListViewInfo])+ oldMap = M.fromList $ map f old+ where+ f (Tree.Node lvi lvis) = ((lviName lvi, maybeType), (lvi, lvis))+ where+ maybeType = case lvi of+ ListViewInfo {lviTypeOrGetter = Left typ} -> Just typ+ _ -> Nothing++ convert :: Tree ([String], Either String (a -> [[(Double, Double)]]))+ -> Tree ListViewInfo+ convert (Tree.Node (name, tog) others) = case M.lookup (name, maybeType) oldMap of+ Nothing -> Tree.Node (ListViewInfo name tog Off plotValueRef) (merge [] others)+ Just (lvi, oldOthers) ->+ Tree.Node (ListViewInfo name tog (lviMarked lvi) plotValueRef) (merge oldOthers others)+ where+ maybeType = case tog of+ Left r -> Just r+ Right _ -> Nothing++ newTree :: Tree ListViewInfo+ newTree = case merge [oldTree] [meta] of+ [r] -> r+ [] -> error "rebuildSignalTree: merged old tree with new tree and got []"+ _ -> error "rebuildSignalTree: merged old tree with new tree and got a forest"++ removed <- Gtk.treeStoreRemove treeStore treePath+ unless removed $ error "rebuildSignalTree: error removing old tree"+ Gtk.treeStoreInsertTree treeStore [] elementIndex newTree+ updateGettersAndTitle++ toValues = do+ (mtitle, getters) <- CC.readMVar graphInfoMVar+ let _ = getters :: [(String, IO [[(Double, Double)]])]++ execGetter :: (String, IO [[(Double, Double)]]) -> IO (String, [[(Double, Double)]])+ execGetter (name, get) = do+ got <- get+ return (name, got)+ gotten <- mapM execGetter getters+ return (mtitle, gotten)++ return+ SignalSelector+ { ssTreeView = treeview+ , ssRebuildSignalTree = rebuildSignalTree+ , ssToPlotValues = toValues+ }++++-- The greatest common prefix will be the title.+-- Everything after that is the field name.+gettersAndTitle :: forall a . [([String], a)] -> ([(String, a)], Maybe String)+gettersAndTitle fullGetters =+ ( map (\(x,y) -> (intercalate "." x, y)) gettersWithPrefixRemoved+ , mtitle+ )+ where+ mtitle :: Maybe String+ mtitle = case titleNames of+ [] -> Nothing+ ts -> Just $ intercalate "." (reverse ts)++ titleNames :: [String]+ gettersWithPrefixRemoved :: [([String], a)]+ (titleNames, gettersWithPrefixRemoved) = splitPartialCommonPrefix $ splitCommonPrefixes [] fullGetters++splitCommonPrefixes :: forall a . [String] -> [([String], a)] -> ([String], [([String], a)])+splitCommonPrefixes titles getters0+ | any isNothing mheads = (titles, getters0)+ | otherwise = case heads of+ [] -> (titles, getters0)+ (prefix, _):others+ -- if all prefixes match, do another recursion+ | all ((prefix ==) . fst) others -> splitCommonPrefixes (prefix:titles) (map snd heads)+ -- otherwise we're done+ | otherwise -> (titles, getters0)+ where+ mheads :: [Maybe (String, ([String], a))]+ mheads = map mhead getters0++ heads :: [(String, ([String], a))]+ heads = map fromJust mheads++ -- split out the first element if there is one+ mhead :: ([String], a) -> Maybe (String, ([String], a))+ mhead (x:xs, y) = Just (x, (xs, y))+ mhead ([], _) = Nothing+++-- We've already split out all the common whole strings.+-- Now we want to get any partial strings.+splitPartialCommonPrefix :: ([String], [([String], a)]) -> ([String], [([String], a)])+splitPartialCommonPrefix (wholePrefixes, getters)+ -- if there is no common prefix, do nothing+ | null prefix = (wholePrefixes, getters)+ -- If there is a common prefix, add it to the wholePrefixes and remove it from the next names.+ | otherwise = (prefix:wholePrefixes, map (\(x,y) -> (removePrefix x, y)) getters)+ where+ removePrefix :: [String] -> [String]+ removePrefix [] = [] -- No names, I guess don't return anything. I think this is impossible+ removePrefix (x:xs) = case drop (length prefix) x of+ -- If the common prefix is a whole variable name, i guess we shouldn't remove it.+ [] -> x:xs+ -- Normal path+ r -> r:xs++ prefix :: String+ prefix+ | any null names = []+ | otherwise = case map head names of+ -- only do it if there are at least two+ first:others@(_:_) -> foldl' commonPrefix first others+ _ -> []+ where+ names :: [[String]]+ names = map fst getters++ commonPrefix (x:xs) (y:ys)+ | x == y = x : commonPrefix xs ys+ commonPrefix _ _ = []
src/SetHo/LookupTree.hs view
@@ -43,13 +43,24 @@ , seStagedSum :: DSimpleEnum , seListStore :: Gtk.ListStore String -- , seSpinAdjustment :: Gtk.Adjustment- } -- deriving Show+ }+instance Show SumElem where+ show se@(SumElem {}) =+ init $+ unlines+ [ "SumElem"+ , "{ seName = " ++ show (seName se)+ , ", seDName = " ++ seDName se+ , ", seUpstreamSum = " ++ show (seUpstreamSum se)+ , ", seStagedSum = " ++ show (seStagedSum se)+ , "}"+ ] data ListViewElement = LveField FieldElem | LveConstructor ConstructorElem | LveSum SumElem--- deriving Show+ deriving Show ddataToTree :: Maybe String -> Either DField DData -> IO (Tree ListViewElement) ddataToTree name (Left field) = return $ Node (LveField fe) []@@ -288,37 +299,57 @@ Just r -> return r :: IO (Tree ListViewElement) - let assertCompatible :: Bool -> IO ()- assertCompatible False = error "the \"impossible\" happened: trees aren't compatible"- assertCompatible True = return ()+ let assertCompatible :: Show a => Maybe String -> a -> a -> Bool -> IO ()+ assertCompatible _ _ _ True = return ()+ assertCompatible mdesc oldNode newNode False =+ error $+ unlines $+ [ "the \"impossible\" happened: trees aren't compatible"+ ,"old tree:"+ , show oldTree+ , ""+ , "new tree:"+ , show newTree+ , ""+ , "old node:"+ , show oldNode+ , ""+ , "new node:"+ , show newNode+ ] ++ case mdesc of+ Nothing -> []+ Just desc -> ["", desc] case (oldTree, newTree) of -- sums- (Node (LveSum oldSum) [], Node (LveSum newSum) []) -> do+ (Node oldNode@(LveSum oldSum) [], Node newNode@(LveSum newSum) []) -> do let (compatible, mergedSum) = mergeSums oldSum newSum- assertCompatible compatible+ assertCompatible Nothing oldNode newNode compatible changed <- Gtk.treeStoreChange treeStore treePath (const (LveSum mergedSum)) case changed of False -> error $ "merged sums didn't change" True -> return ()- (_, Node (LveSum _) []) -> assertCompatible False+ (oldNode, newNode@(Node (LveSum _) [])) ->+ assertCompatible (Just "got a mixed type") oldNode newNode False (_, Node (LveSum _) _) -> error "mergeTrees: new LveSum has children" -- fields- (Node (LveField oldField) [], Node (LveField newField) []) -> do+ (Node oldNode@(LveField oldField) [], Node newNode@(LveField newField) []) -> do let (compatible, mergedField) = mergeFields oldField newField- assertCompatible compatible+ assertCompatible Nothing oldNode newNode compatible changed <- Gtk.treeStoreChange treeStore treePath (const (LveField mergedField)) case changed of False -> error $ "merged fields didn't change" True -> return ()- (_, Node (LveField _) []) -> assertCompatible False+ (oldNode, newNode@(Node (LveField _) [])) ->+ assertCompatible (Just "got a mixed type") oldNode newNode False (_, Node (LveField _) _) -> error "mergeTrees: new LveField has children" -- constructors- (Node (LveConstructor oldCons) oldChildren, Node (LveConstructor newCons) newChildren)- | oldCons /= newCons -> assertCompatible False- | length oldChildren /= length newChildren -> assertCompatible False+ (Node oldNode@(LveConstructor oldCons) oldChildren, Node newNode@(LveConstructor newCons) newChildren)+ | oldCons /= newCons -> assertCompatible Nothing oldNode newNode False+ | length oldChildren /= length newChildren ->+ assertCompatible (Just "constructor length mismatch") oldNode newNode False | otherwise -> do mtreeIter <- Gtk.treeModelGetIter treeStore treePath treeIter <- case mtreeIter of@@ -344,7 +375,8 @@ mergeTrees childPath newChild mergeNthChild (k + 1) others mergeNthChild 0 newChildren- (_, Node (LveConstructor _) _) -> assertCompatible False+ (oldNode, newNode@(Node (LveConstructor _) _)) ->+ assertCompatible (Just "got a mixed type") oldNode newNode False receiveNewUpstream :: DTree -> IO () receiveNewUpstream newMsg = do