diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,60 +1,70 @@ -0.1 +0.9.0.2 --- -* Initial release (moved from rawesome repo) +* Add autocommit toggle +* Add "take upstream" button +* Implemented saving/loading files -0.2 +0.9.0.1 --- -* Cleaner API +* workaround issue where toggling expander hides the plot -0.3 (Unreleased development version) +0.9.0.0 --- -* switch from Template Haskell to GHC.Generics +* generic-accessors 0.6.0.0 compatibility +* rewrite settings app to use dynamic data +* upgrade to GTK3 -0.4 +0.8.0.0 --- -* Performance improvements -* Safer monadic API -* More general plottable types +* Switch from Tree ([String], String, Maybe (a -> [[(Double, Double)]])) + to Tree ([String], Either String (a -> [[(Double, Double)]])) -0.4.0.4 +0.7.0.1 --- -remove Generic requirement for some Lookup instances +* Make the list of channels a scrollable thing. -0.5.0.0 +0.7.0.0 --- -* Use Accessors from generic-accessors package -* Major performance improvements (only draw new data) -* Both "history" and custom plot interfaces -* Unify this package with the dynobud plotter +* Better legend and title. +0.5.0.5 +--- +* Compatability with generic-accessors 0.2 + +0.5.0.4 +--- +* Performance improvement + 0.5.0.1 --- * Hierarchical visibility clicking and inconsistent state * Merge new signal tree with old -0.5.0.4 +0.5.0.0 --- -* Performance improvement +* Use Accessors from generic-accessors package +* Major performance improvements (only draw new data) +* Both "history" and custom plot interfaces +* Unify this package with the dynobud plotter -0.5.0.5 +0.4.0.4 --- -* Compatability with generic-accessors 0.2 +remove Generic requirement for some Lookup instances -0.7.0.0 +0.4 --- -* Better legend and title. +* Performance improvements +* Safer monadic API +* More general plottable types -0.7.0.1 +0.3 (Unreleased development version) --- -* Make the list of channels a scrollable thing. +* switch from Template Haskell to GHC.Generics -0.8.0.0 +0.2 --- -* Switch from Tree ([String], String, Maybe (a -> [[(Double, Double)]])) - to Tree ([String], Either String (a -> [[(Double, Double)]])) +* Cleaner API -0.9.0.0 +0.1 --- -* generic-accessors 0.6.0.0 compatibility -* rewrite settings app to use dynamic data -* upgrade to GTK3 +* Initial release (moved from rawesome repo) diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -1,5 +1,5 @@ name: Plot-ho-matic -version: 0.9.0.1 +version: 0.9.0.2 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE @@ -31,7 +31,9 @@ SetHo.LookupTree SetHo.OptionsWidget build-depends: base >= 4.6.0.0 && < 5 + , cereal , containers + , bytestring , lens , data-default-class , glib diff --git a/src/SetHo.hs b/src/SetHo.hs --- a/src/SetHo.hs +++ b/src/SetHo.hs @@ -13,15 +13,15 @@ import Accessors.Dynamic ( DTree ) import qualified Control.Concurrent as CC import Control.Monad.IO.Class ( liftIO ) +import qualified Data.ByteString.Lazy as BSL +import Data.Serialize ( encodeLazy, decodeLazy ) import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified "gtk3" Graphics.UI.Gtk as Gtk import Text.Printf ( printf ) import System.Glib.Signals ( on ) import SetHo.LookupTree ( newLookupTreeview ) -import SetHo.OptionsWidget ( GraphInfo(..), makeOptionsWidget ) - -- | fire up the the GUI runSetter :: String -> DTree -> IO (Maybe DTree) -> IO () -> (DTree -> IO ()) -> IO () runSetter rootName initialValue userPollForNewMessage sendRequest commit = do @@ -67,38 +67,56 @@ --------------- main widget ----------------- buttonCommit <- Gtk.buttonNewWithLabel "commit" + buttonAutoCommit <- Gtk.checkButtonNewWithLabel "auto-commit" buttonRefresh <- Gtk.buttonNewWithLabel "refresh" - Gtk.widgetSetTooltipText buttonCommit (Just "SET ME SET ME GO HEAD DO IT COME ON SET ME") - - -- mvar with all the user input - graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = True - , giXRange = Nothing - } :: IO (CC.MVar GraphInfo) + buttonTakeUpstream <- Gtk.buttonNewWithLabel "take upstream" + Gtk.widgetSetTooltipText buttonCommit + (Just "SET ME SET ME GO HEAD DO IT COME ON SET ME") + Gtk.widgetSetTooltipText buttonAutoCommit + (Just "Send settings upstream as soon as any value is changed") -- the options widget - optionsWidget <- makeOptionsWidget graphInfoMVar options <- Gtk.expanderNew "options" - Gtk.set options [ Gtk.containerChild := optionsWidget - , Gtk.expanderExpanded := False + Gtk.set options [ Gtk.containerChild := buttonAutoCommit + , Gtk.expanderExpanded := True ] + -- the signal selector - (treeview, getLatestStaged, receiveNewValue) <- newLookupTreeview rootName initialValue + (treeview, getLatestStaged, receiveNewUpstream, takeLatestUpstream, loadFromFile) <- + newLookupTreeview rootName initialValue (Gtk.toggleButtonGetActive buttonAutoCommit) commit treeviewExpander <- Gtk.expanderNew "signals" Gtk.set treeviewExpander [ Gtk.containerChild := treeview , Gtk.expanderExpanded := True ] + let menuBarDescription = + [ ("_File", [ ("Load", Just (loadFile win loadFromFile)) + , ("Save", Just (saveFile win getLatestStaged)) + , ("_Quit", Just Gtk.mainQuit) + ] + ) + , ("Help", [ ("_Help", Just (help win)) + ] + ) + ] + + menuBar <- createMenuBar menuBarDescription + -- vbox to hold buttons and list of channel vbox <- Gtk.vBoxNew False 4 Gtk.set vbox - [ Gtk.containerChild := statsLabel + [ Gtk.containerChild := menuBar + , Gtk.boxChildPacking menuBar := Gtk.PackNatural + , Gtk.containerChild := statsLabel , Gtk.boxChildPacking statsLabel := Gtk.PackNatural , Gtk.containerChild := buttonCommit , Gtk.boxChildPacking buttonCommit := Gtk.PackNatural , Gtk.containerChild := buttonRefresh , Gtk.boxChildPacking buttonRefresh := Gtk.PackNatural + , Gtk.containerChild := buttonTakeUpstream + , Gtk.boxChildPacking buttonTakeUpstream := Gtk.PackNatural , Gtk.containerChild := options , Gtk.boxChildPacking options := Gtk.PackNatural , Gtk.containerChild := treeviewExpander @@ -111,15 +129,106 @@ _ <- on buttonRefresh Gtk.buttonActivated sendRequest + _ <- on buttonTakeUpstream Gtk.buttonActivated takeLatestUpstream + let pollForNewMessage = do mmsg <- userPollForNewMessage case mmsg of Nothing -> return () - Just newVal -> receiveNewValue newVal + Just newVal -> receiveNewUpstream newVal _ <- Gtk.timeoutAddFull (pollForNewMessage >> return True) Gtk.priorityDefault 300 -- add widget to window and show - _ <- Gtk.set win [ Gtk.containerChild := vbox ] + _ <- Gtk.set win [ Gtk.windowTitle := "set-ho-matic 2000" + , Gtk.containerChild := vbox + ] Gtk.widgetShowAll win Gtk.mainGUI + +createMenuBar :: [( String + + , [( String + , Maybe (IO ()) + )] + )] -> IO Gtk.MenuBar +createMenuBar descr + = do bar <- Gtk.menuBarNew + mapM_ (createMenu bar) descr + return bar + where + createMenu bar (name,items) + = do menu <- Gtk.menuNew + item <- menuItemNewWithLabelOrMnemonic name + Gtk.menuItemSetSubmenu item menu + Gtk.menuShellAppend bar item + mapM_ (createMenuItem menu) items + createMenuItem menu (name,action) + = do item <- menuItemNewWithLabelOrMnemonic name + Gtk.menuShellAppend menu item + case action of + Just act -> on item Gtk.menuItemActivate act + Nothing -> on item Gtk.menuItemActivate (return ()) + menuItemNewWithLabelOrMnemonic name + | elem '_' name = Gtk.menuItemNewWithMnemonic name + | otherwise = Gtk.menuItemNewWithLabel name + + +loadFile :: Gtk.Window -> (DTree -> IO ()) -> IO () +loadFile win loadData = do + dialog <- Gtk.fileChooserDialogNew (Just "load settings") (Just win) + Gtk.FileChooserActionOpen + [ ("Cancel", Gtk.ResponseCancel) + , ("Load", Gtk.ResponseAccept) + ] + responseId <- Gtk.dialogRun dialog + case responseId of + Gtk.ResponseAccept -> do + mfileName <- Gtk.fileChooserGetFilename dialog + case mfileName of + Nothing -> error "fileChooserGetFileName failed on ResponseAccept" + Just path -> do + bs <- BSL.readFile path + case decodeLazy bs of + Left msg -> errorMsg win ("error decoding " ++ show path ++ "\n" ++ msg) + Right r -> loadData r >> putStrLn ("loaded " ++ show path) + _ -> return () + Gtk.widgetDestroy dialog + + +saveFile :: Gtk.Window -> IO DTree -> IO () +saveFile win getLatestStaged = do + dialog <- Gtk.fileChooserDialogNew (Just "save settings") (Just win) + Gtk.FileChooserActionSave + [ ("Cancel", Gtk.ResponseCancel) + , ("Save", Gtk.ResponseAccept) + ] + Gtk.fileChooserSetDoOverwriteConfirmation dialog True + responseId <- Gtk.dialogRun dialog + case responseId of + Gtk.ResponseAccept -> do + mfileName <- Gtk.fileChooserGetFilename dialog + case mfileName of + Nothing -> error "fileChooserGetFileName failed on ResponseAccept" + Just fileName -> do + staged <- getLatestStaged + BSL.writeFile fileName (encodeLazy staged) + putStrLn $ "saved settings in " ++ show fileName + _ -> return () + Gtk.widgetDestroy dialog + +help :: Gtk.Window -> IO () +help win = do + dialog <- Gtk.messageDialogNew (Just win) [Gtk.DialogDestroyWithParent] + Gtk.MessageInfo Gtk.ButtonsOk + "There is no help for you here." + _responseId <- Gtk.dialogRun dialog + Gtk.widgetDestroy dialog + +errorMsg :: Gtk.Window -> String -> IO () +errorMsg win message = do + dialog <- Gtk.messageDialogNew (Just win) [Gtk.DialogDestroyWithParent] + Gtk.MessageError Gtk.ButtonsOk + message + _responseId <- Gtk.dialogRun dialog + Gtk.widgetDestroy dialog diff --git a/src/SetHo/LookupTree.hs b/src/SetHo/LookupTree.hs --- a/src/SetHo/LookupTree.hs +++ b/src/SetHo/LookupTree.hs @@ -115,11 +115,39 @@ treeToStagedDData (Node (LveSum _) _) = error $ "treeToStagedDData: LveSum has children" + +treeToUpstreamDData :: Tree ListViewElement -> Either DField DData +treeToUpstreamDData (Node (LveField fe) []) = Left (feUpstreamField fe) +treeToUpstreamDData (Node (LveField fe) _) = + error $ "treeToUpstreamDData: LveField " ++ show fe ++ " has children" +treeToUpstreamDData (Node (LveConstructor ce) fields) = + Right (DData dname (DConstructor cname (map f fields))) + where + dname = ceDName ce + cname = ceCName ce + + getName :: Tree ListViewElement -> Maybe String + getName (Node (LveSum se) _) = seName se + getName (Node (LveConstructor ce') _) = ceName ce' + getName (Node (LveField fe) _) = feName fe + + f x = (getName x, treeToUpstreamDData x) +treeToUpstreamDData (Node (LveSum se) []) = + Right (DData dname (DSum s)) + where + dname = seDName se + s = seUpstreamSum se +treeToUpstreamDData (Node (LveSum _) _) = + error $ "treeToUpstreamDData: LveSum has children" + + newLookupTreeview :: String -> DTree - -> IO (Gtk.ScrolledWindow, IO DTree, DTree -> IO ()) -newLookupTreeview rootName initialValue = do + -> IO Bool + -> (DTree -> IO ()) + -> IO (Gtk.ScrolledWindow, IO DTree, DTree -> IO (), IO (), DTree -> IO ()) +newLookupTreeview rootName initialValue getAutocommit commit = do treeStore <- Gtk.treeStoreNew [] :: IO (Gtk.TreeStore ListViewElement) treeview <- Gtk.treeViewNewWithModel treeStore :: IO Gtk.TreeView @@ -164,6 +192,7 @@ _ <- Gtk.treeViewAppendColumn treeview colCombo -- _ <- Gtk.treeViewAppendColumn treeview colSpin + ----------------------------- showing values ------------------------ -- data name let showName :: ListViewElement -> String showName (LveSum se) = fromMName $ seName se @@ -225,32 +254,6 @@ , Gtk.cellTextEditable := False ] - let modifyField :: DField -> String -> DField - modifyField f0@(DDouble _) txt = case readMaybe txt of - Nothing -> f0 - Just x -> DDouble x - modifyField f0@(DFloat _) txt = case readMaybe txt of - Nothing -> f0 - Just x -> DFloat x - modifyField f0@(DInt _) txt = case readMaybe txt of - Nothing -> f0 - Just x -> DInt x - modifyField (DString _) txt = DString txt - modifyField DSorry _ = DSorry - - modifySum :: DSimpleEnum -> String -> DSimpleEnum - modifySum denum txt = case denumSetString denum txt of - Left _ -> denum - Right r -> r - - _ <- on rendererStagedValue Gtk.edited $ \treePath txt -> do - lve0 <- Gtk.treeStoreGetValue treeStore treePath - let lve = case lve0 of - LveField fe -> LveField (fe {feStagedField = modifyField (feStagedField fe) txt}) - LveSum se -> LveSum (se {seStagedSum = modifySum (seStagedSum se) txt}) - ce@(LveConstructor _) -> ce -- not editible anyway - Gtk.treeStoreSetValue treeStore treePath lve - -- combo box Gtk.cellLayoutSetAttributes colCombo rendererCombo treeStore $ \lve -> case lve of @@ -263,7 +266,8 @@ _ -> [ Gtk.cellMode := Gtk.CellRendererModeInert , Gtk.cellText := "" ] - + -- workaround to make sure combo box is displaying correctly, see + -- http://stackoverflow.com/questions/35147473/cant-get-gtk2-cellrenderercombo-to-display-anything _ <- on rendererCombo Gtk.editingStarted $ \widget treePath -> do lve <- Gtk.treeStoreGetValue treeStore treePath case lve of @@ -277,91 +281,7 @@ Gtk.comboBoxSetActive comboBox active - _ <- on rendererCombo Gtk.edited $ \treePath newVal -> do - lve0 <- Gtk.treeStoreGetValue treeStore treePath - let newLve = case lve0 of - LveSum se -> LveSum (se {seStagedSum = case denumSetString (seStagedSum se) newVal of - Left msg -> error $ "error updating sum elem: " ++ msg - Right r -> r - }) - LveField _ -> error "cell renderer edited on Field" - LveConstructor _ -> error "cell renderer edited on Constructor" - Gtk.treeStoreSetValue treeStore treePath newLve - - --- -- spin button for enums --- Gtk.cellLayoutSetAttributes colSpin rendererSpin treeStore $ \lve -> --- case lve of ----- LveField _ -> [ Gtk.cellText := "" ----- , Gtk.cellComboHasEntry := False ----- ] ----- LveConstructor _ -> [ Gtk.cellText := "" ----- , Gtk.cellComboHasEntry := False ----- ] --- LveSum (SumElem {seStagedSum = denum, seSpinAdjustment = adjustment}) -> --- [ Gtk.cellRendererSpinAdjustment := adjustment ----- , Gtk.cellText := denumToStringOrMsg denum --- , Gtk.cellMode := Gtk.CellRendererModeActivatable ----- , Gtk.cellMode := Gtk.CellRendererModeEditable --- , Gtk.cellTextEditable := True --- , Gtk.cellVisible := True --- , Gtk.cellSensitive := True ----- , Gtk.cellComboHasEntry := False --- ] --- _ -> [] --- --- _ <- on rendererSpin Gtk.editingStarted $ \widget treePath -> do --- putStrLn "spin renderer is being edited" --- ----- _ <- Gtk.onValueChanged AdjChangedon rendererSpin Gtk.edited $ \treePath (newVal :: String) -> do ----- putStrLn "combo box is being edited" ----- lve0 <- Gtk.treeStoreGetValue treeStore treePath ----- let newLve = case lve0 of ----- LveSum se -> LveSum (se {seStagedSum = case denumSetString (seStagedSum se) newVal of ----- Left msg -> error $ "error updating sum elem: " ++ msg ----- Right r -> r ----- }) ----- LveField _ -> error "cell renderer edited on Field" ----- LveConstructor _ -> error "cell renderer edited on Constructor" ----- Gtk.treeStoreSetValue treeStore treePath newLve - - - Gtk.treeStoreClear treeStore - tree <- ddataToTree (Just rootName) initialValue - Gtk.treeStoreInsertTree treeStore [] 0 tree - --- let forEach :: (ListViewElement -> IO ListViewElement) -> IO () --- forEach f = Gtk.treeModelForeach treeStore $ \treeIter -> do --- treePath <- Gtk.treeModelGetPath treeStore treeIter --- lve0 <- Gtk.treeStoreGetValue treeStore treePath --- lve1 <- f lve0 --- Gtk.treeStoreSetValue treeStore treePath lve1 --- return False - --- let gotNewValue val = do --- moldTree <- Gtk.treeStoreLookup treeStore [0] --- oldTree <- case moldTree of --- Nothing -> error "failed looking up treestore" --- Just r -> return r --- --- -- forEach (\lve -> return (lve {lveUpstreamValue = val})) --- return () - --- -- on insert or change, rebuild the signal tree --- _ <- on treeStore Gtk.rowChanged $ \_ changedPath -> do --- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath) --- gotNewValue newMsg --- --- _ <- on treeStore Gtk.rowInserted $ \_ changedPath -> do --- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath) --- gotNewValue newMsg - - scroll <- Gtk.scrolledWindowNew Nothing Nothing - Gtk.containerAdd scroll treeview - Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever - , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic - ] - + --------------------------- getting/setting the whole tree -------------------------- let mergeTrees :: Gtk.TreePath -> Tree ListViewElement -> IO () mergeTrees treePath newTree = do moldTree <- Gtk.treeStoreLookup treeStore treePath @@ -428,8 +348,8 @@ mergeNthChild 0 newChildren (_, Node (LveConstructor _) _) -> assertCompatible False - receiveNewValue :: DTree -> IO () - receiveNewValue newMsg = do + receiveNewUpstream :: DTree -> IO () + receiveNewUpstream newMsg = do moldTree <- Gtk.treeStoreLookup treeStore [0] oldTree <- case moldTree of Nothing -> error "failed looking up old treestore" @@ -450,7 +370,109 @@ Nothing -> error "failed looking up treestore" Just r -> return (treeToStagedDData r) - return (scroll, getLatestStaged, receiveNewValue) + getLatestUpstream = do + mtree <- Gtk.treeStoreLookup treeStore [0] + return $ case mtree of + Nothing -> Nothing + Just r -> Just (treeToUpstreamDData r) + + loadDTree :: DTree -> IO () + loadDTree dtree = do + eupstream <- getLatestUpstream + Gtk.treeStoreClear treeStore + tree <- ddataToTree (Just rootName) dtree + Gtk.treeStoreInsertTree treeStore [] 0 tree + case eupstream of + Nothing -> return () + Just upstream -> receiveNewUpstream upstream + + takeLatestUpstream = do + let takeUpstreamElem :: ListViewElement -> ListViewElement + takeUpstreamElem (LveField fe) = LveField (fe {feStagedField = feUpstreamField fe}) + takeUpstreamElem c@(LveConstructor _) = c + takeUpstreamElem (LveSum se) = LveSum (se {seStagedSum = seUpstreamSum se}) + + takeUpstream :: Gtk.TreeIter -> IO () + takeUpstream iter = do + -- change the value at the current iter + path <- Gtk.treeModelGetPath treeStore iter + _ <- Gtk.treeStoreChange treeStore path takeUpstreamElem + + -- if there are children, change their values + mchildren <- Gtk.treeModelIterChildren treeStore iter + case mchildren of + Just childIter -> takeUpstream childIter + Nothing -> return () + + -- if there are siblings, change their values + msiblings <- Gtk.treeModelIterNext treeStore iter + case msiblings of + Just siblingIter -> takeUpstream siblingIter + Nothing -> return () + + miter <- Gtk.treeModelGetIterFirst treeStore + case miter of + Nothing -> return () + Just root -> takeUpstream root + + + -------------------------- editing values ---------------------- + let sendDataIfAutocommitIsOn = do + autoCommit <- getAutocommit + when autoCommit (getLatestStaged >>= commit) + + modifyField :: DField -> String -> DField + modifyField f0@(DDouble _) txt = case readMaybe txt of + Nothing -> f0 + Just x -> DDouble x + modifyField f0@(DFloat _) txt = case readMaybe txt of + Nothing -> f0 + Just x -> DFloat x + modifyField f0@(DInt _) txt = case readMaybe txt of + Nothing -> f0 + Just x -> DInt x + modifyField (DString _) txt = DString txt + modifyField DSorry _ = DSorry + + modifySum :: DSimpleEnum -> String -> DSimpleEnum + modifySum denum txt = case denumSetString denum txt of + Left _ -> denum + Right r -> r + + _ <- on rendererStagedValue Gtk.edited $ \treePath txt -> do + lve0 <- Gtk.treeStoreGetValue treeStore treePath + let lve = case lve0 of + LveField fe -> LveField (fe {feStagedField = modifyField (feStagedField fe) txt}) + LveSum se -> LveSum (se {seStagedSum = modifySum (seStagedSum se) txt}) + ce@(LveConstructor _) -> ce -- not editible anyway + Gtk.treeStoreSetValue treeStore treePath lve + sendDataIfAutocommitIsOn + + + _ <- on rendererCombo Gtk.edited $ \treePath newVal -> do + lve0 <- Gtk.treeStoreGetValue treeStore treePath + let newLve = case lve0 of + LveSum se -> LveSum (se {seStagedSum = case denumSetString (seStagedSum se) newVal of + Left msg -> error $ "error updating sum elem: " ++ msg + Right r -> r + }) + LveField _ -> error "cell renderer edited on Field" + LveConstructor _ -> error "cell renderer edited on Constructor" + Gtk.treeStoreSetValue treeStore treePath newLve + sendDataIfAutocommitIsOn + + + Gtk.treeStoreClear treeStore + tree <- ddataToTree (Just rootName) initialValue + Gtk.treeStoreInsertTree treeStore [] 0 tree + + scroll <- Gtk.scrolledWindowNew Nothing Nothing + Gtk.containerAdd scroll treeview + Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever + , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic + ] + + return (scroll, getLatestStaged, receiveNewUpstream, takeLatestUpstream, loadDTree) mergeSums :: SumElem -> SumElem -> (Bool, SumElem) mergeSums oldSum newSum