diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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"; diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -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 diff --git a/examples/Example.hs b/examples/Example.hs deleted file mode 100644 --- a/examples/Example.hs +++ /dev/null @@ -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 diff --git a/examples/PlotExample.hs b/examples/PlotExample.hs new file mode 100644 --- /dev/null +++ b/examples/PlotExample.hs @@ -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 diff --git a/examples/SetExample.hs b/examples/SetExample.hs new file mode 100644 --- /dev/null +++ b/examples/SetExample.hs @@ -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 diff --git a/src/PlotHo.hs b/src/PlotHo.hs --- a/src/PlotHo.hs +++ b/src/PlotHo.hs @@ -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 } diff --git a/src/SetHo.hs b/src/SetHo.hs new file mode 100644 --- /dev/null +++ b/src/SetHo.hs @@ -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 diff --git a/src/SetHo/LookupTree.hs b/src/SetHo/LookupTree.hs new file mode 100644 --- /dev/null +++ b/src/SetHo/LookupTree.hs @@ -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