diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -21,7 +21,7 @@ script: - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests/benchmarks) - - cabal test + - cabal test --show-details=always # - cabal check - cabal sdist # tests that a source-distribution can be generated diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,3 +19,10 @@ 0.4.0.4 --- remove Generic requirement for some Lookup instances + +0.5.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 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.4.0.4 +version: 0.5.0.0 synopsis: Real-time line plotter for protobuf-like data license: BSD3 license-file: LICENSE @@ -22,12 +22,10 @@ hs-source-dirs: src default-language: Haskell2010 exposed-modules: PlotHo - other-modules: GraphWidget, - Accessors, - PlotChart, - PlotTypes, - ReadMaybe - build-depends: base >= 4.5.0 && < 5 + other-modules: PlotHo.GraphWidget, + PlotHo.PlotChart, + PlotHo.PlotTypes + build-depends: base >= 4.6.0.0 && < 5 , containers , lens , data-default-class @@ -37,8 +35,11 @@ , time , Chart >= 1.1 , Chart-cairo >= 1.1 + , cairo , linear , text + , spatial-math >= 0.2.0 + , generic-accessors >= 0.1.0.0 ghc-options: -O2 -Wall ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts @@ -60,5 +61,5 @@ , Plot-ho-matic , containers - ghc-options: -threaded -O2 - ghc-prof-options: -threaded -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts + ghc-options: -O2 + ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -7,7 +7,7 @@ import GHC.Generics ( Generic ) --import qualified System.Remote.Monitoring as EKG -import PlotHo ( Lookup, SignalTree, runPlotter, addChannel, makeSignalTree ) +import PlotHo ( Lookup, XAxisType(..), runPlotter, addHistoryChannel ) data Xyz = MkXyz { x :: Double , y :: Double @@ -41,22 +41,19 @@ incrementXyz (MkXyz a _ _) = MkXyz (a+0.3) (2 * sin a) (3 * cos a) -- a random function to write a bunch of data to a chan -channelWriter :: Int -> (a -> a) -> a -> (a -> IO ()) -> IO () -channelWriter delay increment x' chan = do +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') - channelWriter delay increment (increment x') chan - -ast :: SignalTree Axyz -ast = makeSignalTree axyz0 - -st :: SignalTree Xyz -st = makeSignalTree xyz0 + 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 - addChannel "posPlus" ast (\w _ -> channelWriter 50000 incrementAxyz axyz0 w) - addChannel "pos" st (\w _ -> channelWriter 60000 incrementXyz xyz0 w) + 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/src/Accessors.hs b/src/Accessors.hs deleted file mode 100644 --- a/src/Accessors.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ---{-# OPTIONS_GHC -ddump-deriv #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} ---{-# LANGUAGE DeriveGeneric #-} -- for example at bottom - -module Accessors - ( Generic - , Lookup(..) - , AccessorTree(..) - , accessors - , flatten - ) where - -import Data.List ( intercalate ) -import qualified Linear -import GHC.Word -import Data.Int -import Foreign.C.Types -import GHC.Generics - -showAccTree :: String -> AccessorTree a -> [String] -showAccTree spaces (ATGetter _) = [spaces ++ "ATGetter {}"] -showAccTree spaces (Data name trees) = - (spaces ++ "Data " ++ show name) : - concatMap (showChild (spaces ++ " ")) trees - -showChild :: String -> (String, AccessorTree a) -> [String] -showChild spaces (name, tree) = - (spaces ++ name) : showAccTree (spaces ++ " ") tree - -instance Show (AccessorTree a) where - show = unlines . showAccTree "" - -data AccessorTree a = Data (String,String) [(String, AccessorTree a)] - | ATGetter (a -> Double) - -accessors :: Lookup a => a -> AccessorTree a -accessors = flip toAccessorTree id - -showMsgs :: [String] -> String -showMsgs = intercalate "." - -flatten :: AccessorTree a -> [(String, a -> Double)] -flatten = flatten' [] - -flatten' :: [String] -> AccessorTree a -> [(String, a -> Double)] -flatten' msgs (ATGetter f) = [(showMsgs (reverse msgs), f)] -flatten' msgs (Data (_,_) trees) = concatMap f trees - where - f (name,tree) = flatten' (name:msgs) tree - --- | Things which you can make a tree of labeled getters for. --- You should derive this using GHC.Generics. -class Lookup a where - toAccessorTree :: a -> (b -> a) -> AccessorTree b - - default toAccessorTree :: (Generic a, GLookup (Rep a)) => a -> (b -> a) -> AccessorTree b - toAccessorTree x f = gtoAccessorTree (from x) (from . f) - -class GLookup f where - gtoAccessorTree :: f a -> (b -> f a) -> AccessorTree b - -class GLookupS f where - gtoAccessorTreeS :: f a -> (b -> f a) -> [(String, AccessorTree b)] - --- some instance from linear -instance Lookup a => Lookup (Linear.V0 a) where - toAccessorTree _ _ = - Data ("V0", "V0") [] -instance Lookup a => Lookup (Linear.V1 a) where - toAccessorTree xyz f = - Data ("V1", "V1") [ ("x", toAccessorTree (getX xyz) (getX . f)) - ] - where - getX (Linear.V1 x) = x -instance Lookup a => Lookup (Linear.V2 a) where - toAccessorTree xyz f = - Data ("V2", "V2") [ ("x", toAccessorTree (getX xyz) (getX . f)) - , ("y", toAccessorTree (getY xyz) (getY . f)) - ] - where - getX (Linear.V2 x _) = x - getY (Linear.V2 _ y) = y -instance Lookup a => Lookup (Linear.V3 a) where - toAccessorTree xyz f = - Data ("V3", "V3") [ ("x", toAccessorTree (getX xyz) (getX . f)) - , ("y", toAccessorTree (getY xyz) (getY . f)) - , ("z", toAccessorTree (getZ xyz) (getZ . f)) - ] - where - getX (Linear.V3 x _ _) = x - getY (Linear.V3 _ y _) = y - getZ (Linear.V3 _ _ z) = z -instance Lookup a => Lookup (Linear.V4 a) where - toAccessorTree xyz f = - Data ("V4", "V4") [ ("x", toAccessorTree (getX xyz) (getX . f)) - , ("y", toAccessorTree (getY xyz) (getY . f)) - , ("z", toAccessorTree (getZ xyz) (getZ . f)) - , ("w", toAccessorTree (getW xyz) (getW . f)) - ] - where - getX (Linear.V4 x _ _ _) = x - getY (Linear.V4 _ y _ _) = y - getZ (Linear.V4 _ _ z _) = z - getW (Linear.V4 _ _ _ w) = w -instance Lookup a => Lookup (Linear.Quaternion a) where - toAccessorTree xyz f = - Data ("Quaternion", "Quaternion") - [ ("q0", toAccessorTree (getQ0 xyz) (getQ0 . f)) - , ("q1", toAccessorTree (getQ1 xyz) (getQ1 . f)) - , ("q2", toAccessorTree (getQ2 xyz) (getQ2 . f)) - , ("q3", toAccessorTree (getQ3 xyz) (getQ3 . f)) - ] - where - getQ0 (Linear.Quaternion q0 _) = q0 - getQ1 (Linear.Quaternion _ (Linear.V3 x _ _)) = x - getQ2 (Linear.Quaternion _ (Linear.V3 _ y _)) = y - getQ3 (Linear.Quaternion _ (Linear.V3 _ _ z)) = z - - -instance Lookup f => GLookup (Rec0 f) where - gtoAccessorTree x f = toAccessorTree (unK1 x) (unK1 . f) - -instance (Selector s, GLookup a) => GLookupS (S1 s a) where - gtoAccessorTreeS x f = [(selname, gtoAccessorTree (unM1 x) (unM1 . f))] - where - selname = case selName x of - [] -> "()" - y -> y - -instance GLookupS U1 where - gtoAccessorTreeS _ _ = [] - -instance (GLookupS f, GLookupS g) => GLookupS (f :*: g) where - gtoAccessorTreeS (x :*: y) f = tf ++ tg - where - tf = gtoAccessorTreeS x $ left . f - tg = gtoAccessorTreeS y $ right . f - - left ( x' :*: _ ) = x' - right ( _ :*: y' ) = y' - -instance (Datatype d, Constructor c, GLookupS a) => GLookup (D1 d (C1 c a)) where - gtoAccessorTree d@(M1 c) f = Data (datatypeName d, conName c) con - where - con = gtoAccessorTreeS (unM1 c) (unM1 . unM1 . f) - --- basic types -instance Lookup () where -- hack to get dummy tree - toAccessorTree _ _ = ATGetter $ const 0 -instance Lookup Int where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Float where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Double where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Bool where - toAccessorTree _ f = ATGetter $ realToFrac . fromEnum . f - --- Word types -instance Lookup Word where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Word8 where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Word16 where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Word32 where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Word64 where - toAccessorTree _ f = ATGetter $ realToFrac . f - --- Int types -instance Lookup Int8 where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Int16 where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Int32 where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup Int64 where - toAccessorTree _ f = ATGetter $ realToFrac . f - --- C types -instance Lookup CChar where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CSChar where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CUChar where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CShort where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CUShort where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CInt where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CUInt where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CLong where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CULong where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CPtrdiff where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CSize where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CWchar where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CSigAtomic where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CLLong where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CULLong where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CIntPtr where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CUIntPtr where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CIntMax where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CUIntMax where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CClock where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CTime where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CUSeconds where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CSUSeconds where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CFloat where - toAccessorTree _ f = ATGetter $ realToFrac . f -instance Lookup CDouble where - toAccessorTree _ f = ATGetter $ realToFrac . f - - ---data Xyz = Xyz { xx :: Int --- , yy :: Double --- , zz :: Float --- , ww :: Int --- } deriving (Generic) ---data One = MkOne { one :: Double } deriving (Generic) ---data Foo = MkFoo { aaa :: Int --- , bbb :: Xyz --- , ccc :: One --- } deriving (Generic) ---instance Lookup One ---instance Lookup Xyz ---instance Lookup Foo --- ---foo :: Foo ---foo = MkFoo 2 (Xyz 6 7 8 9) (MkOne 17) --- ---go = accessors foo diff --git a/src/GraphWidget.hs b/src/GraphWidget.hs deleted file mode 100644 --- a/src/GraphWidget.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# Language ScopedTypeVariables #-} -{-# Language PackageImports #-} - --- | This module manages the widget which lets the user click signals and stuff - -module GraphWidget - ( newGraph - ) where - -import Data.Maybe (fromJust, isJust) -import qualified Control.Concurrent as CC -import Control.Monad ( when, unless ) -import qualified Data.Sequence as S -import qualified Data.Tree as Tree -import "gtk" Graphics.UI.Gtk ( AttrOp( (:=) ) ) -import qualified "gtk" Graphics.UI.Gtk as Gtk -import Data.Time ( NominalDiffTime ) -import System.Glib.Signals ( on ) -import qualified Data.Text as T - -import PlotChart ( GraphInfo(..), AxisScaling(..), XAxisType(..), newChartCanvas ) -import PlotTypes ( SignalTree, ListViewInfo(..), Getter ) -import ReadMaybe ( readMaybe ) - --- make a new graph window -newGraph :: - String -> - Gtk.ListStore (SignalTree a) -> - CC.MVar (S.Seq (a, Int, NominalDiffTime)) -> - IO Gtk.Window -newGraph channame signalTreeStore chanseq = do - win <- Gtk.windowNew - - _ <- Gtk.set win [ Gtk.containerBorderWidth := 8 - , Gtk.windowTitle := channame - ] - - -- mvar with everything the graphs need to plot - graphInfoMVar <- CC.newMVar GraphInfo { giData = chanseq - , giXScaling = LinearScaling - , giYScaling = LinearScaling - , giXRange = Nothing - , giYRange = Nothing - , giXAxisType = XAxisCounter - , giGetters = [] - } - - -- the options widget - optionsWidget <- makeOptionsWidget graphInfoMVar - options <- Gtk.expanderNew "options" - Gtk.set options [ Gtk.containerChild := optionsWidget - , Gtk.expanderExpanded := False - ] - - -- the signal selector - treeview' <- newSignalSelectorArea graphInfoMVar signalTreeStore - treeview <- Gtk.expanderNew "signals" - Gtk.set treeview [ Gtk.containerChild := treeview' - , Gtk.expanderExpanded := True - ] - - -- options and signal selector packed in vbox - vboxOptionsAndSignals <- Gtk.vBoxNew False 4 - Gtk.set vboxOptionsAndSignals - [ Gtk.containerChild := options - , Gtk.boxChildPacking options := Gtk.PackNatural - , Gtk.containerChild := treeview - , Gtk.boxChildPacking treeview := Gtk.PackGrow - ] - - -- chart drawing area - chartCanvas <- newChartCanvas graphInfoMVar - - -- hbox to hold eveything - hboxEverything <- Gtk.hBoxNew False 4 - Gtk.set hboxEverything - [ Gtk.containerChild := vboxOptionsAndSignals - , Gtk.boxChildPacking vboxOptionsAndSignals := Gtk.PackNatural - , Gtk.containerChild := chartCanvas - ] - _ <- Gtk.set win [ Gtk.containerChild := hboxEverything ] - - Gtk.widgetShowAll win - return win - - - -newSignalSelectorArea :: forall a . - CC.MVar (GraphInfo a) -> Gtk.ListStore (SignalTree a) -> IO Gtk.ScrolledWindow -newSignalSelectorArea graphInfoMVar signalTreeStore = do - treeStore <- Gtk.treeStoreNew [] - treeview <- Gtk.treeViewNewWithModel treeStore - - Gtk.treeViewSetHeadersVisible treeview True - - -- add some columns - col1 <- Gtk.treeViewColumnNew - col2 <- Gtk.treeViewColumnNew - - Gtk.treeViewColumnSetTitle col1 "signal" - Gtk.treeViewColumnSetTitle col2 "visible?" - - renderer1 <- Gtk.cellRendererTextNew - renderer2 <- Gtk.cellRendererToggleNew - - Gtk.cellLayoutPackStart col1 renderer1 True - Gtk.cellLayoutPackStart col2 renderer2 True - - let showName (Just _) name _ = name - showName Nothing name "" = name - showName Nothing name typeName = name ++ " (" ++ typeName ++ ")" - Gtk.cellLayoutSetAttributes col1 renderer1 treeStore $ - \(ListViewInfo {lviName = name, lviType = typeName, lviGetter = getter}) -> - [ Gtk.cellText := showName getter name typeName] - Gtk.cellLayoutSetAttributes col2 renderer2 treeStore $ \lvi -> [ Gtk.cellToggleActive := lviMarked lvi] - - _ <- Gtk.treeViewAppendColumn treeview col1 - _ <- Gtk.treeViewAppendColumn treeview col2 - - - let -- update the graph information - updateGraphInfo = do - -- first get all trees - let getTrees k = do - tree' <- Gtk.treeStoreLookup treeStore [k] - case tree' of Nothing -> return [] - Just tree -> fmap (tree:) (getTrees (k+1)) - theTrees <- getTrees 0 - let newGetters :: [(String, Getter a)] - newGetters = [ (lviName lvi, fromJust $ lviGetter lvi) - | lvi <- concatMap Tree.flatten theTrees - , lviMarked lvi - , isJust (lviGetter lvi) - ] - _ <- CC.modifyMVar_ graphInfoMVar (\gi0 -> return $ gi0 { giGetters = newGetters }) - return () - - -- update which y axes are visible - _ <- on renderer2 Gtk.cellToggled $ \pathStr -> do - let treePath = Gtk.stringToTreePath pathStr - -- toggle the check mark - let g lvi@(ListViewInfo _ _ Nothing _) = lvi - g lvi = lvi {lviMarked = not (lviMarked lvi)} - ret <- Gtk.treeStoreChange treeStore treePath g - unless ret $ putStrLn "treeStoreChange fail" - updateGraphInfo - - - -- rebuild the signal tree - let rebuildSignalTree :: SignalTree a -> IO () - rebuildSignalTree signalTree = do - let mkTreeNode :: (String, String, Maybe (Getter a)) -> ListViewInfo a - mkTreeNode (name,typeName,maybeget) = ListViewInfo name typeName maybeget False - newTrees :: [Tree.Tree (ListViewInfo a)] - newTrees = map (fmap mkTreeNode) signalTree - Gtk.treeStoreClear treeStore - Gtk.treeStoreInsertForest treeStore [] 0 newTrees - updateGraphInfo - - -- on insert or change, rebuild the signal tree - _ <- on signalTreeStore Gtk.rowChanged $ \_ changedPath -> do - newMeta <- Gtk.listStoreGetValue signalTreeStore (Gtk.listStoreIterToIndex changedPath) - rebuildSignalTree newMeta - _ <- on signalTreeStore Gtk.rowInserted $ \_ changedPath -> do - newMeta <- Gtk.listStoreGetValue signalTreeStore (Gtk.listStoreIterToIndex changedPath) - rebuildSignalTree newMeta - - -- rebuild the signal tree right now if it exists - size <- Gtk.listStoreGetSize signalTreeStore - when (size > 0) $ do - newMeta <- Gtk.listStoreGetValue signalTreeStore 0 - rebuildSignalTree newMeta - - - scroll <- Gtk.scrolledWindowNew Nothing Nothing - Gtk.containerAdd scroll treeview - Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever - , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic - ] - return scroll - - -makeOptionsWidget :: CC.MVar (GraphInfo a) -> IO Gtk.VBox -makeOptionsWidget graphInfoMVar = do - -- user selectable range - xRange <- Gtk.entryNew - yRange <- Gtk.entryNew - Gtk.set xRange [ Gtk.entryEditable := False - , Gtk.widgetSensitive := False - ] - Gtk.set yRange [ Gtk.entryEditable := False - , Gtk.widgetSensitive := False - ] - xRangeBox <- labeledWidget "x range:" xRange - yRangeBox <- labeledWidget "y range:" yRange - Gtk.set xRange [Gtk.entryText := "(-10,10)"] - Gtk.set yRange [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 () - let updateYRange = do - Gtk.set yRange [ Gtk.entryEditable := True - , Gtk.widgetSensitive := True - ] - txt <- Gtk.get yRange Gtk.entryText - gi <- CC.readMVar graphInfoMVar - case readMaybe txt of - Nothing -> do - putStrLn $ "invalid y range entry: " ++ txt - Gtk.set yRange [Gtk.entryText := "(min,max)"] - Just (z0,z1) -> if z0 >= z1 - then do - putStrLn $ "invalid y range entry (min >= max): " ++ txt - Gtk.set yRange [Gtk.entryText := "(min,max)"] - return () - else do - _ <- CC.swapMVar graphInfoMVar (gi {giYRange = Just (z0,z1)}) - return () - _ <- on xRange Gtk.entryActivate updateXRange - _ <- on yRange Gtk.entryActivate updateYRange - - -- linear or log scaling on the x and y axis? - xScalingSelector <- Gtk.comboBoxNewText - yScalingSelector <- Gtk.comboBoxNewText - mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack) - ["linear (auto)","linear (manual)","logarithmic (auto)"] - mapM_ (Gtk.comboBoxAppendText yScalingSelector . T.pack) - ["linear (auto)","linear (manual)","logarithmic (auto)"] - Gtk.comboBoxSetActive xScalingSelector 0 - Gtk.comboBoxSetActive yScalingSelector 0 - xScalingBox <- labeledWidget "x scaling:" xScalingSelector - yScalingBox <- labeledWidget "y scaling:" yScalingSelector - 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 = LinearScaling, giXRange = Nothing} - 1 -> do - CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giXScaling = LinearScaling, giXRange = Nothing} - updateXRange - 2 -> do - Gtk.set xRange [ Gtk.entryEditable := False - , Gtk.widgetSensitive := False - ] - CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giXScaling = LogScaling, giXRange = Nothing} - _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 3" - return () - let updateYScaling = do - k <- Gtk.comboBoxGetActive yScalingSelector - _ <- case k of - 0 -> do - Gtk.set yRange [ Gtk.entryEditable := False - , Gtk.widgetSensitive := False - ] - CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giYScaling = LinearScaling, giYRange = Nothing} - 1 -> do - CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giYScaling = LinearScaling, giYRange = Nothing} - updateYRange - 2 -> do - Gtk.set yRange [ Gtk.entryEditable := False - , Gtk.widgetSensitive := False - ] - CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giYScaling = LogScaling, giYRange = Nothing} - _ -> error "the \"impossible\" happened: y scaling comboBox index should be < 3" - return () - updateXScaling - updateYScaling - _ <- on xScalingSelector Gtk.changed updateXScaling - _ <- on yScalingSelector Gtk.changed updateYScaling - - -- x axis type - xAxisTypeSelector <- Gtk.comboBoxNewText - mapM_ (Gtk.comboBoxAppendText xAxisTypeSelector . T.pack) - ["shifted counter","counter","shifted time","time"] - Gtk.comboBoxSetActive xAxisTypeSelector 0 - xAxisTypeSelectorBox <- labeledWidget "x axis:" xAxisTypeSelector - let updateXAxisTypeSelector = do - k <- Gtk.comboBoxGetActive xAxisTypeSelector - _ <- case k of - 0 -> CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giXAxisType = XAxisShiftedCounter} - 1 -> CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giXAxisType = XAxisCounter} - 2 -> CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giXAxisType = XAxisShiftedTime} - 3 -> CC.modifyMVar_ graphInfoMVar $ - \gi -> return $ gi {giXAxisType = XAxisTime} - _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 4" - return () - updateXAxisTypeSelector - _ <- on xAxisTypeSelector Gtk.changed updateXAxisTypeSelector - - -- vbox to hold the little window on the left - vbox <- Gtk.vBoxNew False 4 - - Gtk.set vbox [ Gtk.containerChild := xAxisTypeSelectorBox - , Gtk.boxChildPacking xAxisTypeSelectorBox := Gtk.PackNatural - , Gtk.containerChild := xScalingBox - , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural - , Gtk.containerChild := xRangeBox - , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural - , Gtk.containerChild := yScalingBox - , Gtk.boxChildPacking yScalingBox := Gtk.PackNatural - , Gtk.containerChild := yRangeBox - , Gtk.boxChildPacking yRangeBox := 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 diff --git a/src/PlotChart.hs b/src/PlotChart.hs deleted file mode 100644 --- a/src/PlotChart.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# Language PackageImports #-} - --- | One signals are selected and whatnot, this module just dumbly plots whatever --- is in the GraphInfo data - -module PlotChart - ( AxisScaling(..) - , GraphInfo(..) - , XAxisType(..) - , newChartCanvas - ) where - -import qualified Data.Sequence as S -import qualified Data.Foldable as F -import Data.Time ( NominalDiffTime ) -import qualified Control.Concurrent as CC -import Control.Lens ( (.~) ) -import Data.Default.Class ( def ) ---import qualified Data.Foldable as F ---import qualified Data.Sequence as S -import qualified "gtk" Graphics.UI.Gtk as Gtk -import qualified Graphics.Rendering.Chart as Chart -import Graphics.Rendering.Chart.Backend.Cairo ( runBackend, defaultEnv ) - -import PlotTypes ( Getter ) - --- milliseconds for draw time -animationWaitTime :: Int -animationWaitTime = 33 - -data XAxisType = XAxisCounter -- message number - | XAxisShiftedCounter -- message number shifted to 0 - | XAxisTime -- message receive time - | XAxisShiftedTime -- message receive time shifted to 0 --- | XAxisFun (String, a -> Double) - -data AxisScaling = LogScaling - | LinearScaling - --- what the chart window needs to know to draw -data GraphInfo a = - GraphInfo { giData :: CC.MVar (S.Seq (a, Int, NominalDiffTime)) - , giXScaling :: AxisScaling - , giYScaling :: AxisScaling - , giXAxisType :: XAxisType - , giXRange :: Maybe (Double,Double) - , giYRange :: Maybe (Double,Double) - , giGetters :: [(String, Getter a)] - } - -newChartCanvas :: CC.MVar (GraphInfo a) -> IO Gtk.DrawingArea -newChartCanvas graphInfoMVar = do - -- chart drawing area - chartCanvas <- Gtk.drawingAreaNew - _ <- Gtk.widgetSetSizeRequest chartCanvas 250 250 - _ <- Gtk.onExpose chartCanvas $ const (updateCanvas graphInfoMVar chartCanvas) - _ <- Gtk.timeoutAddFull - (Gtk.widgetQueueDraw chartCanvas >> return True) - Gtk.priorityDefaultIdle animationWaitTime - return chartCanvas - -updateCanvas :: CC.MVar (GraphInfo a) -> Gtk.DrawingArea -> IO Bool -updateCanvas graphInfoMVar canvas = do - gi <- CC.readMVar graphInfoMVar - datalogSeq <- CC.readMVar (giData gi) - let datalogList = F.toList datalogSeq - nameWithPoints :: [(String, [[(Double,Double)]])] - nameWithPoints = map f (giGetters gi) - - (k0,t0) = case datalogList of - [] -> (0,0) - ((_,k0',t0'):_) -> (k0',t0') - - xAxisType = giXAxisType gi - - xaxis :: [Double] - xaxis = case xAxisType of - XAxisCounter -> map (\(_,k,_) -> realToFrac k ) datalogList - XAxisShiftedCounter -> map (\(_,k,_) -> realToFrac (k-k0)) datalogList - XAxisTime -> map (\(_,_,t) -> realToFrac t ) datalogList - XAxisShiftedTime -> map (\(_,_,t) -> realToFrac (t-t0)) datalogList - - f (name, Right getter) = (name, getter datalogSeq :: [[(Double,Double)]]) - f (name, Left getter) = (name, [zip xaxis (map (\(d,_,_) -> getter d) datalogList)]) - - let myGraph = displayChart xAxisType - (giXScaling gi, giYScaling gi) (giXRange gi, giYRange gi) nameWithPoints - chartGtkUpdateCanvas myGraph canvas - -chartGtkUpdateCanvas :: Chart.Renderable a -> Gtk.DrawingArea -> IO Bool -chartGtkUpdateCanvas chart canvas = do - win <- Gtk.widgetGetDrawWindow canvas - (width, height) <- Gtk.widgetGetSize canvas - regio <- Gtk.regionRectangle $ Gtk.Rectangle 0 0 width height - let sz = (fromIntegral width,fromIntegral height) - Gtk.drawWindowBeginPaintRegion win regio - _ <- Gtk.renderWithDrawable win $ runBackend (defaultEnv Chart.bitmapAlignmentFns) (Chart.render chart sz) - Gtk.drawWindowEndPaint win - return True - - -displayChart :: (Chart.PlotValue a, Show a, RealFloat a) => - XAxisType -> - (AxisScaling, AxisScaling) -> (Maybe (a,a),Maybe (a,a)) -> - [(String, [[(a,a)]])] -> Chart.Renderable () -displayChart xAxisType (xScaling,yScaling) (xRange,yRange) namePcs = Chart.toRenderable layout - where - drawOne (name,pc) col - = Chart.plot_lines_values .~ pc - $ Chart.plot_lines_style . Chart.line_color .~ col --- $ Chart.plot_points_style ~. Chart.filledCircles 2 red - $ Chart.plot_lines_title .~ name - $ def - allLines = zipWith drawOne namePcs Chart.defaultColorSeq - - xscaleFun = case xScaling of - LogScaling -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def - LinearScaling -> case xRange of - Nothing -> id - Just range -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.scaledAxis def range - - yscaleFun = case yScaling of - LogScaling -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def - LinearScaling -> case yRange of - Nothing -> id - Just range -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.scaledAxis def range - - xlabel = case xAxisType of - XAxisTime -> "time [s]" - XAxisShiftedTime -> "time [s]" - XAxisCounter -> "count" - XAxisShiftedCounter -> "count" - - layout = Chart.layout_plots .~ map Chart.toPlot allLines --- $ Chart.layout_title .~ "Wooo, Party Graph!" - $ Chart.layout_x_axis . Chart.laxis_title .~ xlabel - $ xscaleFun - $ yscaleFun - def diff --git a/src/PlotHo.hs b/src/PlotHo.hs --- a/src/PlotHo.hs +++ b/src/PlotHo.hs @@ -1,39 +1,41 @@ {-# OPTIONS_GHC -Wall #-} {-# Language ScopedTypeVariables #-} {-# Language DeriveFunctor #-} -{-# Language PackageImports #-} module PlotHo - ( Lookup(..) - , SignalTree - , AccessorTree(..) + ( Plotter + , XAxisType(..) + , Lookup , addChannel - , makeSignalTree + , addHistoryChannel , runPlotter ) where -import Data.Monoid -import Data.Time ( NominalDiffTime ) -import qualified Data.Sequence as S +import qualified GHC.Stats + +import Control.Applicative ( Applicative(..), liftA2 ) +import Data.Monoid ( mappend, mempty ) +import Control.Monad ( when ) import qualified Control.Concurrent as CC -import qualified Control.Concurrent.STM as STM -import Data.Time ( getCurrentTime, diffUTCTime ) -import "gtk" Graphics.UI.Gtk ( AttrOp( (:=) ) ) -import qualified "gtk" Graphics.UI.Gtk as Gtk +import qualified Data.Foldable as F +import qualified Data.IORef as IORef +import Data.Time ( NominalDiffTime, getCurrentTime, diffUTCTime ) +import Data.Tree ( Tree ) +import qualified Data.Tree as Tree +import Graphics.UI.Gtk ( AttrOp( (:=) ) ) +import qualified Graphics.UI.Gtk as Gtk +import Text.Printf ( printf ) +import Text.Read ( readMaybe ) import System.Glib.Signals ( on ) --import System.IO ( withFile, IOMode ( WriteMode ) ) --import qualified Data.ByteString.Lazy as BSL -import qualified Data.Tree as Tree -import Text.Printf ( printf ) +import qualified Data.Sequence as S -import Control.Applicative ( Applicative(..), liftA2 ) +import Accessors -import qualified GHC.Stats +import PlotHo.PlotTypes ( Channel(..) ) +import PlotHo.GraphWidget ( newGraph ) -import PlotTypes --( Channel(..), SignalTree ) -import Accessors -import GraphWidget ( newGraph ) -import ReadMaybe ( readMaybe ) newtype Plotter a = Plotter { unPlotter :: IO (a, [ChannelStuff]) } deriving Functor @@ -67,12 +69,84 @@ ChannelStuff { csKillThreads :: IO () , csMkChanEntry :: CC.MVar [Gtk.Window] -> IO Gtk.VBox - , csClearChan :: IO () } -makeSignalTree :: Lookup a => a -> SignalTree a -makeSignalTree x = case accessors x of +addHistoryChannel :: + Lookup a + => String -> XAxisType -> ((a -> Bool -> IO ()) -> IO ()) + -> Plotter () +addHistoryChannel name xaxisType action = do + (chan, newMessage) <- liftIO $ newHistoryChannel name xaxisType + workerTid <- liftIO $ CC.forkIO (action newMessage) + tell ChannelStuff { csKillThreads = CC.killThread workerTid + , csMkChanEntry = newChannelWidget chan + } + + +addChannel :: + String + -> (a -> a -> Bool) + -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) + -> ((a -> IO ()) -> IO ()) + -> Plotter () +addChannel name sameSignalTree toSignalTree action = do + (chan, newMessage) <- liftIO $ newChannel name sameSignalTree toSignalTree + workerTid <- liftIO $ CC.forkIO (action newMessage) + tell ChannelStuff { csKillThreads = CC.killThread workerTid + , csMkChanEntry = newChannelWidget chan + } + + +newChannel :: + forall a + . String + -> (a -> a -> Bool) + -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) + -> IO (Channel a, a -> IO ()) +newChannel name sameSignalTree toSignalTree = do + msgStore <- Gtk.listStoreNew [] + maxHist <- IORef.newIORef 0 + + let newMessage :: a -> IO () + newMessage next = do + -- 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 + + let retChan = Channel { chanName = name + , chanMsgStore = msgStore + , chanSameSignalTree = sameSignalTree + , chanToSignalTree = toSignalTree + , chanMaxHistory = maxHist + } + + return (retChan, newMessage) + + +data History a = History (S.Seq (a, Int, NominalDiffTime)) + +type SignalTree a = Tree.Forest (String, String, Maybe (History a -> [[(Double, Double)]])) + +data XAxisType = + XAxisTime + | XAxisCount + | XAxisTime0 + | XAxisCount0 + +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" d -> Tree.subForest $ head $ makeSignalTree' "" "" d where @@ -83,78 +157,89 @@ (concatMap (\(getterName,child) -> makeSignalTree' getterName pn child) children) ] makeSignalTree' myName parentName (ATGetter getter) = - [Tree.Node (myName, parentName, Just (Left getter)) []] - - -addChannel :: String -> SignalTree a - -> ((a -> IO ()) -> (SignalTree a -> IO ()) -> IO ()) - -> Plotter () -addChannel name signalTree0 action = do - chanStuff <- liftIO $ newChannel name signalTree0 action - tell chanStuff - - -newChannel :: forall a . - String -> SignalTree a - -> ((a -> IO ()) -> (SignalTree a -> IO ()) -> IO ()) - -> IO ChannelStuff -newChannel name signalTree0 action = do - time0 <- getCurrentTime - - trajChan <- STM.atomically STM.newTQueue - trajMv <- CC.newMVar S.empty - maxHistMv <- CC.newMVar 200 - - signalTreeStore <- Gtk.listStoreNew [] - - let getLastValue :: IO a - getLastValue = do - val <- STM.atomically (STM.readTQueue trajChan) - empty <- STM.atomically (STM.isEmptyTQueue trajChan) - if empty then return val else getLastValue + [Tree.Node (myName, parentName, Just (toHistoryGetter getter)) []] + toHistoryGetter :: (a -> Double) -> History a -> [[(Double, Double)]] + toHistoryGetter = case axisType of + XAxisTime -> timeGetter + XAxisTime0 -> timeGetter0 + XAxisCount -> countGetter + XAxisCount0 -> countGetter0 + timeGetter get (History s) = [map (\(val, _, time) -> (realToFrac time, get val)) (F.toList s)] + timeGetter0 get (History s) = [map (\(val, _, time) -> (realToFrac time - time0, get val)) (F.toList s)] + where + time0 :: Double + time0 = case S.viewl s of + (_, _, time0') S.:< _ -> realToFrac time0' + S.EmptyL -> 0 + countGetter get (History s) = [map (\(val, k, _) -> (fromIntegral k, get val)) (F.toList s)] + countGetter0 get (History s) = [map (\(val, k, _) -> (fromIntegral k - k0, get val)) (F.toList s)] + where + k0 :: Double + k0 = case S.viewl s of + (_, k0', _) S.:< _ -> realToFrac k0' + S.EmptyL -> 0 - let rebuildSignalTree newSignalTree = do - --putStrLn $ "rebuilding signal tree" - size <- Gtk.listStoreGetSize signalTreeStore - if size == 0 - then Gtk.listStorePrepend signalTreeStore newSignalTree - else Gtk.listStoreSetValue signalTreeStore 0 newSignalTree +newHistoryChannel :: + forall a + . Lookup a + => String + -> XAxisType + -> IO (Channel (History a), a -> Bool -> IO ()) +newHistoryChannel name xaxisType = do + time0 <- getCurrentTime >>= IORef.newIORef + counter <- IORef.newIORef 0 + maxHist <- IORef.newIORef 200 - -- this is the loop that reads new messages and stores them - let serverLoop :: Int -> IO () - serverLoop k = do - -- wait until a new message is written to the Chan - newPoint0 <- getLastValue + msgStore <- Gtk.listStoreNew [] - -- grab the timestamp + let newMessage :: a -> Bool -> IO () + newMessage next reset = do + -- grab the time and counter time <- getCurrentTime + when reset $ do + IORef.writeIORef time0 time + IORef.writeIORef counter 0 - -- write to the mvar - maxHist <- CC.readMVar maxHistMv - let newPoint = (newPoint0, k, diffUTCTime time time0) - addPoint lst0 = S.drop (S.length lst0 - maxHist + 1) (lst0 S.|> newPoint) - CC.modifyMVar_ trajMv (return . addPoint) - return () + k <- IORef.readIORef counter + time0' <- IORef.readIORef time0 - -- loop forever - serverLoop (k+1) + IORef.writeIORef counter (k+1) + Gtk.postGUIAsync $ do + let val = (next, k, diffUTCTime time time0') + size <- Gtk.listStoreGetSize msgStore + if size == 0 + then Gtk.listStorePrepend msgStore (History (S.singleton val)) + else do History vals0 <- Gtk.listStoreGetValue msgStore 0 + maxHistory <- IORef.readIORef maxHist + let undropped = vals0 S.|> val + dropped = S.drop (S.length undropped - maxHistory) undropped + Gtk.listStoreSetValue msgStore 0 (History dropped) - let updateMaxHist k = CC.modifyMVar_ maxHistMv (const (return k)) + when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val)) - rebuildSignalTree signalTree0 - serverTid <- CC.forkIO (serverLoop 0) - let writeToThread = STM.atomically . STM.writeTQueue trajChan + 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 + , 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" - p <- CC.forkIO (action writeToThread (Gtk.postGUISync . rebuildSignalTree)) + let retChan = Channel { chanName = name + , chanMsgStore = msgStore + , chanSameSignalTree = sst + , chanToSignalTree = tst + , chanMaxHistory = maxHist + } - return $ - ChannelStuff - { csKillThreads = mapM_ CC.killThread [serverTid,p] - , csMkChanEntry = newChannelWidget trajMv signalTreeStore updateMaxHist name - , csClearChan = CC.modifyMVar_ trajMv (const (return S.empty)) - } + return (retChan, newMessage) runPlotter :: Plotter () -> IO () @@ -162,6 +247,7 @@ statsEnabled <- GHC.Stats.getGCStatsEnabled _ <- Gtk.initGUI + _ <- Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50 -- start the main window win <- Gtk.windowNew @@ -169,16 +255,6 @@ , Gtk.windowTitle := "Plot-ho-matic" ] - -- on close, kill all the windows and threads - graphWindowsToBeKilled <- CC.newMVar [] - - -- run the plotter monad - channels <- execPlotter plotterMonad - let windows = map csMkChanEntry channels - - chanWidgets <- mapM (\x -> x graphWindowsToBeKilled) windows - - -- ghc stats statsLabel <- Gtk.labelNew (Nothing :: Maybe String) let statsWorker = do CC.threadDelay 500000 @@ -192,7 +268,16 @@ 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 @@ -203,20 +288,17 @@ --------------- main widget ----------------- -- button to clear history - buttonClear <- Gtk.buttonNewWithLabel "clear history" - _ <- Gtk.onClicked buttonClear $ do - mapM_ csClearChan channels - - + buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing" + _ <- Gtk.onClicked buttonDoNothing $ + putStrLn "seriously, it does nothing" - -- vbox to hold buttons + -- 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 := buttonClear - , Gtk.boxChildPacking buttonClear := Gtk.PackNatural - ] ++ concatMap (\x -> [Gtk.containerChild := x + , Gtk.containerChild := buttonDoNothing + ] ++ concatMap (\x -> [ Gtk.containerChild := x , Gtk.boxChildPacking x := Gtk.PackNatural ]) chanWidgets @@ -225,48 +307,38 @@ Gtk.widgetShowAll win Gtk.mainGUI --- 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 -- the list of channels -newChannelWidget :: - CC.MVar (S.Seq (a, Int, NominalDiffTime)) - -> Gtk.ListStore (SignalTree a) - -> (Int -> IO ()) - -> String - -> CC.MVar [Gtk.Window] - -> IO Gtk.VBox -newChannelWidget logData signalTreeStore updateMaxHistMVar name graphWindowsToBeKilled = do +newChannelWidget :: Channel a + -> CC.MVar [Gtk.Window] -> IO Gtk.VBox +newChannelWidget channel graphWindowsToBeKilled = do vbox <- Gtk.vBoxNew False 4 nameBox' <- Gtk.hBoxNew False 4 - nameBox <- labeledWidget name nameBox' + nameBox <- labeledWidget (chanName channel) nameBox' buttonsBox <- Gtk.hBoxNew False 4 -- button to clear history - buttonClear <- Gtk.buttonNewWithLabel "clear history" - _ <- Gtk.onClicked buttonClear $ do - CC.modifyMVar_ logData (const (return S.empty)) + buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing" + _ <- Gtk.onClicked buttonAlsoDoNothing $ do + putStrLn "i promise, nothing happens" + -- CC.modifyMVar_ logData (const (return S.empty)) return () -- button to make a new graph buttonNew <- Gtk.buttonNewWithLabel "new graph" _ <- Gtk.onClicked buttonNew $ do - graphWin <- newGraph name signalTreeStore logData + graphWin <- newGraph + (chanName channel) + (chanSameSignalTree channel) + (chanToSignalTree channel) + (chanMsgStore channel) -- add this window to the list to be killed on exit CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:)) + -- entry to set history length entryAndLabel <- Gtk.hBoxNew False 4 entryLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "max history:" @@ -277,9 +349,13 @@ Gtk.entrySetText entryEntry "200" let updateMaxHistory = do txt <- Gtk.get entryEntry Gtk.entryText - case readMaybe txt of - Just k -> updateMaxHistMVar k - Nothing -> putStrLn $ "max history: couldn't make an Int out of \"" ++ show txt ++ "\"" + let reset = Gtk.entrySetText entryEntry "(max)" + case readMaybe txt :: Maybe Int of + Nothing -> + putStrLn ("max history: couldn't make an Int out of \"" ++ show txt ++ "\"") >> reset + Just 0 -> putStrLn ("max history: must be greater than 0") >> reset + Just k -> IORef.writeIORef (chanMaxHistory channel) k + _ <- on entryEntry Gtk.entryActivate updateMaxHistory updateMaxHistory @@ -294,8 +370,8 @@ -- put all the buttons/entries together Gtk.set buttonsBox [ Gtk.containerChild := buttonNew , Gtk.boxChildPacking buttonNew := Gtk.PackNatural - , Gtk.containerChild := buttonClear - , Gtk.boxChildPacking buttonClear := Gtk.PackNatural + , Gtk.containerChild := buttonAlsoDoNothing + , Gtk.boxChildPacking buttonAlsoDoNothing := Gtk.PackNatural , Gtk.containerChild := entryAndLabel , Gtk.boxChildPacking entryAndLabel := Gtk.PackNatural ] @@ -331,3 +407,16 @@ -- return () -- -- return treeview + + +-- 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 diff --git a/src/PlotHo/GraphWidget.hs b/src/PlotHo/GraphWidget.hs new file mode 100644 --- /dev/null +++ b/src/PlotHo/GraphWidget.hs @@ -0,0 +1,358 @@ +{-# OPTIONS_GHC -Wall #-} +{-# Language ScopedTypeVariables #-} + +module PlotHo.GraphWidget + ( newGraph + ) where + +import qualified Control.Concurrent as CC +import Control.Monad ( when, unless ) +import qualified Data.IORef as IORef +import Data.Maybe ( isJust, fromJust ) +import qualified Data.Tree as Tree +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 qualified Graphics.Rendering.Chart as Chart + +import PlotHo.PlotChart ( AxisScaling(..), displayChart, chartGtkUpdateCanvas ) +import PlotHo.PlotTypes ( GraphInfo(..), ListViewInfo(..) ) + +-- make a new graph window +newGraph :: + forall a + . String + -> (a -> a -> Bool) + -> (a -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) + -> Gtk.ListStore a -> IO Gtk.Window +newGraph channame sameSignalTree forestFromMeta msgStore = do + win <- Gtk.windowNew + + _ <- Gtk.set win [ Gtk.containerBorderWidth := 8 + , Gtk.windowTitle := channame + ] + + -- mvar with all the user input + graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = LinearScaling + , giYScaling = LinearScaling + , giXRange = Nothing + , giYRange = Nothing + , giGetters = [] + } :: IO (CC.MVar (GraphInfo a)) + + let makeRenderable :: IO (Chart.Renderable ()) + makeRenderable = do + gi <- CC.readMVar graphInfoMVar + size <- Gtk.listStoreGetSize msgStore + + namePcs <- if size == 0 + then return [] + else do + datalog <- Gtk.listStoreGetValue msgStore 0 + let ret :: [(String, [[(Double,Double)]])] + ret = map (fmap (\g -> g datalog)) (giGetters gi) + return ret + return $ displayChart (giXScaling gi, giYScaling gi) (giXRange gi, giYRange gi) namePcs + + -- chart drawing area + chartCanvas <- Gtk.drawingAreaNew + _ <- Gtk.widgetSetSizeRequest chartCanvas 250 250 + + let redraw :: IO () + redraw = do + renderable <- makeRenderable + chartGtkUpdateCanvas renderable chartCanvas + + _ <- Gtk.onExpose chartCanvas $ const (redraw >> return True) + + + -- the options widget + optionsWidget <- makeOptionsWidget graphInfoMVar redraw + options <- Gtk.expanderNew "options" + Gtk.set options [ Gtk.containerChild := optionsWidget + , Gtk.expanderExpanded := False + ] + + + -- the signal selector + treeview' <- newSignalSelectorArea sameSignalTree forestFromMeta graphInfoMVar msgStore redraw + treeview <- Gtk.expanderNew "signals" + Gtk.set treeview [ Gtk.containerChild := treeview' + , Gtk.expanderExpanded := True + ] + + -- options and signal selector packed in vbox + vboxOptionsAndSignals <- Gtk.vBoxNew False 4 + Gtk.set vboxOptionsAndSignals + [ Gtk.containerChild := options + , Gtk.boxChildPacking options := Gtk.PackNatural + , Gtk.containerChild := treeview + , Gtk.boxChildPacking treeview := Gtk.PackGrow + ] + + -- hbox to hold eveything + hboxEverything <- Gtk.hBoxNew False 4 + Gtk.set hboxEverything + [ Gtk.containerChild := vboxOptionsAndSignals + , Gtk.boxChildPacking vboxOptionsAndSignals := Gtk.PackNatural + , Gtk.containerChild := chartCanvas + ] + _ <- Gtk.set win [ Gtk.containerChild := hboxEverything ] + + Gtk.widgetShowAll win + return win + + + +newSignalSelectorArea :: + forall a + . (a -> a -> Bool) + -> (a -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) + -> CC.MVar (GraphInfo a) + -> Gtk.ListStore a + -> IO () -> IO Gtk.ScrolledWindow +newSignalSelectorArea sameSignalTree forestFromMeta graphInfoMVar msgStore redraw = do + treeStore <- Gtk.treeStoreNew [] + treeview <- Gtk.treeViewNewWithModel treeStore + + Gtk.treeViewSetHeadersVisible treeview True + + -- add some columns + col1 <- Gtk.treeViewColumnNew + col2 <- Gtk.treeViewColumnNew + + Gtk.treeViewColumnSetTitle col1 "signal" + Gtk.treeViewColumnSetTitle col2 "visible?" + + renderer1 <- Gtk.cellRendererTextNew + renderer2 <- Gtk.cellRendererToggleNew + + Gtk.cellLayoutPackStart col1 renderer1 True + Gtk.cellLayoutPackStart col2 renderer2 True + + let showName (Just _) name _ = name + showName Nothing name "" = name + showName Nothing name typeName = name ++ " (" ++ typeName ++ ")" + Gtk.cellLayoutSetAttributes col1 renderer1 treeStore $ + \(ListViewInfo {lviName = name, lviType = typeName, lviGetter = getter}) -> + [ Gtk.cellText := showName getter name typeName] + Gtk.cellLayoutSetAttributes col2 renderer2 treeStore $ \lvi -> [ Gtk.cellToggleActive := lviMarked lvi] + + _ <- Gtk.treeViewAppendColumn treeview col1 + _ <- Gtk.treeViewAppendColumn treeview col2 + + + let -- update the graph information + updateGraphInfo = do + -- first get all trees + let getTrees k = do + tree' <- Gtk.treeStoreLookup treeStore [k] + case tree' of Nothing -> return [] + Just tree -> fmap (tree:) (getTrees (k+1)) + theTrees <- getTrees 0 + let newGetters = [ (lviName lvi, fromJust $ lviGetter lvi) + | lvi <- concatMap Tree.flatten theTrees + , lviMarked lvi + , isJust (lviGetter lvi) + ] + _ <- CC.modifyMVar_ graphInfoMVar (\gi0 -> return $ gi0 { giGetters = newGetters }) + return () + + -- update which y axes are visible + _ <- on renderer2 Gtk.cellToggled $ \pathStr -> do + let treePath = Gtk.stringToTreePath pathStr + -- toggle the check mark + let g lvi@(ListViewInfo _ _ Nothing _) = lvi + g lvi = lvi {lviMarked = not (lviMarked lvi)} + ret <- Gtk.treeStoreChange treeStore treePath g + unless ret $ putStrLn "treeStoreChange fail" + updateGraphInfo + redraw + + + -- rebuild the signal tree + let rebuildSignalTree :: [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))] + -> IO () + rebuildSignalTree meta = do + let mkTreeNode (name,typeName,maybeget) = ListViewInfo name typeName maybeget False + newTrees :: [Tree.Tree (ListViewInfo a)] + newTrees = map (fmap mkTreeNode) meta + Gtk.treeStoreClear treeStore + Gtk.treeStoreInsertForest treeStore [] 0 newTrees + updateGraphInfo + + oldMetaRef <- IORef.newIORef Nothing + let maybeRebuildSignalTree newMeta = do + oldMeta <- IORef.readIORef oldMetaRef + let sameSignalTree' Nothing _ = False + sameSignalTree' (Just x) y = sameSignalTree x y + unless (sameSignalTree' oldMeta newMeta) $ do + IORef.writeIORef oldMetaRef (Just newMeta) + rebuildSignalTree (forestFromMeta newMeta) + + -- on insert or change, rebuild the signal tree + _ <- on msgStore Gtk.rowChanged $ \_ changedPath -> do + newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath) + maybeRebuildSignalTree newMsg >> redraw + _ <- on msgStore Gtk.rowInserted $ \_ changedPath -> do + newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath) + maybeRebuildSignalTree newMsg >> redraw + + -- rebuild the signal tree right now if it exists + size <- Gtk.listStoreGetSize msgStore + when (size > 0) $ do + newMsg <- Gtk.listStoreGetValue msgStore 0 + maybeRebuildSignalTree newMsg >> redraw + + + scroll <- Gtk.scrolledWindowNew Nothing Nothing + Gtk.containerAdd scroll treeview + Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever + , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic + ] + return scroll + + + +makeOptionsWidget :: CC.MVar (GraphInfo a) -> IO () -> IO Gtk.VBox +makeOptionsWidget graphInfoMVar redraw = do + -- user selectable range + xRange <- Gtk.entryNew + yRange <- Gtk.entryNew + Gtk.set xRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + Gtk.set yRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + xRangeBox <- labeledWidget "x range:" xRange + yRangeBox <- labeledWidget "y range:" yRange + Gtk.set xRange [Gtk.entryText := "(-10,10)"] + Gtk.set yRange [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)}) + redraw + let updateYRange = do + Gtk.set yRange [ Gtk.entryEditable := True + , Gtk.widgetSensitive := True + ] + txt <- Gtk.get yRange Gtk.entryText + gi <- CC.readMVar graphInfoMVar + case readMaybe txt of + Nothing -> do + putStrLn $ "invalid y range entry: " ++ txt + Gtk.set yRange [Gtk.entryText := "(min,max)"] + Just (z0,z1) -> if z0 >= z1 + then do + putStrLn $ "invalid y range entry (min >= max): " ++ txt + Gtk.set yRange [Gtk.entryText := "(min,max)"] + return () + else do + _ <- CC.swapMVar graphInfoMVar (gi {giYRange = Just (z0,z1)}) + redraw + _ <- on xRange Gtk.entryActivate updateXRange + _ <- on yRange Gtk.entryActivate updateYRange + + -- linear or log scaling on the x and y axis? + xScalingSelector <- Gtk.comboBoxNewText + yScalingSelector <- Gtk.comboBoxNewText + mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack) + ["linear (auto)","linear (manual)","logarithmic (auto)"] + mapM_ (Gtk.comboBoxAppendText yScalingSelector . T.pack) + ["linear (auto)","linear (manual)","logarithmic (auto)"] + Gtk.comboBoxSetActive xScalingSelector 0 + Gtk.comboBoxSetActive yScalingSelector 0 + xScalingBox <- labeledWidget "x scaling:" xScalingSelector + yScalingBox <- labeledWidget "y scaling:" yScalingSelector + 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 = LinearScaling, giXRange = Nothing} + 1 -> do + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXScaling = LinearScaling, giXRange = Nothing} + updateXRange + 2 -> do + Gtk.set xRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXScaling = LogScaling, giXRange = Nothing} + _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 3" + redraw + let updateYScaling = do + k <- Gtk.comboBoxGetActive yScalingSelector + _ <- case k of + 0 -> do + Gtk.set yRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giYScaling = LinearScaling, giYRange = Nothing} + 1 -> do + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giYScaling = LinearScaling, giYRange = Nothing} + updateYRange + 2 -> do + Gtk.set yRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giYScaling = LogScaling, giYRange = Nothing} + _ -> error "the \"impossible\" happened: y scaling comboBox index should be < 3" + redraw + updateXScaling + updateYScaling + _ <- on xScalingSelector Gtk.changed updateXScaling + _ <- on yScalingSelector Gtk.changed updateYScaling + + -- 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 + , Gtk.containerChild := yScalingBox + , Gtk.boxChildPacking yScalingBox := Gtk.PackNatural + , Gtk.containerChild := yRangeBox + , Gtk.boxChildPacking yRangeBox := 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 diff --git a/src/PlotHo/PlotChart.hs b/src/PlotHo/PlotChart.hs new file mode 100644 --- /dev/null +++ b/src/PlotHo/PlotChart.hs @@ -0,0 +1,75 @@ +{-# OPTIONS_GHC -Wall #-} + +module PlotHo.PlotChart + ( AxisScaling(..) + , displayChart + , chartGtkUpdateCanvas + ) where + +import Control.Lens ( (.~) ) +import Data.Default.Class ( def ) +--import qualified Data.Foldable as F +--import qualified Data.Sequence as S +import qualified Graphics.UI.Gtk as Gtk +import qualified Graphics.Rendering.Chart as Chart +import Graphics.Rendering.Chart.Backend.Cairo ( runBackend, defaultEnv ) +import Graphics.Rendering.Cairo hiding (width, height) + --( Render, Format(..) + --, renderWith, setSourceSurface, withImageSurface ) + +import PlotHo.PlotTypes ( AxisScaling(..) ) + +chartGtkUpdateCanvas :: Chart.Renderable () -> Gtk.DrawingArea -> IO () +chartGtkUpdateCanvas chart canvas = do + Gtk.threadsEnter + maybeWin <- Gtk.widgetGetWindow canvas + case maybeWin of + Nothing -> Gtk.threadsLeave >> return () + Just win -> do + (width, height) <- Gtk.widgetGetSize canvas + regio <- Gtk.regionRectangle $ Gtk.Rectangle 0 0 width height + Gtk.threadsLeave + let sz = (fromIntegral width,fromIntegral height) + let render0 :: Render (Chart.PickFn ()) + render0 = runBackend (defaultEnv Chart.bitmapAlignmentFns) (Chart.render chart sz) + + withImageSurface FormatARGB32 width height $ \surface -> do + _ <- renderWith surface render0 + let render1 = setSourceSurface surface 0 0 >> paint + Gtk.threadsEnter + Gtk.drawWindowBeginPaintRegion win regio + _ <- Gtk.renderWithDrawable win render1 + Gtk.drawWindowEndPaint win + Gtk.threadsLeave + +displayChart :: (Chart.PlotValue a, Show a, RealFloat a) => + (AxisScaling, AxisScaling) -> (Maybe (a,a),Maybe (a,a)) -> + [(String, [[(a,a)]])] -> Chart.Renderable () +displayChart (xScaling,yScaling) (xRange,yRange) namePcs = Chart.toRenderable layout + where + drawOne (name,pc) col + = Chart.plot_lines_values .~ pc + $ Chart.plot_lines_style . Chart.line_color .~ col +-- $ Chart.plot_points_style ~. Chart.filledCircles 2 red + $ Chart.plot_lines_title .~ name + $ def + allLines = zipWith drawOne namePcs Chart.defaultColorSeq + + xscaleFun = case xScaling of + LogScaling -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def + LinearScaling -> case xRange of + Nothing -> id + Just range -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.scaledAxis def range + + yscaleFun = case yScaling of + LogScaling -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def + LinearScaling -> case yRange of + Nothing -> id + Just range -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.scaledAxis def range + + layout = Chart.layout_plots .~ map Chart.toPlot allLines +-- $ Chart.layout_title .~ "Wooo, Party Graph!" + $ Chart.layout_x_axis . Chart.laxis_title .~ "time [s]" + $ xscaleFun + $ yscaleFun + def diff --git a/src/PlotHo/PlotTypes.hs b/src/PlotHo/PlotTypes.hs new file mode 100644 --- /dev/null +++ b/src/PlotHo/PlotTypes.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -Wall #-} +--{-# Language ExistentialQuantification #-} +--{-# Language GADTs #-} + +module PlotHo.PlotTypes + ( Channel(..) + , GraphInfo(..) + , ListViewInfo(..) + , AxisScaling(..) + ) where + +import Data.Tree ( Tree ) +import qualified Graphics.UI.Gtk as Gtk +import Data.IORef ( IORef ) + +data ListViewInfo a = + ListViewInfo + { lviName :: String + , lviType :: String + , lviGetter :: Maybe (a -> [[(Double,Double)]]) + , lviMarked :: Bool + } + +data AxisScaling = LogScaling + | LinearScaling + +-- what the graph should draw +data GraphInfo a = + GraphInfo { giXScaling :: AxisScaling + , giYScaling :: AxisScaling + , giXRange :: Maybe (Double,Double) + , giYRange :: Maybe (Double,Double) + , giGetters :: [(String, a -> [[(Double,Double)]])] + } + +data Channel a = + Channel { chanName :: String + , chanMsgStore :: Gtk.ListStore a + , chanSameSignalTree :: a -> a -> Bool + , chanToSignalTree :: a -> [Tree ( String + , String + , Maybe (a -> [[(Double, Double)]]) + )] + , chanMaxHistory :: IORef Int + } diff --git a/src/PlotTypes.hs b/src/PlotTypes.hs deleted file mode 100644 --- a/src/PlotTypes.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ---{-# Language ExistentialQuantification #-} ---{-# Language GADTs #-} - -module PlotTypes - ( ListViewInfo(..) - , SignalTree - , Getter - ) where - -import Data.Time ( NominalDiffTime ) -import qualified Data.Sequence as S -import qualified Data.Tree as Tree - -type Getter a = Either (a -> Double) (S.Seq (a, Int, NominalDiffTime) -> [[(Double,Double)]]) - --- | a tree of name/getter pairs -type SignalTree a = Tree.Forest (String, String, Maybe (Getter a)) - -data ListViewInfo a = ListViewInfo { lviName :: String - , lviType :: String - , lviGetter :: Maybe (Getter a) - , lviMarked :: Bool - } diff --git a/src/ReadMaybe.hs b/src/ReadMaybe.hs deleted file mode 100644 --- a/src/ReadMaybe.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - -module ReadMaybe - ( readMaybe - ) where - --- | GHC 7.4 compatability -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x, "")] -> Just x - _ -> Nothing