Plot-ho-matic 0.9.0.1 → 0.9.0.2
raw patch · 4 files changed
+308/−165 lines, 4 filesdep +bytestringdep +cerealPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, cereal
API changes (from Hackage documentation)
Files
- CHANGELOG.md +42/−32
- Plot-ho-matic.cabal +3/−1
- src/SetHo.hs +124/−15
- src/SetHo/LookupTree.hs +139/−117
CHANGELOG.md view
@@ -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)
Plot-ho-matic.cabal view
@@ -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
src/SetHo.hs view
@@ -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
src/SetHo/LookupTree.hs view
@@ -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