Plot-ho-matic 0.5.0.5 → 0.6.0.0
raw patch · 8 files changed
+658/−106 lines, 8 filesdep ~basedep ~generic-accessorsnew-component:exe:plot-examplenew-component:exe:set-examplePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, generic-accessors
API changes (from Hackage documentation)
- PlotHo: instance Applicative Plotter
- PlotHo: instance Functor Plotter
- PlotHo: instance Monad Plotter
+ PlotHo: instance GHC.Base.Applicative PlotHo.Plotter
+ PlotHo: instance GHC.Base.Functor PlotHo.Plotter
+ PlotHo: instance GHC.Base.Monad PlotHo.Plotter
+ SetHo: class Lookup a
+ SetHo: runSetter :: Lookup a => a -> IO a -> (a -> IO ()) -> IO ()
Files
- .travis.yml +9/−7
- Plot-ho-matic.cabal +23/−7
- examples/Example.hs +0/−62
- examples/PlotExample.hs +62/−0
- examples/SetExample.hs +38/−0
- src/PlotHo.hs +24/−30
- src/SetHo.hs +130/−0
- src/SetHo/LookupTree.hs +372/−0
.travis.yml view
@@ -1,22 +1,24 @@ # from https://github.com/hvr/multi-ghc-travis env:-# - GHCVER=7.6.3 # todo: re-enable this- - GHCVER=7.8.3 # see note about Alex/Happy- - GHCVER=7.10.1 # see note about Alex/Happy+ - CABALVER=1.22 GHCVER=7.6.3+ - CABALVER=1.22 GHCVER=7.8.4 # see note about Alex/Happy+ - CABALVER=1.22 GHCVER=7.10.2 # see note about Alex/Happy before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-1.22 ghc-$GHCVER libgsl0-dev liblapack-dev- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER libgsl0-dev liblapack-dev+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install: - cabal update - cabal install alex - cabal install happy - cabal install gtk2hs-buildtools- - cabal install --only-dependencies --enable-tests --enable-benchmarks+ - for pkg in $(ghc-pkg list --user); do ghc-pkg unregister --force ${pkg}; done+ - cabal install Cabal+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --reorder-goals # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. script:@@ -27,7 +29,7 @@ - cabal sdist # tests that a source-distribution can be generated # The following scriptlet checks that the resulting source distribution can be built & installed- - export SRC_TGZ=$(cabal-1.22 info . | awk '{print $2 ".tar.gz";exit}') ;+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install "$SRC_TGZ";
Plot-ho-matic.cabal view
@@ -1,6 +1,6 @@ name: Plot-ho-matic-version: 0.5.0.5-synopsis: Real-time line plotter for protobuf-like data+version: 0.6.0.0+synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE author: Greg Horn@@ -24,10 +24,11 @@ library hs-source-dirs: src default-language: Haskell2010- exposed-modules: PlotHo+ exposed-modules: PlotHo, SetHo other-modules: PlotHo.GraphWidget, PlotHo.PlotChart,- PlotHo.PlotTypes+ PlotHo.PlotTypes,+ SetHo.LookupTree build-depends: base >= 4.6.0.0 && < 5 , containers , lens@@ -39,7 +40,7 @@ , Chart-cairo >= 1.1 , cairo , text- , generic-accessors >= 0.2.0+ , generic-accessors >= 0.5.0.0 ghc-options: -O2 -Wall ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts@@ -49,17 +50,32 @@ description: build the examples default: False -executable example+executable plot-example if flag(examples) Buildable: True else Buildable: False hs-source-dirs: examples- main-is: Example.hs+ main-is: PlotExample.hs default-language: Haskell2010 build-depends: base >= 4.5 && < 5 , Plot-ho-matic , containers++ ghc-options: -O2 -with-rtsopts=-T+ ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts++executable set-example+ if flag(examples)+ Buildable: True+ else+ Buildable: False+ hs-source-dirs: examples+ main-is: SetExample.hs+ default-language: Haskell2010+ build-depends: base >= 4.5 && < 5+ , Plot-ho-matic+ , generic-accessors ghc-options: -O2 -with-rtsopts=-T ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts
− examples/Example.hs
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# Language DeriveGeneric #-}--module Main where--import qualified Control.Concurrent as CC-import GHC.Generics ( Generic )---import qualified System.Remote.Monitoring as EKG--import PlotHo ( Lookup, XAxisType(..), runPlotter, addHistoryChannel )--data Xyz a = MkXyz { x :: Double- , y :: Double- , z :: Double- , zz :: a- } deriving Generic-data Axyz = MkAxyz { lol :: Double--- , xyzList :: S.Seq Xyz- , xyz1 :: Xyz (Xyz (Xyz Double))- , xyz2 :: Xyz Double- } deriving Generic-instance Lookup a => Lookup (Xyz a)-instance Lookup Axyz--axyz0 :: Axyz-axyz0 = MkAxyz- 7--- (S.fromList [MkXyz 1 2 3])- (MkXyz 1 2 3 (MkXyz 4 5 6 (MkXyz 7 8 9 10)))- (MkXyz 1 2 3 4)--xyz0 :: Xyz Double-xyz0 = MkXyz 1 2 3 0.1--incrementAxyz :: Axyz -> Axyz-incrementAxyz (MkAxyz a _ _) = MkAxyz- (a+0.2)- (xyz' (xyz' (xyz' (sin (3*a)))))- (xyz' (sin (2*a)))- where- xyz' w = MkXyz (sin a) (cos a) (sin a * cos a) w--incrementXyz :: Xyz a -> Xyz a-incrementXyz (MkXyz a _ _ b) = MkXyz (a+0.3) (2 * sin a) (3 * cos a) b---- a random function to write a bunch of data to a chan-channelWriter :: Int -> Int -> (a -> a) -> a -> (a -> Bool -> IO ()) -> IO ()-channelWriter count delay increment x' chan = do- --putStrLn $ "writing: " ++ show count- CC.threadDelay delay- chan (increment x') False- channelWriter (count + 1) delay increment (increment x') chan--main :: IO ()-main = do--- ekgTid <- fmap EKG.serverThreadId $ EKG.forkServer "localhost" 8000-- runPlotter $ do- addHistoryChannel "posPlos" XAxisTime $ channelWriter 0 50000 incrementAxyz axyz0- addHistoryChannel "pos" XAxisCount $ channelWriter 0 60000 incrementXyz xyz0- addHistoryChannel "posPlos" XAxisTime0 $ channelWriter 0 50000 incrementAxyz axyz0- addHistoryChannel "pos" XAxisCount0 $ channelWriter 0 60000 incrementXyz xyz0
+ examples/PlotExample.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language DeriveGeneric #-}++module Main where++import qualified Control.Concurrent as CC+import GHC.Generics ( Generic )+--import qualified System.Remote.Monitoring as EKG++import PlotHo ( Lookup, XAxisType(..), runPlotter, addHistoryChannel )++data Xyz a = MkXyz { x :: Double+ , y :: Double+ , z :: Double+ , zz :: a+ } deriving Generic+data Axyz = MkAxyz { lol :: Double+-- , xyzList :: S.Seq Xyz+ , xyz1 :: Xyz (Xyz (Xyz Double))+ , xyz2 :: Xyz Double+ } deriving Generic+instance Lookup a => Lookup (Xyz a)+instance Lookup Axyz++axyz0 :: Axyz+axyz0 = MkAxyz+ 7+-- (S.fromList [MkXyz 1 2 3])+ (MkXyz 1 2 3 (MkXyz 4 5 6 (MkXyz 7 8 9 10)))+ (MkXyz 1 2 3 4)++xyz0 :: Xyz Double+xyz0 = MkXyz 1 2 3 0.1++incrementAxyz :: Axyz -> Axyz+incrementAxyz (MkAxyz a _ _) = MkAxyz+ (a+0.2)+ (xyz' (xyz' (xyz' (sin (3*a)))))+ (xyz' (sin (2*a)))+ where+ xyz' w = MkXyz (sin a) (cos a) (sin a * cos a) w++incrementXyz :: Xyz a -> Xyz a+incrementXyz (MkXyz a _ _ b) = MkXyz (a+0.3) (2 * sin a) (3 * cos a) b++-- a random function to write a bunch of data to a chan+channelWriter :: Int -> Int -> (a -> a) -> a -> (a -> Bool -> IO ()) -> IO ()+channelWriter count delay increment x' chan = do+ --putStrLn $ "writing: " ++ show count+ CC.threadDelay delay+ chan (increment x') False+ channelWriter (count + 1) delay increment (increment x') chan++main :: IO ()+main = do+-- ekgTid <- fmap EKG.serverThreadId $ EKG.forkServer "localhost" 8000++ runPlotter $ do+ addHistoryChannel "posPlos" XAxisTime $ channelWriter 0 50000 incrementAxyz axyz0+ addHistoryChannel "pos" XAxisCount $ channelWriter 0 60000 incrementXyz xyz0+ addHistoryChannel "posPlos" XAxisTime0 $ channelWriter 0 50000 incrementAxyz axyz0+ addHistoryChannel "pos" XAxisCount0 $ channelWriter 0 60000 incrementXyz xyz0
+ examples/SetExample.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DeriveGeneric #-}++-- export Bar/Foo to silence warnings about unused records+module Main ( Bar(..), Foo(..), main ) where++import GHC.Generics ( Generic )++import Data.IORef ( newIORef, readIORef, writeIORef )++import SetHo ( runSetter )+import Accessors ( Lookup )++data Bar =+ Bar+ { bar1 :: Double+ , bar2 :: Int+ , bar3 :: Bool+ } deriving (Generic, Show)+instance Lookup Bar++data Foo =+ Foo+ { foo1 :: Double+ , foo2 :: Int+ , fooBar :: Bar+ } deriving (Generic, Show)+instance Lookup Foo++initialFoo :: Foo+initialFoo = Foo pi 42 (Bar 1 2 True)++main :: IO ()+main = do+ fooRef <- newIORef initialFoo+ let refresh = readIORef fooRef+ commit x = print x >> writeIORef fooRef x+ runSetter initialFoo refresh commit
src/PlotHo.hs view
@@ -15,6 +15,7 @@ import qualified GHC.Stats import Control.Applicative ( Applicative(..), liftA2 )+import Control.Lens ( (^.) ) import Data.Monoid ( mappend, mempty ) import Control.Monad ( when ) import qualified Control.Concurrent as CC@@ -75,6 +76,9 @@ -- | Simplified time-series channel which passes a "send message" function to a worker and forks it using '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. addHistoryChannel :: Lookup a => String -- ^ channel name@@ -146,17 +150,9 @@ | XAxisCount -- ^ message index | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter) -sameHistorySignalTree :: Lookup a => XAxisType -> a -> a -> Bool-sameHistorySignalTree xaxisType x y = hx == hy- where- hx = map (fmap f) $ historySignalTree x xaxisType- hy = map (fmap f) $ historySignalTree y xaxisType-- f (n1, n2, mg) = (n1, n2, fmap (const ()) mg)--historySignalTree :: forall a . Lookup a => a -> XAxisType -> SignalTree a-historySignalTree x axisType = case accessors x of- (ATGetter _) -> error "makeSignalTree: got an accessor right away"+historySignalTree :: forall a . Lookup a => XAxisType -> SignalTree a+historySignalTree axisType = case accessors of+ (Field _) -> error "historySignalTree: got a Field right away" d -> Tree.subForest $ head $ makeSignalTree' "" "" d where makeSignalTree' :: String -> String -> AccessorTree a -> SignalTree a@@ -165,15 +161,17 @@ (myName, parentName, Nothing) (concatMap (\(getterName,child) -> makeSignalTree' getterName pn child) children) ]- makeSignalTree' myName parentName (ATGetter (getter, _)) =- [Tree.Node (myName, parentName, Just (toHistoryGetter (toDoubleGetter getter))) []]- toDoubleGetter :: Getter a -> (a -> Double)- toDoubleGetter (GetDouble f) = f- toDoubleGetter (GetFloat f) = realToFrac . f- toDoubleGetter (GetBool f) = fromIntegral . fromEnum . f- toDoubleGetter (GetInt f) = fromIntegral . f- toDoubleGetter GetSorry = const 0+ makeSignalTree' myName parentName (Field field) =+ [Tree.Node (myName, parentName, Just (toHistoryGetter (toDoubleGetter field))) []] + toDoubleGetter :: Field a -> (a -> Double)+ toDoubleGetter (FieldDouble f) = (^. f)+ toDoubleGetter (FieldFloat f) = realToFrac . (^. f)+ toDoubleGetter (FieldBool f) = fromIntegral . fromEnum . (^. 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@@ -196,6 +194,10 @@ (_, 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@@ -234,23 +236,15 @@ when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val)) - let -- todo: cache this so i don't have to keep building an accessor tree to compare- sst :: History a -> History a -> Bool- sst (History x) (History y) = case (S.viewr x, S.viewr y) of- (_ S.:> (x',_,_), _ S.:> (y',_,_)) -> sameHistorySignalTree xaxisType x' y'- _ -> error "sameSignalTree got an empty history :("-- tst :: History a -> [Tree ( String+ let tst :: History a -> [Tree ( String , String , Maybe (History a -> [[(Double, Double)]]) )]- tst (History x) = case (S.viewr x) of- (_ S.:> (x',_,_)) -> historySignalTree x' xaxisType- S.EmptyR -> error "toSignalTree got an empty history"+ tst = const (historySignalTree xaxisType) let retChan = Channel { chanName = name , chanMsgStore = msgStore- , chanSameSignalTree = sst+ , chanSameSignalTree = \_ _ -> True , chanToSignalTree = tst , chanMaxHistory = maxHist }
+ src/SetHo.hs view
@@ -0,0 +1,130 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This is an experimental and unstable interface for+-- generating a GUI for getting/setting options.+module SetHo+ ( runSetter+ -- * re-exported for convenience+ , Lookup+ ) where++import qualified GHC.Stats++import qualified Control.Concurrent as CC+import Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified Graphics.UI.Gtk as Gtk+import Text.Printf ( printf )+--import System.Glib.Signals ( on )++import Accessors++import SetHo.LookupTree ( GraphInfo(..), newLookupTreeview, makeOptionsWidget )+++-- | fire up the the GUI+runSetter :: forall a . Lookup a => a -> IO a -> (a -> IO ()) -> IO ()+runSetter initialValue refresh commit = do+ statsEnabled <- GHC.Stats.getGCStatsEnabled++ _ <- Gtk.initGUI+ _ <- Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50++ -- start the main window+ win <- Gtk.windowNew+ _ <- Gtk.set win [ Gtk.containerBorderWidth := 8+ , Gtk.windowTitle := "set-ho-matic"+ ]++ statsLabel <- Gtk.labelNew (Nothing :: Maybe String)+ let statsWorker = do+ CC.threadDelay 500000+ msg <- if statsEnabled+ then do+ stats <- GHC.Stats.getGCStats+ return $ printf "The current memory usage is %.2f MB"+ ((realToFrac (GHC.Stats.currentBytesUsed stats) :: Double) /(1024*1024))+ else return "(enable GHC statistics with +RTS -T)"+ Gtk.postGUISync $ Gtk.labelSetText statsLabel ("Welcome to set-ho-matic!\n" ++ msg)+ statsWorker++ statsThread <- CC.forkIO statsWorker+ -- 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 = do+ CC.killThread statsThread+ _gws <- CC.readMVar graphWindowsToBeKilled+-- mapM_ Gtk.widgetDestroy gws+-- mapM_ csKillThreads channels+ Gtk.mainQuit+ _ <- Gtk.onDestroy win killEverything++ --------------- main widget -----------------+ buttonCommit <- Gtk.buttonNewWithLabel "commit"+ buttonRefresh <- Gtk.buttonNewWithLabel "refresh"+ Gtk.widgetSetTooltipText buttonCommit (Just "SET ME SET ME GO HEAD DO IT COME ON SET ME")++ msgStore <- Gtk.listStoreNew [initialValue]+ let newMessage :: a -> IO ()+ newMessage next =+ -- 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++ -- mvar with all the user input+ graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = True+ , giXRange = Nothing+ , giValue = initialValue+ } :: IO (CC.MVar (GraphInfo a))++ -- the options widget+ optionsWidget <- makeOptionsWidget graphInfoMVar+ options <- Gtk.expanderNew "options"+ Gtk.set options [ Gtk.containerChild := optionsWidget+ , Gtk.expanderExpanded := False+ ]++ -- the signal selector+ (treeview, getLatestStaged) <- newLookupTreeview initialValue msgStore+ treeviewExpander <- Gtk.expanderNew "signals"+ Gtk.set treeviewExpander+ [ Gtk.containerChild := treeview+ , Gtk.expanderExpanded := True+ ]++ -- vbox to hold buttons and list of channel+ vbox <- Gtk.vBoxNew False 4+ Gtk.set vbox+ [ 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 := options+ , Gtk.boxChildPacking options := Gtk.PackNatural+ , Gtk.containerChild := treeviewExpander+ , Gtk.boxChildPacking treeviewExpander := Gtk.PackGrow+ ]++ _ <- Gtk.onClicked buttonCommit $ do+ val <- getLatestStaged+ commit val+ + _ <- Gtk.onClicked buttonRefresh $ do+ newVal <- refresh+ newMessage newVal++-- add widget to window and show+ _ <- Gtk.set win [ Gtk.containerChild := vbox ]+ Gtk.widgetShowAll win+ Gtk.mainGUI
+ src/SetHo/LookupTree.hs view
@@ -0,0 +1,372 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}++module SetHo.LookupTree+ ( GraphInfo(..)+ , ListViewInfo(..)+ , newLookupTreeview+ , makeOptionsWidget+ ) where++import qualified Control.Concurrent as CC+import Data.List ( foldl' )+import qualified Data.IORef as IORef+import qualified Data.Tree as Tree+import Control.Lens ( (.~), (^.) )+import Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified Graphics.UI.Gtk as Gtk+import System.Glib.Signals ( on )+import Text.Read ( readMaybe )+import qualified Data.Text as T+import Text.Printf ( printf )++import Accessors ( Lookup, AccessorTree(..), Field(..), accessors, describeField )++data ListViewInfo a =+ ListViewInfo+ { lviName :: String+ , lviType :: String+ , lviField :: Maybe (Field a)+ , lviMarked :: Bool+ , lviStagedMutator :: a -> a+ , lviUpstreamValue :: a+ , lviShownValue :: String+ }++instance Show a => Show (ListViewInfo a) where+ show (ListViewInfo n t _ _ mut val m) = "ListViewInfo " ++ show (n,t,m,mut val)++-- what the graph should draw+data GraphInfo a =+ GraphInfo { giXScaling :: Bool+ , giXRange :: Maybe (Double,Double)+ , giValue :: a+ }++type SignalTree a = Tree.Forest (String, String, Maybe (Field a))++toSignalTree :: forall a . Lookup a => SignalTree a+toSignalTree = case (accessors :: AccessorTree a) of+ (Field _) -> error "toSignalTree: got an accessor right away"+ d -> Tree.subForest $ head $ makeSignalTree' "" "" d+ where+ makeSignalTree' :: String -> String -> AccessorTree a -> SignalTree a+ makeSignalTree' myName parentName (Data (pn,_) children) =+ [Tree.Node+ (myName, parentName, Nothing)+ (concatMap (\(getterName,child) -> makeSignalTree' getterName pn child) children)+ ]+ makeSignalTree' myName parentName (Field f) =+ [Tree.Node (myName, parentName, Just f) []]++++newLookupTreeview ::+ forall a+ . Lookup a+ => a+ -> Gtk.ListStore a+ -> IO (Gtk.ScrolledWindow, IO a)+newLookupTreeview initialValue msgStore = do+ let signalTree = toSignalTree++ treeStore <- Gtk.treeStoreNew []+ treeview <- Gtk.treeViewNewWithModel treeStore++ Gtk.treeViewSetHeadersVisible treeview True+ Gtk.treeViewSetEnableTreeLines treeview True+-- Gtk.treeViewSetGridLines treeview Gtk.TreeViewGridLinesVertical+-- Gtk.treeViewSetGridLines treeview Gtk.TreeViewGridLinesBoth++ -- add some columns+ colName <- Gtk.treeViewColumnNew+ colType <- Gtk.treeViewColumnNew+ colUpstreamValue <- Gtk.treeViewColumnNew+ colStagedValue <- Gtk.treeViewColumnNew+ colBool <- Gtk.treeViewColumnNew+ colSpin <- Gtk.treeViewColumnNew++ Gtk.treeViewColumnSetTitle colName "name"+ Gtk.treeViewColumnSetTitle colBool "bool"+ Gtk.treeViewColumnSetTitle colType "type"+ Gtk.treeViewColumnSetTitle colUpstreamValue "upstream"+ Gtk.treeViewColumnSetTitle colStagedValue "staged"+ Gtk.treeViewColumnSetTitle colSpin "spin"++ rendererName <- Gtk.cellRendererTextNew+ rendererBool <- Gtk.cellRendererToggleNew+ rendererType <- Gtk.cellRendererTextNew+ rendererStagedValue <- Gtk.cellRendererTextNew+ rendererUpstreamValue <- Gtk.cellRendererTextNew+ rendererSpin <- Gtk.cellRendererSpinNew++ Gtk.cellLayoutPackStart colName rendererName True+ Gtk.cellLayoutPackStart colType rendererType True+ Gtk.cellLayoutPackStart colUpstreamValue rendererUpstreamValue True+ Gtk.cellLayoutPackStart colStagedValue rendererStagedValue True+ Gtk.cellLayoutPackStart colBool rendererBool True+ Gtk.cellLayoutPackStart colSpin rendererSpin True++ _ <- Gtk.treeViewAppendColumn treeview colName+ _ <- Gtk.treeViewAppendColumn treeview colType+ _ <- Gtk.treeViewAppendColumn treeview colUpstreamValue+ _ <- Gtk.treeViewAppendColumn treeview colStagedValue+ _ <- Gtk.treeViewAppendColumn treeview colBool+ _ <- Gtk.treeViewAppendColumn treeview colSpin++ -- data name+ let showName (Just _) name _ = name+ showName Nothing name "" = name+ showName Nothing name typeName = name ++ " (" ++ typeName ++ ")"++ Gtk.cellLayoutSetAttributes colName rendererName treeStore $+ \(ListViewInfo {lviName = name, lviType = typeName, lviField = field}) ->+ [ Gtk.cellText := showName field name typeName+ ]++ -- data type+ let showType (Just x) = describeField x+ showType Nothing = ""++ Gtk.cellLayoutSetAttributes colType rendererType treeStore $+ \lvi -> [ Gtk.cellText := showType (lviField lvi) ]++ -- upstream value+ let showUpstreamValue lvi = case lviField lvi of+ (Just (FieldBool f)) -> show (upstream ^. f)+ (Just (FieldDouble f)) -> printf "%.2g" (upstream ^. f)+ (Just (FieldFloat f)) -> printf "%.2g" (upstream ^. f)+ (Just (FieldInt f)) -> show (upstream ^. f)+ (Just (FieldString f)) -> upstream ^. f+ Just FieldSorry -> ""+ Nothing -> ""+ where+ upstream = lviUpstreamValue lvi++ Gtk.cellLayoutSetAttributes colUpstreamValue rendererUpstreamValue treeStore $+ \lvi -> [ Gtk.cellText := showUpstreamValue lvi+ , Gtk.cellTextEditable := False+ ]++ -- staged value+ let showStagedValue lvi = case lviField lvi of+ Just (FieldBool f) -> show (staged ^. f)+ Just (FieldDouble f) -> printf "%.2g" (staged ^. f)+ Just (FieldFloat f) -> printf "%.2g" (staged ^. f)+ Just (FieldInt f) -> show (staged ^. f)+ Just (FieldString f) -> staged ^. f+ Just FieldSorry -> ""+ Nothing -> ""+ where+ staged = lviStagedMutator lvi (lviUpstreamValue lvi)++ Gtk.cellLayoutSetAttributes colStagedValue rendererStagedValue treeStore $+ \lvi -> case lviField lvi of+ Just _ -> [ Gtk.cellText := showStagedValue lvi+ , Gtk.cellTextEditable := True+ ]+ Nothing -> [ Gtk.cellText := ""+ , Gtk.cellTextEditable := False+ ]+ _ <- on rendererStagedValue Gtk.edited $ \treePath txt -> do+ let _ = txt :: String+ lvi0 <- Gtk.treeStoreGetValue treeStore treePath+ let lvi = case lviField lvi0 of+ Just (FieldBool f)+ | txt `elem` ["t","true","True","1"] ->+ lvi0 { lviStagedMutator = f .~ True, lviMarked = True }+ | txt `elem` ["f","false","False","0"] ->+ lvi0 {lviStagedMutator = f .~ False, lviMarked = False }+ | otherwise -> lvi0+ Just (FieldDouble f) -> case readMaybe txt of+ Nothing -> lvi0+ Just x -> lvi0 { lviStagedMutator = f .~ x }+ Just (FieldFloat f) -> case readMaybe txt of+ Nothing -> lvi0+ Just x -> lvi0 { lviStagedMutator = f .~ x }+ Just (FieldInt f) -> case readMaybe txt of+ Nothing -> lvi0+ Just x -> lvi0 { lviStagedMutator = f .~ x }+ Just (FieldString f) -> lvi0 { lviStagedMutator = f .~ txt }+ Just FieldSorry -> lvi0+ Nothing -> lvi0+ Gtk.treeStoreSetValue treeStore treePath lvi+ return ()++ -- bool+ let toShownBool marked (Just (FieldBool _)) =+ [ Gtk.cellToggleInconsistent := False+ , Gtk.cellToggleActive := marked+ , Gtk.cellToggleActivatable := True+ , Gtk.cellToggleRadio := True+ , Gtk.cellToggleIndicatorSize := 12+ ]+ toShownBool _ _ =+ [ Gtk.cellToggleInconsistent := True+ , Gtk.cellToggleActive := False+ , Gtk.cellToggleActivatable := False+ , Gtk.cellToggleRadio := True+ , Gtk.cellToggleIndicatorSize := 0+ ]++ Gtk.cellLayoutSetAttributes colBool rendererBool treeStore $+ \lvi -> toShownBool (lviMarked lvi) (lviField lvi)++ _ <- on rendererBool Gtk.cellToggled $ \pathStr -> do+ let treePath = Gtk.stringToTreePath pathStr+ lvi0 <- Gtk.treeStoreGetValue treeStore treePath+ let newMarked :: Bool+ newMarked = not (lviMarked lvi0)+ newMutator :: a -> a+ newMutator = case lviField lvi0 of+ Just (FieldBool f) -> f .~ newMarked+ Just f -> error $ "the new mutator must be a bool mutator, got "+ ++ describeField f+ Nothing -> error "the new mutator must be not Nothing"+ Gtk.treeStoreSetValue treeStore treePath+ (lvi0 {lviMarked = newMarked, lviStagedMutator = newMutator})+ return ()++ -- spin+ let toSpin _lvi = []+ Gtk.cellLayoutSetAttributes colSpin rendererSpin treeStore toSpin+++ let -- build the signal tree+ convert :: Tree.Tree (String, String, Maybe (Field a))+ -> Tree.Tree (ListViewInfo a)+ convert (Tree.Node (name, typ, getter) others) =+ Tree.Node (ListViewInfo name typ getter marked id initialValue "")+ (map convert others)+ where+ marked = case (getter :: Maybe (Field a)) of+ Just (FieldBool f) -> initialValue ^. f+ _ -> False++ Gtk.treeStoreClear treeStore+ Gtk.treeStoreInsertForest treeStore [] 0 (map convert signalTree)++ let forEach :: (ListViewInfo a -> IO (ListViewInfo a)) -> IO ()+ forEach f = Gtk.treeModelForeach treeStore $ \treeIter -> do+ treePath <- Gtk.treeModelGetPath treeStore treeIter+ lvi0 <- Gtk.treeStoreGetValue treeStore treePath+ lvi1 <- f lvi0+ Gtk.treeStoreSetValue treeStore treePath lvi1+ return False++ latestUpstreamRef <- IORef.newIORef initialValue+ let gotNewValue val = do+ IORef.writeIORef latestUpstreamRef val+ forEach (\lvi -> return (lvi {lviUpstreamValue = val}))++ -- on insert or change, rebuild the signal tree+ _ <- on msgStore Gtk.rowChanged $ \_ changedPath -> do+ newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)+ gotNewValue newMsg++ _ <- on msgStore 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+ ]++ let getAll :: IO [ListViewInfo a]+ getAll = do+ lvisRef <- IORef.newIORef []+ Gtk.treeModelForeach treeStore $ \treeIter -> do+ treePath <- Gtk.treeModelGetPath treeStore treeIter+ lvi <- Gtk.treeStoreGetValue treeStore treePath+ IORef.modifyIORef lvisRef (lvi:)+ return False+ fmap reverse (IORef.readIORef lvisRef)+ let getLatest = do+ lvis <- getAll+ latestUpstream <- IORef.readIORef latestUpstreamRef+ return (foldl' (flip lviStagedMutator) latestUpstream lvis)++ return (scroll, getLatest)++++makeOptionsWidget :: CC.MVar (GraphInfo a) -> IO Gtk.VBox+makeOptionsWidget graphInfoMVar = do+ -- user selectable range+ xRange <- Gtk.entryNew+ Gtk.set xRange [ Gtk.entryEditable := False+ , Gtk.widgetSensitive := False+ ]+ xRangeBox <- labeledWidget "x range:" xRange+ Gtk.set xRange [Gtk.entryText := "(-10,10)"]+ let updateXRange = do+ Gtk.set xRange [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ 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 := "(min,max)"]+ Just (z0,z1) -> if z0 >= z1+ then do+ putStrLn $ "invalid x range entry (min >= max): " ++ txt+ Gtk.set xRange [Gtk.entryText := "(min,max)"]+ return ()+ else do+ _ <- CC.swapMVar graphInfoMVar (gi {giXRange = Just (z0,z1)})+ return ()+ _ <- on xRange Gtk.entryActivate updateXRange++ -- linear or log scaling on the x and y axis?+ xScalingSelector <- Gtk.comboBoxNewText+ mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack)+ ["linear (auto)","linear (manual)","logarithmic (auto)"]+ Gtk.comboBoxSetActive xScalingSelector 0+ xScalingBox <- labeledWidget "x scaling:" xScalingSelector+ let updateXScaling = do+ k <- Gtk.comboBoxGetActive xScalingSelector+ case k of+ 0 -> do+ Gtk.set xRange [ Gtk.entryEditable := False+ , Gtk.widgetSensitive := False+ ]+ CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXScaling = False, giXRange = Nothing}+ 1 -> do+ Gtk.set xRange [ Gtk.entryEditable := False+ , Gtk.widgetSensitive := False+ ]+ CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXScaling = True, giXRange = Nothing}+ _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 3"+ updateXScaling+ _ <- on xScalingSelector Gtk.changed updateXScaling++ -- 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+ ]++ 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