diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal index 2d92086..ce06351 100644 --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -30,6 +30,7 @@ library PlotHo.ChartRender PlotHo.HistoryChannel PlotHo.GraphWidget + PlotHo.MultiSelectWidget PlotHo.OptionsWidget PlotHo.Plotter PlotHo.PlotTypes diff --git a/src/PlotHo/GraphWidget.hs b/src/PlotHo/GraphWidget.hs index 68f2ab8..98367a9 100644 --- a/src/PlotHo/GraphWidget.hs +++ b/src/PlotHo/GraphWidget.hs @@ -4,6 +4,7 @@ module PlotHo.GraphWidget ( newGraph + , toElement' ) where import Control.Concurrent ( MVar ) @@ -25,7 +26,7 @@ import Graphics.Rendering.Chart ( RectSize ) import PlotHo.ChartRender ( toChartRender ) import PlotHo.OptionsWidget ( OptionsWidget(..), makeOptionsWidget ) import PlotHo.PlotTypes -import PlotHo.SignalSelector ( SignalSelector(..), newSignalSelectorArea ) +import PlotHo.SignalSelector ( SignalSelector(..), Selector(..), newSignalSelectorArea ) toElement' :: Int -> Channel' a -> IO (Element' a) @@ -53,8 +54,8 @@ toElement' index channel = do -- make a new graph window -newGraph :: PlotterOptions -> [Channel] -> IO Gtk.Window -newGraph options channels = do +newGraph :: PlotterOptions -> [Channel] -> Maybe (SignalSelector Selector) -> IO Gtk.Window +newGraph options channels mSignalSelector = do win <- Gtk.windowNew elements <- zipWithM (\k (Channel c) -> Element <$> toElement' k c) [0..] channels @@ -86,7 +87,7 @@ newGraph options channels = do void $ CC.swapMVar needRedrawMVar True Gtk.postGUIAsync (Gtk.widgetQueueDraw chartCanvas) - signalSelector <- newSignalSelectorArea elements redraw + signalSelector <- newSignalSelectorArea elements redraw mSignalSelector largestRangeMVar <- CC.newMVar (XY defaultHistoryRange defaultHistoryRange) optionsWidget <- makeOptionsWidget options largestRangeMVar redraw @@ -143,7 +144,7 @@ newGraph options channels = do 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} -> + SignalSelector {ssSelectors = Selector {sRebuildSignalTree = rebuildSignalTree}} -> rebuildSignalTree element newSignalTree -- write the data to the IORef so that the getters get the right stuff @@ -158,7 +159,7 @@ newGraph options channels = do -- 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 + (mtitle, namedPlotPoints) <- sToPlotValues (ssSelectors signalSelector) debug "handleDraw: got title and plot points" let -- update the min/max plot ranges diff --git a/src/PlotHo/MultiSelectWidget.hs b/src/PlotHo/MultiSelectWidget.hs new file mode 100644 index 0000000..c3162fe --- /dev/null +++ b/src/PlotHo/MultiSelectWidget.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -Wall #-} +{-# Language ScopedTypeVariables #-} +{-# LANGUAGE PackageImports #-} + +module PlotHo.MultiSelectWidget + ( multiSelectWidget + ) where + +import Control.Monad ( unless, void, zipWithM ) +import Control.Monad.IO.Class ( liftIO ) +import qualified Control.Concurrent as CC +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 System.Exit ( exitFailure ) +import System.Glib.Signals ( on ) +import Prelude + +import PlotHo.GraphWidget ( newGraph, toElement' ) +import PlotHo.PlotTypes ( Channel(..), Element(..), Element'(..), PlotterOptions(..) ) +import PlotHo.SignalSelector ( SignalSelector(..), Selector(..), newMultiSignalSelectorArea ) + + +-- | fire up the the GUI +multiSelectWidget :: Maybe PlotterOptions -> [Channel] -> Int -> IO (CC.MVar [Gtk.Window]) +multiSelectWidget mplotterOptions channels numGraphs = do + let plotterOptions = fromMaybe def mplotterOptions + + 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 + + -- start the main window + win <- Gtk.windowNew + void $ Gtk.set win + [ Gtk.containerBorderWidth := 8 + , Gtk.windowTitle := "Plot-ho-matic Multi Selector Deluxe" + ] + + -- on close of main, kill all the windows and threads + graphWindowsToBeKilled <- CC.newMVar [] + CC.modifyMVar_ graphWindowsToBeKilled (return . (win:)) + + let killEverything :: IO () + killEverything = do + Gtk.mainQuit + void $ on win Gtk.deleteEvent $ liftIO (killEverything >> return False) + + --------------- main widget ----------------- + + -- Multi Signal Selector + elements <- zipWithM (\k (Channel c) -> Element <$> toElement' k c) [0..] channels + multiSignalSelector <- newMultiSignalSelectorArea elements numGraphs + + -- refresh signal selector + buttonRefresh <- Gtk.buttonNewWithLabel "refresh" + void $ on buttonRefresh Gtk.buttonActivated (rebuildSignals elements multiSignalSelector) + + buttonSpawnPrefilledGraphs <- Gtk.buttonNewWithLabel "gen prefilled graphs" + void $ on buttonSpawnPrefilledGraphs Gtk.buttonActivated $ do + let genGraph selector = do + let signalSelector = + SignalSelector + { ssTreeView = ssTreeView multiSignalSelector + , ssTreeStore = ssTreeStore multiSignalSelector + , ssSelectors = selector + } + graphWin <- newGraph plotterOptions channels (Just signalSelector) + -- add this window to the list to be killed on exit + CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:)) + + mapM_ genGraph (ssSelectors multiSignalSelector) + Gtk.mainQuit + Gtk.widgetDestroy win + + treeviewScroll <- Gtk.scrolledWindowNew Nothing Nothing + Gtk.set treeviewScroll [Gtk.widgetVExpand := True] -- make sure it expands vertically + Gtk.containerAdd treeviewScroll (ssTreeView multiSignalSelector) + Gtk.set treeviewScroll + [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever + , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic + ] + treeviewExpander <- Gtk.expanderNew "sig" + Gtk.set treeviewExpander + [ Gtk.containerChild := treeviewScroll + , Gtk.expanderExpanded := True + ] + + -- vbox to hold everything + vbox <- Gtk.vBoxNew False 4 + Gtk.set vbox $ + [ Gtk.containerChild := buttonSpawnPrefilledGraphs + , Gtk.boxChildPacking buttonSpawnPrefilledGraphs := Gtk.PackNatural + , Gtk.containerChild := buttonRefresh + , Gtk.boxChildPacking buttonRefresh := Gtk.PackNatural + , Gtk.containerChild := treeviewExpander + , Gtk.boxChildPacking treeviewExpander := Gtk.PackGrow + ] + + void $ Gtk.widgetSetSizeRequest vbox 20 200 + + -- add widget to window and show + void $ Gtk.set win [ Gtk.containerChild := vbox ] + Gtk.widgetShowAll win + Gtk.mainGUI + -- Pass graphs back to main program + return graphWindowsToBeKilled + +rebuildSignals :: [Element] -> SignalSelector [Selector] -> IO () +rebuildSignals elements signalSelector = do + 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 -> do + let rebuilds = sRebuildSignalTree <$> (ssSelectors signalSelector) + mapM_ (\x -> x element newSignalTree) rebuilds + + -- write the data to the IORef so that the getters get the right stuff + IORef.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 \ No newline at end of file diff --git a/src/PlotHo/PlotTypes.hs b/src/PlotHo/PlotTypes.hs index 0b5205e..4c957ad 100644 --- a/src/PlotHo/PlotTypes.hs +++ b/src/PlotHo/PlotTypes.hs @@ -49,7 +49,7 @@ data ListViewInfo where ListViewInfo :: { lviName :: ![String] , lviTypeOrGetter :: !(Either String (a -> [[(Double,Double)]])) - , lviMarked :: !MarkedState + , lviMarked :: ![MarkedState] , lviPlotValueRef :: IORef a } -> ListViewInfo diff --git a/src/PlotHo/Plotter.hs b/src/PlotHo/Plotter.hs index 141d0bc..84e1776 100644 --- a/src/PlotHo/Plotter.hs +++ b/src/PlotHo/Plotter.hs @@ -8,7 +8,7 @@ module PlotHo.Plotter import qualified GHC.Stats -import Control.Monad ( unless, void ) +import Control.Monad ( unless, void, ) import Control.Monad.IO.Class ( MonadIO(..) ) import qualified Control.Concurrent as CC import Data.Default.Class ( def ) @@ -24,6 +24,7 @@ import Prelude import PlotHo.GraphWidget ( newGraph ) import PlotHo.PlotTypes ( Channel(..), Channel'(..), PlotterOptions(..) ) +import PlotHo.MultiSelectWidget ( multiSelectWidget ) -- | fire up the the GUI runPlotter :: Maybe PlotterOptions -> [Channel] -> IO () @@ -77,10 +78,45 @@ runPlotter mplotterOptions channels = do -- button to spawn a new graph buttonSpawnGraph <- Gtk.buttonNewWithLabel "new graph" void $ on buttonSpawnGraph Gtk.buttonActivated $ do - graphWin <- newGraph plotterOptions channels + graphWin <- newGraph plotterOptions channels Nothing -- add this window to the list to be killed on exit CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:)) + -- multi signal selector + -- set the number of graphs + numGraphsLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "num graphs:" + numGraphsEntry <- Gtk.entryNew + Gtk.set numGraphsEntry + [ Gtk.entryEditable := True + , Gtk.widgetSensitive := True + ] + Gtk.entrySetText numGraphsEntry "3" + let makeMultiGraphs = do + txt <- Gtk.get numGraphsEntry Gtk.entryText + case readMaybe txt :: Maybe Int of + Nothing -> + putStrLn ("num graphs: couldn't make an Int out of \"" ++ show txt ++ "\"") + Just 0 -> putStrLn "numGraphs: must be greater than 0" + Just k -> do + mVarMoreGraphsToKill <- multiSelectWidget mplotterOptions channels k + moreGraphsToKill <- CC.readMVar mVarMoreGraphsToKill + CC.modifyMVar_ graphWindowsToBeKilled (return . (moreGraphsToKill++)) + + -- make the button + buttonMultiSelector <- Gtk.buttonNewWithLabel "multigraph" + void $ on buttonMultiSelector Gtk.buttonActivated $ do + makeMultiGraphs + + hboxMultiSelector <- Gtk.hBoxNew False 4 + Gtk.set hboxMultiSelector + [ Gtk.containerChild := numGraphsLabel + , Gtk.boxChildPacking numGraphsLabel := Gtk.PackNatural + , Gtk.containerChild := numGraphsEntry + , Gtk.boxChildPacking numGraphsEntry := Gtk.PackNatural + , Gtk.containerChild := buttonMultiSelector + , Gtk.boxChildPacking buttonMultiSelector := Gtk.PackGrow + ] + -- clear history / max history widget for each channel chanWidgets <- mapM (\(Channel c) -> newChannelWidget c) channels @@ -105,6 +141,8 @@ runPlotter mplotterOptions channels = do , Gtk.boxChildPacking statsLabel := Gtk.PackNatural , Gtk.containerChild := buttonSpawnGraph , Gtk.boxChildPacking buttonSpawnGraph := Gtk.PackNatural + , Gtk.containerChild := hboxMultiSelector + , Gtk.boxChildPacking hboxMultiSelector := Gtk.PackNatural , Gtk.containerChild := scroll ] @@ -115,9 +153,6 @@ runPlotter mplotterOptions channels = do Gtk.widgetShowAll win Gtk.mainGUI - - - -- the list of channels newChannelWidget :: Channel' a -> IO Gtk.VBox newChannelWidget channel = do diff --git a/src/PlotHo/SignalSelector.hs b/src/PlotHo/SignalSelector.hs index c929d80..ba7a793 100644 --- a/src/PlotHo/SignalSelector.hs +++ b/src/PlotHo/SignalSelector.hs @@ -5,13 +5,16 @@ module PlotHo.SignalSelector ( SignalSelector(..) + , Selector(..) , newSignalSelectorArea + , newMultiSignalSelectorArea + , gettersAndTitle ) where import qualified Control.Concurrent as CC import Control.Monad ( unless, void, when ) import Data.IORef ( IORef, readIORef ) -import Data.List ( foldl', intercalate ) +import Data.List ( foldl', intercalate, elemIndex ) import qualified Data.Map as M import Data.Maybe ( isNothing, fromJust ) import Data.Tree ( Tree ) @@ -19,256 +22,407 @@ 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 System.Glib.UTFString ( DefaultGlibString ) import PlotHo.PlotTypes -data SignalSelector +data SignalSelector a = SignalSelector { ssTreeView :: Gtk.TreeView - , ssRebuildSignalTree :: forall a . Element' a -> SignalTree a -> IO () - , ssToPlotValues :: IO (Maybe String, [(String, [[(Double, Double)]])]) + , ssTreeStore :: Gtk.TreeStore ListViewInfo + , ssSelectors :: a } -newSignalSelectorArea :: [Element] -> IO () -> IO SignalSelector -newSignalSelectorArea elems redraw = do +data Selector + = Selector + { sRebuildSignalTree :: forall a . Element' a -> SignalTree a -> IO () + , sToPlotValues :: IO (Maybe String, [(String, [[(Double, Double)]])]) + , sColumnNumber :: Int -- ^ must be assigned after tree is built - a bit hacky :( + } + +newMultiSignalSelectorArea :: [Element] -> Int -> IO (SignalSelector [Selector]) +newMultiSignalSelectorArea elems numCols = do + + -- Be sure to get the # columns right or there will be a runtime error + treeStore <- Gtk.treeStoreNew $ initialForest elems (numCols + 1) + treeview <- Gtk.treeViewNewWithModel treeStore + + Gtk.treeViewSetHeadersVisible treeview True + + (setSignalAttrAndRender, _) <- signalColumn treeStore treeview "signal" + -- add some columns + + attrAndCol <- mapM (\n -> checkMarkColumn treeStore treeview ("Plot " ++ show n)) [1,2..numCols] + let (setAttrAndRenders, columns) = unzip $ attrAndCol + -- set the attributes + sequence_ setAttrAndRenders + setSignalAttrAndRender + + let toSelector :: Gtk.TreeViewColumn -> IO Selector + toSelector column = do + graphInfoMVar <- CC.newMVar (Nothing, []) + colNum <- getColumnNumber treeview column + let updateGettersAndTitle' = updateGettersAndTitle graphInfoMVar treeStore colNum + return $ + Selector + { sRebuildSignalTree = rebuildSignalTree treeStore updateGettersAndTitle' treeview + , sToPlotValues = toValues graphInfoMVar + , sColumnNumber = colNum + } + selectors <- mapM toSelector columns + + return $ + SignalSelector + { ssTreeView = treeview + , ssTreeStore = treeStore + , ssSelectors = selectors + } + +newSignalSelectorArea :: [Element] -> IO () + -> Maybe (SignalSelector Selector) + -> IO (SignalSelector Selector) +newSignalSelectorArea elems redraw mSigSelector = 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 + treeStore <- case (ssTreeStore <$> mSigSelector) of + Just t -> return t + Nothing -> Gtk.treeStoreNew $ initialForest elems 2 treeview <- Gtk.treeViewNewWithModel treeStore Gtk.treeViewSetHeadersVisible treeview True -- add some columns - colSignal <- Gtk.treeViewColumnNew + -- the signal column + (setSignalAttrAndRender, _) <- signalColumn treeStore treeview "signal" + + -- the selection column 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 + appendColumn treeview colVisible - 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 + -- Now, we can set the attributes and render since the order of the columns is set. + colVisibleNumber <- case ((sColumnNumber . ssSelectors) <$> mSigSelector) of + Nothing -> getColumnNumber treeview colVisible + Just i -> return i + let updateGettersAndTitle' = updateGettersAndTitle graphInfoMVar treeStore colVisibleNumber + Gtk.cellLayoutSetAttributes colVisible rendererVisible treeStore $ \lvi -> (markedAttribute colVisibleNumber lvi) - -- 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) + setSignalAttrAndRender + + _ <- on rendererVisible Gtk.cellToggled $ \pathStr -> renderPlotSignal colVisibleNumber treeStore pathStr redraw updateGettersAndTitle' return SignalSelector { ssTreeView = treeview - , ssRebuildSignalTree = rebuildSignalTree - , ssToPlotValues = toValues + , ssTreeStore = treeStore + , ssSelectors = + Selector + { sRebuildSignalTree = rebuildSignalTree treeStore updateGettersAndTitle' treeview + , sToPlotValues = toValues graphInfoMVar + , sColumnNumber = colVisibleNumber + } } +signalColumn :: forall a . Gtk.TreeViewClass a => Gtk.TreeStore ListViewInfo -> a -> String + -> IO (IO (), Gtk.TreeViewColumn) +signalColumn treeStore treeview columnName = do + colSignal <- Gtk.treeViewColumnNew + Gtk.treeViewColumnSetTitle colSignal columnName + rendererSignal <- Gtk.cellRendererTextNew + Gtk.treeViewColumnPackStart colSignal rendererSignal True + appendColumn treeview colSignal + let setAttributeAndRender :: IO () + setAttributeAndRender = + Gtk.cellLayoutSetAttributes colSignal rendererSignal treeStore $ + \ListViewInfo {lviName = name, lviTypeOrGetter = typeOrGetter} -> + [ Gtk.cellText := showName typeOrGetter (reverse name) + ] + return (setAttributeAndRender, colSignal) + + +checkMarkColumn :: forall a . Gtk.TreeViewClass a => Gtk.TreeStore ListViewInfo -> a -> String + -> IO (IO (), Gtk.TreeViewColumn) +checkMarkColumn treeStore treeview columnName = do + colCheckMark <- Gtk.treeViewColumnNew + Gtk.treeViewColumnSetTitle colCheckMark columnName + rendererCheckMark <- Gtk.cellRendererToggleNew + Gtk.treeViewColumnPackStart colCheckMark rendererCheckMark True + appendColumn treeview colCheckMark + let setAttributeAndRender :: IO () + setAttributeAndRender = do + colNum <- getColumnNumber treeview colCheckMark + Gtk.cellLayoutSetAttributes colCheckMark rendererCheckMark treeStore $ \lvi -> (markedAttribute colNum lvi) + _ <- on rendererCheckMark Gtk.cellToggled $ \pathStr -> toggleCheckMark treeStore colNum pathStr + return () + -- update which y axes are CheckMark + return (setAttributeAndRender, colCheckMark) + +appendColumn :: forall a . Gtk.TreeViewClass a => a -> Gtk.TreeViewColumn -> IO () +appendColumn treeview col = do + void $ Gtk.treeViewAppendColumn treeview col + --TODO(rebecca): append proper number of columns to lvi? maybe + + +initialForest :: [Element] -> Int -> [Tree ListViewInfo] +initialForest elems numCols = map (\(Element e) -> toNode e) elems + where + toNode :: Element' a -> Tree ListViewInfo + toNode element = + Tree.Node + { Tree.rootLabel = + ListViewInfo + { lviName = [chanName (eChannel element)] + , lviMarked = take numCols $ repeat Off + , lviTypeOrGetter = Left "" + , lviPlotValueRef = ePlotValueRef element + } + , Tree.subForest = [] + } + +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" + +getColumnNumber :: forall a . Gtk.TreeViewClass a => a -> Gtk.TreeViewColumn -> IO Int +getColumnNumber treeview col = do + cols <- Gtk.treeViewGetColumns treeview + let mColNum = elemIndex col cols + case mColNum of + Just n -> return n + Nothing -> error "can't find column number" + +setMark :: Int -> [MarkedState] -> MarkedState -> [MarkedState] +setMark colNum oldStates mark = take colNum oldStates ++ [mark] ++ drop (colNum + 1) oldStates + +getMark :: Int -> [MarkedState] -> MarkedState +getMark colNum oldStates = oldStates !! colNum + +markedAttribute :: Int -> ListViewInfo -> [AttrOp Gtk.CellRendererToggle] +markedAttribute colNum lvi = case ((lviMarked lvi) !! colNum) of + On -> [ Gtk.cellToggleInconsistent := False + , Gtk.cellToggleActive := True + ] + Off -> [ Gtk.cellToggleInconsistent := False + , Gtk.cellToggleActive := False + ] + Inconsistent -> [ Gtk.cellToggleActive := False + , Gtk.cellToggleInconsistent := True + ] + + +toggleCheckMark :: Gtk.TreeStore ListViewInfo -> Int -> DefaultGlibString -> IO () +toggleCheckMark treeStore colNum pathStr = do + let treePath = Gtk.stringToTreePath pathStr + + (_, changeSelfAndChildren) = getChildrenFuns treeStore + + val <- Gtk.treeStoreGetValue treeStore treePath + let mark = getMark colNum (lviMarked val) + changeMark lvi newMark = lvi { lviMarked = setMark colNum (lviMarked lvi) newMark } + case (val, mark) of + (ListViewInfo {lviTypeOrGetter = Left _ }, Off) -> + changeSelfAndChildren (\lvi -> changeMark lvi On) treePath + (ListViewInfo {lviTypeOrGetter = Left _ } ,On) -> + changeSelfAndChildren (\lvi -> changeMark lvi Off) treePath + (ListViewInfo {lviTypeOrGetter = Left _ }, Inconsistent) -> + changeSelfAndChildren (\lvi -> changeMark lvi On) treePath + (lvi@(ListViewInfo {lviTypeOrGetter = Right _}), On) -> + Gtk.treeStoreSetValue treeStore treePath $ changeMark lvi Off + (lvi@(ListViewInfo {lviTypeOrGetter = Right _}), Off) -> + Gtk.treeStoreSetValue treeStore treePath $ changeMark lvi On + (ListViewInfo {lviTypeOrGetter = Right _}, Inconsistent) -> + error "cell getter can't be inconsistent" + +renderPlotSignal :: Int -> Gtk.TreeStore ListViewInfo -> DefaultGlibString -> IO () -> IO () -> IO () +renderPlotSignal colNum treeStore pathStr redraw updateGettersAndTitle' = do + let 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 + + treePath = Gtk.stringToTreePath pathStr + (getChildrenPaths, _) = getChildrenFuns treeStore + + 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 + parentLvi <- Gtk.treeStoreGetValue treeStore parentPath + let changeParentMark = setMark colNum (lviMarked parentLvi) + markedSiblings :: [MarkedState] + markedSiblings = map ((getMark colNum) . lviMarked) siblings + + changeParent + | all (== On) markedSiblings = + Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = changeParentMark On}) + | all (== Off) markedSiblings = + Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = changeParentMark Off}) + | otherwise = + Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = changeParentMark Inconsistent}) + ret <- changeParent + when (not ret) $ error "fixInconsistent couldn't change parent" + fixInconsistent parentPath + return () + -- toggle the check mark + toggleCheckMark treeStore colNum pathStr + fixInconsistent treePath + updateGettersAndTitle' + redraw + +getChildrenFuns :: Gtk.TreeStore ListViewInfo -> (Gtk.TreePath + -> IO [Gtk.TreePath], (ListViewInfo -> ListViewInfo) -> Gtk.TreePath -> IO ()) +getChildrenFuns treeStore = (getChildrenPaths, changeSelfAndChildren) + where + 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 + + 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 + +-- traverse the whole graph and update the list of getters and the title +updateGettersAndTitle :: CC.MVar (Maybe String, [(String, IO [[(Double, Double)]])]) + -> Gtk.TreeStore ListViewInfo -> Int -> IO () +updateGettersAndTitle graphInfoMVar treeStore colNum = 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 = zip names (gots <$> goodLvis) + where + goodLvis = [x | x <- (concatMap Tree.flatten theTrees),isGoodLvi x] + isGoodLvi lvi = (getMark colNum (lviMarked lvi)) == On && rights lvi + where + rights ListViewInfo { lviTypeOrGetter = t } = case t of + Right _ -> True + Left _ -> False + names = lviName <$> goodLvis + gots ListViewInfo{ lviTypeOrGetter = Right getter, lviPlotValueRef = plotValRef} = getter <$> readIORef plotValRef + gots ListViewInfo{ lviTypeOrGetter = Left _, lviPlotValueRef = _} = error "error parsing getters" + {-where + getter ListViewInfo { lviTypeOrGetter = t } = case t of + Right g -> g + Left _ -> error "update getters and title left not filtered" + plotValRef ListViewInfo { lviPlotValueRef = p } = p-} + + let newGetters :: [(String, IO [[(Double, Double)]])] + newTitle :: Maybe String + (newGetters, newTitle) = gettersAndTitle newGetters0 + + void $ newTitle `seq` newGetters `seq` + CC.swapMVar graphInfoMVar (newTitle, newGetters) + +rebuildSignalTree :: forall a t . Gtk.TreeViewClass t + => Gtk.TreeStore ListViewInfo -> IO () -> t + -> Element' a -> SignalTree a + -> IO () +rebuildSignalTree treeStore updateGettersAndTitle' treeview 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 + where + i2p i = Gtk.treeModelGetPath treeStore i + 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 + + columns <- Gtk.treeViewGetColumns treeview + 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 (take (length columns) (repeat 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 :: CC.MVar (Maybe String, [(String, IO [[(Double, Double)]])]) + -> IO (Maybe String, [(String, [[(Double, Double)]])]) +toValues graphInfoMVar = 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) -- The greatest common prefix will be the title. -- Everything after that is the field name.