Plot-ho-matic 0.4.0.4 → 0.5.0.0
raw patch · 13 files changed
+726/−931 lines, 13 filesdep +cairodep +generic-accessorsdep +spatial-mathdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: cairo, generic-accessors, spatial-math
Dependency ranges changed: base
API changes (from Hackage documentation)
- PlotHo: ATGetter :: (a -> Double) -> AccessorTree a
- PlotHo: Data :: (String, String) -> [(String, AccessorTree a)] -> AccessorTree a
- PlotHo: data AccessorTree a
- PlotHo: makeSignalTree :: Lookup a => a -> SignalTree a
- PlotHo: toAccessorTree :: Lookup a => a -> (b -> a) -> AccessorTree b
- PlotHo: type SignalTree a = Forest (String, String, Maybe (Getter a))
+ PlotHo: XAxisCount :: XAxisType
+ PlotHo: XAxisCount0 :: XAxisType
+ PlotHo: XAxisTime :: XAxisType
+ PlotHo: XAxisTime0 :: XAxisType
+ PlotHo: addHistoryChannel :: Lookup a => String -> XAxisType -> ((a -> Bool -> IO ()) -> IO ()) -> Plotter ()
+ PlotHo: data Plotter a
+ PlotHo: data XAxisType
- PlotHo: addChannel :: String -> SignalTree a -> ((a -> IO ()) -> (SignalTree a -> IO ()) -> IO ()) -> Plotter ()
+ PlotHo: addChannel :: String -> (a -> a -> Bool) -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -> ((a -> IO ()) -> IO ()) -> Plotter ()
- PlotHo: class Lookup a where toAccessorTree x f = gtoAccessorTree (from x) (from . f)
+ PlotHo: class Lookup a
Files
- .travis.yml +1/−1
- CHANGELOG.md +7/−0
- Plot-ho-matic.cabal +10/−9
- examples/Example.hs +10/−13
- src/Accessors.hs +0/−255
- src/GraphWidget.hs +0/−347
- src/PlotChart.hs +0/−140
- src/PlotHo.hs +220/−131
- src/PlotHo/GraphWidget.hs +358/−0
- src/PlotHo/PlotChart.hs +75/−0
- src/PlotHo/PlotTypes.hs +45/−0
- src/PlotTypes.hs +0/−24
- src/ReadMaybe.hs +0/−11
.travis.yml view
@@ -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
CHANGELOG.md view
@@ -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
Plot-ho-matic.cabal view
@@ -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
examples/Example.hs view
@@ -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
− src/Accessors.hs
@@ -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
− src/GraphWidget.hs
@@ -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
− src/PlotChart.hs
@@ -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
src/PlotHo.hs view
@@ -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
+ src/PlotHo/GraphWidget.hs view
@@ -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
+ src/PlotHo/PlotChart.hs view
@@ -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
+ src/PlotHo/PlotTypes.hs view
@@ -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+ }
− src/PlotTypes.hs
@@ -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- }
− src/ReadMaybe.hs
@@ -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