Plot-ho-matic 0.2.0.0 → 0.4.0.0
raw patch · 11 files changed
+997/−651 lines, 11 filesdep +Chart-gtkdep +Plot-ho-maticdep +data-default-classdep −bytestringdep −data-accessordep −protocol-buffersdep ~Chartdep ~basenew-component:exe:examplePVP ok
version bump matches the API change (PVP)
Dependencies added: Chart-gtk, Plot-ho-matic, data-default-class, lens, linear, stm
Dependencies removed: bytestring, data-accessor, protocol-buffers, template-haskell, transformers
Dependency ranges changed: Chart, base
API changes (from Hackage documentation)
- Plotter: data Channel
- Plotter: makeAccessors :: Name -> Q Exp
- Plotter: newChannel :: (ReflectDescriptor a, Wire a) => String -> PbTree a -> IO (Channel, a -> IO ())
- Plotter: runPlotter :: [Channel] -> [ThreadId] -> IO ()
+ PlotHo: ATGetter :: (a -> Double) -> AccessorTree a
+ PlotHo: Data :: (String, String) -> [(String, AccessorTree a)] -> AccessorTree a
+ PlotHo: addChannel :: String -> SignalTree a -> ((a -> IO ()) -> (SignalTree a -> IO ()) -> IO ()) -> Plotter ()
+ PlotHo: class Lookup a where toAccessorTree x f = gtoAccessorTree (from x) (from . f)
+ PlotHo: data AccessorTree a
+ PlotHo: instance Applicative Plotter
+ PlotHo: instance Functor Plotter
+ PlotHo: instance Monad Plotter
+ PlotHo: makeSignalTree :: Lookup a => a -> SignalTree a
+ PlotHo: runPlotter :: Plotter () -> IO ()
+ PlotHo: toAccessorTree :: Lookup a => a -> (b -> a) -> AccessorTree b
+ PlotHo: type SignalTree a = Forest (String, String, Maybe (Getter a))
Files
- .travis.yml +35/−2
- CHANGELOG.md +14/−0
- Plot-ho-matic.cabal +37/−21
- examples/Example.hs +62/−0
- src/Accessors.hs +236/−97
- src/GraphWidget.hs +175/−157
- src/PlotChart.hs +85/−99
- src/PlotHo.hs +332/−0
- src/PlotTypes.hs +17/−75
- src/Plotter.hs +0/−199
- src/ReadMaybe.hs +4/−1
.travis.yml view
@@ -1,3 +1,36 @@-language: haskell+# from https://github.com/hvr/multi-ghc-travis++env:+ - GHCVER=7.6.3+ - GHCVER=7.8.2 # see note about Alex/Happy+ before_install:- - travis/cabal-apt-install+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc+ - travis_retry sudo apt-get update+ - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER libgsl0-dev liblapack-dev+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH++install:+ - cabal update+ - cabal install alex+ - cabal install happy+ - cabal install gtk2hs-buildtools+ - cabal install --only-dependencies --enable-tests --enable-benchmarks++# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.+script:+ - 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 check+ - cabal sdist # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be built & installed+ - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;+ cd dist/;+ if [ -f "$SRC_TGZ" ]; then+ cabal install "$SRC_TGZ";+ else+ echo "expected '$SRC_TGZ' not found";+ exit 1;+ fi
CHANGELOG.md view
@@ -1,3 +1,17 @@ 0.1 --- * Initial release (moved from rawesome repo)++0.2+---+* Cleaner API++0.3 (Unreleased development version)+---+* switch from Template Haskell to GHC.Generics++0.4+---+* Performance improvements+* Safer monadic API+* More general plottable types
Plot-ho-matic.cabal view
@@ -1,14 +1,14 @@ name: Plot-ho-matic-version: 0.2.0.0+version: 0.4.0.0 synopsis: Real-time line plotter for protobuf-like data license: BSD3 license-file: LICENSE author: Greg Horn maintainer: gregmainland@gmail.com-copyright: Copyright (c) 2013, Greg Horn+copyright: Copyright (c) 2013-2014, Greg Horn category: Graphics build-type: Simple-cabal-version: >=1.8+cabal-version: >=1.10 extra-source-files: .gitignore .travis.yml@@ -16,31 +16,47 @@ README.md description: { Plot-ho-matic provides real-time plotting of time-series data with a simple interface.-.-Changelo } library hs-source-dirs: src--- Example,- exposed-modules: Plotter- other-modules: Accessors,- GraphWidget,+ default-language: Haskell2010+ exposed-modules: PlotHo+ other-modules: GraphWidget,+ Accessors, PlotChart, PlotTypes, ReadMaybe- build-depends: base >= 4.5.0 && < 4.7,- protocol-buffers,- template-haskell,- containers,- glib,- gtk,- Chart,- time,- data-accessor,- bytestring,- transformers+ build-depends: base >= 4.5.0 && < 5+ , containers+ , lens+ , data-default-class+ , stm+ , glib+ , gtk+ , time+ , Chart >= 1.1+ , Chart-gtk >= 1.1+ , linear ghc-options: -O2 -Wall ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts- other-extensions: TemplateHaskell+++flag examples+ description: build the examples+ default: False++executable example+ if flag(examples)+ Buildable: True+ else+ Buildable: False+ hs-source-dirs: examples+ main-is: Example.hs+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 5+ , Plot-ho-matic+ , containers++ ghc-options: -threaded -O2
+ examples/Example.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language DeriveGeneric #-}++module Main where++import qualified Control.Concurrent as CC+import GHC.Generics ( Generic )+--import qualified System.Remote.Monitoring as EKG++import PlotHo ( Lookup, SignalTree, runPlotter, addChannel, makeSignalTree )++data Xyz = MkXyz { x :: Double+ , y :: Double+ , z :: Double+ } deriving Generic+data Axyz = MkAxyz { lol :: Double+-- , xyzList :: S.Seq Xyz+ , xyz :: Xyz+ } deriving Generic+instance Lookup Xyz+instance Lookup Axyz++axyz0 :: Axyz+axyz0 = MkAxyz+ 7+-- (S.fromList [MkXyz 1 2 3])+ (MkXyz 1 2 3)++xyz0 :: Xyz+xyz0 = MkXyz 1 2 3++incrementAxyz :: Axyz -> Axyz+incrementAxyz (MkAxyz a _) = MkAxyz+ (a+0.2)+-- (S.take 5 (xyz <| xyzs))+ xyz'+ where+ xyz' = MkXyz (sin a) (cos a) (sin a * cos a)++incrementXyz :: Xyz -> Xyz+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+ CC.threadDelay delay+ chan (increment x')+ channelWriter delay increment (increment x') chan++ast :: SignalTree Axyz+ast = makeSignalTree axyz0++st :: SignalTree Xyz+st = makeSignalTree xyz0++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)
src/Accessors.hs view
@@ -1,116 +1,255 @@ {-# OPTIONS_GHC -Wall #-}-{-# Language TemplateHaskell #-}-{-# Language ExistentialQuantification #-}+--{-# OPTIONS_GHC -ddump-deriv #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+--{-# LANGUAGE DeriveGeneric #-} -- for example at bottom -module Accessors ( makeAccessors ) where+module Accessors+ ( Generic+ , Lookup(..)+ , AccessorTree(..)+ , accessors+ , flatten+ ) where -import Data.Map ( Map )-import qualified Data.Map as M-import Data.Maybe ( fromMaybe )-import Language.Haskell.TH-import qualified Text.ProtocolBuffers.Header as P'+import Data.List ( intercalate )+import qualified Linear+import GHC.Word+import Data.Int+import Foreign.C.Types+import GHC.Generics -import PlotTypes ( PbTree(..), PbPrim(..) )+showAccTree :: String -> AccessorTree a -> [String]+showAccTree spaces (ATGetter _) = [spaces ++ "ATGetter {}"]+showAccTree spaces (Data name trees) =+ (spaces ++ "Data " ++ show name) :+ concatMap (showChild (spaces ++ " ")) trees -data AccessorTree = APrim ExpQ- | AStruct [(Name,AccessorTree)]- | ASeq AccessorTree- | AMaybe AccessorTree+showChild :: String -> (String, AccessorTree a) -> [String]+showChild spaces (name, tree) =+ (spaces ++ name) : showAccTree (spaces ++ " ") tree -atToPbt :: ExpQ -> AccessorTree -> ExpQ-atToPbt getDouble (APrim pbCon) = [| PbtGetter ($pbCon . $getDouble) |]-atToPbt getStruct (AStruct forest) = [| PbtStruct (zip strNames $forestQ) |]+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- forestQ = listE $ zipWith (\n t -> atToPbt [| $(varE n) . $getStruct |] t) names trees- (names,trees) = unzip forest- strNames = map nameBase names-atToPbt getSeq (ASeq pbf) =- [| PbtFunctor PbSeq $getSeq $(atToPbt [| id |] pbf) (\x -> "["++x++"]")|]-atToPbt getMaybe (AMaybe pbf) =- [| PbtFunctor PbMaybe $getMaybe $(atToPbt [| id |] pbf) (\x -> "("++x++")")|]+ 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 -pbPrimMap :: Map Name ExpQ-pbPrimMap =- M.fromList [ (''Double , [| PbDouble |])- , (''Float , [| PbFloat |])- , (''P'.Int32 , [| PbInt32 |])- , (''P'.Int64 , [| PbInt64 |])- , (''P'.Word32 , [| PbWord32 |])- , (''P'.Word64 , [| PbWord64 |])- , (''Bool , [| PbBool |])- , (''P'.Utf8 , [| PbUtf8 |])- , (''P'.ByteString, [| PbByteString |])- ]-getPbPrim :: Name -> Q (Maybe ExpQ)-getPbPrim name = case M.lookup name pbPrimMap of- x@(Just _) -> return x- Nothing -> do- isEnum <- isInstance ''Enum [ConT name]- return $ if isEnum- then Just [| PbEnum . (\x -> (fromEnum x, show x)) |]- else Nothing+ 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 --- | take a constructor field and return usable stuff-handleField :: Type -> Q AccessorTree-handleField (ConT type') = do- let safeGetInfo :: Q [Con]- safeGetInfo = do- info <- reify type'- case info of- (TyConI (DataD _ _ _ [constructor] _ )) -> return [constructor]- (TyConI (NewtypeD _ _ _ constructor _ )) -> return [constructor]- (TyConI (DataD _ _ _ constructors _ )) -> return constructors- d -> error $ "handleField: safeGetInfo got unsafe info: " ++ show d- constructors <- safeGetInfo- case constructors of- -- recursive protobuf- [RecC _ varStrictTypes] -> do- let (names,types) = unzip $ map (\(x,_,z) -> (x,z)) varStrictTypes- outputs <- mapM handleField types- return $ AStruct (zip names outputs)+class GLookupS f where+ gtoAccessorTreeS :: f a -> (b -> f a) -> [(String, AccessorTree b)] - -- empty protobuf- [NormalC _ []] -> return (AStruct [])+-- some instance from linear+instance (Lookup a, Generic a) => Lookup (Linear.V0 a) where+ toAccessorTree _ _ =+ Data ("V0", "V0") []+instance (Lookup a, Generic 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, Generic 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, Generic 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, Generic 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, Generic 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 - -- everything else- xx -> do- maybePrim <- getPbPrim type'- let msg = "can't find appropriate PbPrim for " ++ show type' ++ "\n" ++ show xx- con = fromMaybe (error msg) maybePrim - return (APrim con)--- handle optional fields-handleField x@(AppT (ConT con) (ConT type'))- | con == ''Maybe = fmap AMaybe $ handleField (ConT type')- | con == ''P'.Seq = fmap ASeq $ handleField (ConT type')- | otherwise = error $ "handleField (AppT ...): can't handle constructor "++show con++" in "++show x-handleField x = error $ "handleField _: unhandled case: " ++ show x+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 --- | Take a constructor with multiple fields, call handleFields on each of them,--- assemble the result-handleConstructor :: Con -> Q AccessorTree-handleConstructor (RecC _ varStrictTypes) = do- let (names,types) = unzip $ map (\(x,_,z) -> (x,z)) varStrictTypes- outputs <- mapM handleField types- return (AStruct (zip names outputs))-handleConstructor x = fail $ "\"" ++ show x ++ "\" is not a record syntax constructor"+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 -makeAccessors :: Name -> Q Exp-makeAccessors typ = do- -- get the type info- let safeGetInfo :: Q Info- safeGetInfo = do- info <- reify typ- case info of- d@(TyConI (DataD _ _ _ [_] _ )) -> return d- (TyConI (DataD _ typeName _ constructors _ )) ->- error $ "setupTelem: too many constructors: " ++ show (typeName, constructors)- d -> error $ "setupTelem: safeGetInfo got unsafe info: " ++ show d- TyConI (DataD _ _typeName _ [constructor] _ ) <- safeGetInfo+ left ( x' :*: _ ) = x'+ right ( _ :*: y' ) = y' - outputs' <- handleConstructor constructor- atToPbt [| id |] outputs'+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 view
@@ -1,147 +1,186 @@ {-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-} -module GraphWidget ( newGraph ) where+-- | 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 ( unless )-import Data.Maybe ( mapMaybe, isJust, fromJust )+import Control.Monad ( when, unless )+import qualified Data.Sequence as S import qualified Data.Tree as Tree import Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified Graphics.UI.Gtk as Gtk+import Data.Time ( NominalDiffTime ) import System.Glib.Signals ( on ) -import PlotTypes ( Channel(..), XAxisType(..), PbPrim )-import PlotChart ( GraphInfo(..), AxisScaling(..), newChartCanvas )+import PlotChart ( GraphInfo(..), AxisScaling(..), XAxisType(..), newChartCanvas )+import PlotTypes ( SignalTree, ListViewInfo(..), Getter ) import ReadMaybe ( readMaybe ) -data ListViewInfo a = ListViewInfo { lviName :: String- , lviFullName :: String- , lviGetter :: Maybe (a -> PbPrim)- , lviMarked :: Bool- }--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-- -- make a new graph window-newGraph :: Channel -> IO Gtk.Window-newGraph chan@(Channel {chanGetters = changetters, chanSeq = chanseq}) = do+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 chan+ , Gtk.windowTitle := channame ] -- mvar with everything the graphs need to plot graphInfoMVar <- CC.newMVar GraphInfo { giData = chanseq- , giLen = 0 -- changed immediately- , giXAxis = XAxisStaticCounter , giXScaling = LinearScaling , giYScaling = LinearScaling , giXRange = Nothing , giYRange = Nothing+ , giXAxisType = XAxisCounter , giGetters = [] }- - -- the thing where users select stuff- options' <- makeOptionsWidget graphInfoMVar changetters++ -- the options widget+ optionsWidget <- makeOptionsWidget graphInfoMVar options <- Gtk.expanderNew "options"- Gtk.set options [ Gtk.containerChild := options'- , Gtk.expanderExpanded := True+ Gtk.set options [ Gtk.containerChild := optionsWidget+ , Gtk.expanderExpanded := False ]- - - -- create a new tree model- treeview' <- newTreeViewArea changetters graphInfoMVar++ -- the signal selector+ treeview' <- newSignalSelectorArea graphInfoMVar signalTreeStore treeview <- Gtk.expanderNew "signals" Gtk.set treeview [ Gtk.containerChild := treeview' , Gtk.expanderExpanded := True ]- - vbox <- Gtk.vBoxNew False 4- Gtk.set vbox [ Gtk.containerChild := options- , Gtk.boxChildPacking options := Gtk.PackNatural- , Gtk.containerChild := treeview- , Gtk.boxChildPacking treeview := Gtk.PackGrow- ]- ++ -- 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- hbox <- Gtk.hBoxNew False 4- Gtk.set hbox [ Gtk.containerChild := vbox- , Gtk.boxChildPacking vbox := Gtk.PackNatural- , Gtk.containerChild := chartCanvas- ]- _ <- Gtk.set win [ Gtk.containerChild := hbox ]+ 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 -makeOptionsWidget :: CC.MVar (GraphInfo a) -> Tree.Tree (String, String, Maybe (a -> PbPrim))- -> IO Gtk.VBox-makeOptionsWidget graphInfoMVar changetters = do- -- how many to show?- plotLength <- Gtk.entryNew- plotLengthBox <- labeledWidget "# points to plot:" plotLength- - Gtk.set plotLength [Gtk.entryText := "100"]- let updatePlotLength = do- txt <- Gtk.get plotLength Gtk.entryText- gi <- CC.readMVar graphInfoMVar- case readMaybe txt of- Nothing -> do- putStrLn $ "invalid non-integer range entry: " ++ txt- Gtk.set plotLength [Gtk.entryText := show (giLen gi)]- Just k -> if k < 0- then do- putStrLn $ "invalid negative range entry: " ++ txt- Gtk.set plotLength [Gtk.entryText := show (giLen gi)]- return ()- else do- _ <- CC.swapMVar graphInfoMVar (gi {giLen = k})- return ()- updatePlotLength- _ <- on plotLength Gtk.entryActivate updatePlotLength - -- which one is the x axis?- xaxisSelector <- Gtk.comboBoxNewText- let xaxisSelectorStrings = ["(static counter)","(counter)","(timestamp)"]- mapM_ (Gtk.comboBoxAppendText xaxisSelector) xaxisSelectorStrings- let f (_,_,Nothing) = Nothing- f (_,x,Just y) = Just (x,y)- xaxisGetters = mapMaybe f (Tree.flatten changetters)- mapM_ (Gtk.comboBoxAppendText xaxisSelector. fst) xaxisGetters- Gtk.comboBoxSetActive xaxisSelector 0- xaxisBox <- labeledWidget "x axis:" xaxisSelector+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 - let updateXAxis = do- k <- Gtk.comboBoxGetActive xaxisSelector- _ <- case k of- 0 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXAxis = XAxisStaticCounter}- 1 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXAxis = XAxisCounter}- 2 -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXAxis = XAxisTime}- _ -> CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXAxis = XAxisFun (xaxisGetters !! (k - length xaxisSelectorStrings))}+ 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 ()- updateXAxis- _ <- on xaxisSelector Gtk.changed updateXAxis + -- 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@@ -252,13 +291,33 @@ _ <- on xScalingSelector Gtk.changed updateXScaling _ <- on yScalingSelector Gtk.changed updateYScaling + -- x axis type+ xAxisTypeSelector <- Gtk.comboBoxNewText+ mapM_ (Gtk.comboBoxAppendText xAxisTypeSelector)+ ["counter","shifted counter","time","shifted 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 = XAxisCounter}+ 1 -> CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXAxisType = XAxisShiftedCounter}+ 2 -> CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXAxisType = XAxisTime}+ 3 -> CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXAxisType = XAxisShiftedTime}+ _ -> 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 := plotLengthBox- , Gtk.boxChildPacking plotLengthBox := Gtk.PackNatural- , Gtk.containerChild := xaxisBox- , Gtk.boxChildPacking xaxisBox := Gtk.PackNatural++ Gtk.set vbox [ Gtk.containerChild := xAxisTypeSelectorBox+ , Gtk.boxChildPacking xAxisTypeSelectorBox := Gtk.PackNatural , Gtk.containerChild := xScalingBox , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural , Gtk.containerChild := xRangeBox@@ -268,60 +327,19 @@ , Gtk.containerChild := yRangeBox , Gtk.boxChildPacking yRangeBox := Gtk.PackNatural ]- + return vbox -newTreeViewArea :: Tree.Tree (String, String, Maybe (a -> PbPrim))- -> CC.MVar (GraphInfo a) -> IO Gtk.ScrolledWindow-newTreeViewArea changetters graphInfoMVar = do- let mkTreeNode (name,fullName,maybeget) = ListViewInfo name fullName maybeget False- model <- Gtk.treeStoreNew [fmap mkTreeNode changetters]- treeview <- Gtk.treeViewNewWithModel model - Gtk.treeViewSetHeadersVisible treeview True-- -- add some columns- col1 <- Gtk.treeViewColumnNew- col2 <- Gtk.treeViewColumnNew-- Gtk.treeViewColumnSetTitle col1 "name"- Gtk.treeViewColumnSetTitle col2 "visible?"-- renderer1 <- Gtk.cellRendererTextNew- renderer2 <- Gtk.cellRendererToggleNew-- Gtk.cellLayoutPackStart col1 renderer1 True- Gtk.cellLayoutPackStart col2 renderer2 True-- Gtk.cellLayoutSetAttributes col1 renderer1 model $ \lvi -> [ Gtk.cellText := lviName lvi]- Gtk.cellLayoutSetAttributes col2 renderer2 model $ \lvi -> [ Gtk.cellToggleActive := lviMarked lvi]-- _ <- Gtk.treeViewAppendColumn treeview col1- _ <- Gtk.treeViewAppendColumn treeview col2-- - let -- update the graph information- updateGraphInfo = do- lvis <- Gtk.treeStoreGetTree model [0]- let newGetters = [(lviFullName lvi, fromJust $ lviGetter lvi) | lvi <- Tree.flatten lvis, 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- -- toggle the check mark- let treePath = Gtk.stringToTreePath pathStr- g lvi@(ListViewInfo _ _ Nothing _) = putStrLn "yeah, that's not gonna work" >> return lvi- g lvi = return $ lvi {lviMarked = not (lviMarked lvi)}- ret <- Gtk.treeStoreChangeM model treePath g- unless ret $ putStrLn "treeStoreChange fail"- updateGraphInfo-- scroll <- Gtk.scrolledWindowNew Nothing Nothing- Gtk.containerAdd scroll treeview- Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever- , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic- ]- return scroll+-- 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 view
@@ -1,141 +1,127 @@ {-# OPTIONS_GHC -Wall #-} -module PlotChart ( AxisScaling(..), GraphInfo(..), newChartCanvas, updateCanvas ) where+-- | One signals are selected and whatnot, this module just dumbly plots whatever+-- is in the GraphInfo data -import qualified Control.Concurrent as CC-import Data.Accessor-import qualified Data.Foldable as F-import Data.Maybe ( mapMaybe )-import Data.Sequence ( Seq, ViewR(..) )+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 Graphics.UI.Gtk as Gtk import qualified Graphics.Rendering.Chart as Chart--import PlotTypes ( XAxisType(..), PbPrim(..) )--data AxisScaling = LogScaling- | LinearScaling+import qualified Graphics.Rendering.Chart.Gtk as ChartGtk --- what the graph should draw-data GraphInfo a = GraphInfo { giData :: CC.MVar (S.Seq (a,Int,NominalDiffTime))- , giLen :: Int- , giXAxis :: XAxisType a- , giXScaling :: AxisScaling- , giYScaling :: AxisScaling- , giXRange :: Maybe (Double,Double)- , giYRange :: Maybe (Double,Double)- , giGetters :: [(String, a -> PbPrim)]- }+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 (do- Gtk.widgetQueueDraw chartCanvas- return True)- Gtk.priorityDefaultIdle animationWaitTime+ _ <- Gtk.timeoutAddFull+ (Gtk.widgetQueueDraw chartCanvas >> return True)+ Gtk.priorityDefaultIdle animationWaitTime return chartCanvas -pbpToFrac :: Fractional a => PbPrim -> Maybe a-pbpToFrac (PbDouble c)- | isNaN c = Nothing- | otherwise = Just $ realToFrac c-pbpToFrac (PbFloat c)- | isNaN c = Nothing- | otherwise = Just $ realToFrac c-pbpToFrac (PbInt32 c) = Just $ realToFrac c-pbpToFrac (PbInt64 c) = Just $ realToFrac c-pbpToFrac (PbWord32 c) = Just $ realToFrac c-pbpToFrac (PbWord64 c) = Just $ realToFrac c-pbpToFrac (PbBool c) = Just $ (\x -> if x then 1 else 0) c-pbpToFrac (PbUtf8 _) = Nothing-pbpToFrac (PbByteString _) = Nothing-pbpToFrac (PbSeq _) = Nothing-pbpToFrac (PbMaybe x) = x >>= pbpToFrac-pbpToFrac (PbEnum (k,_)) = Just $ realToFrac k---- convert Seq PbPrim to Seq (Maybe Double)-getSeq :: Seq PbPrim -> Seq (Maybe Double)-getSeq xs = case S.viewr xs of- -- if it's empty do nothing- EmptyR -> S.empty- -- otherwise examine the first element- -- if the first element is a sequence, we'll plot the embedded sequence, not the history- _ :> PbSeq xs' -> getSeq xs'- -- if it's a primitive, map pbpToFrac over the list- _ -> fmap pbpToFrac xs---updateCanvas :: Gtk.WidgetClass widget => CC.MVar (GraphInfo a) -> widget -> IO Bool+updateCanvas :: CC.MVar (GraphInfo a) -> Gtk.DrawingArea -> IO Bool updateCanvas graphInfoMVar canvas = do gi <- CC.readMVar graphInfoMVar- datalog <- CC.readMVar (giData gi)- let -- drop values that are in history but are not to be plotted- shortLog = S.drop (S.length datalog - giLen gi) datalog- f (name,getter) = (name,fmap (\(x,_,_) -> (getter x)) shortLog :: Seq PbPrim)+ datalogSeq <- CC.readMVar (giData gi)+ let datalogList = F.toList datalogSeq+ nameWithPoints :: [(String, [[(Double,Double)]])]+ nameWithPoints = map f (giGetters gi) - -- convert to list of (name,Seq PbPrim)- namePcs' :: [(String, Seq PbPrim)]- namePcs' = map f (giGetters gi)+ (k0,t0) = case datalogList of+ [] -> (0,0)+ ((_,k0',t0'):_) -> (k0',t0') - -- convert Seq PbPrim to [Maybe Double]- namePcs = map (\(name,xs) -> (name, getSeq xs)) namePcs'+ xAxisType = giXAxisType gi - xaxisVals :: [Maybe Double]- (xaxisName, xaxisVals) = case giXAxis gi of- XAxisCounter ->- ("count", map (\(_,k,_) -> Just (fromIntegral k)) (F.toList shortLog))- XAxisStaticCounter -> ("static count", map Just [0..])- XAxisTime ->- ("msg receive timestamp [s]", map (\(_,_,t) -> Just (realToFrac t)) (F.toList shortLog))- XAxisFun (name,getx) ->- (name, F.toList $ getSeq $ fmap (\(x,_,_) -> getx x) shortLog)- (width, height) <- Gtk.widgetGetSize canvas- let sz = (fromIntegral width,fromIntegral height)- win <- Gtk.widgetGetDrawWindow canvas- let myGraph = displayChart (giXScaling gi, giYScaling gi) (giXRange gi, giYRange gi)- xaxisName xaxisVals namePcs- _ <- Gtk.renderWithDrawable win $ Chart.runCRender (Chart.render myGraph sz) Chart.vectorEnv- return True+ 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+ ChartGtk.updateCanvas myGraph canvas+ displayChart :: (Chart.PlotValue a, Show a, RealFloat a) =>- (AxisScaling, AxisScaling) -> (Maybe (a,a),Maybe (a,a)) -> String ->- [Maybe a] -> [(String, Seq (Maybe a))] -> Chart.Renderable ()-displayChart (xScaling,yScaling) (xRange,yRange) xaxisName xaxis namePcs = Chart.toRenderable layout+ 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- f (Just x, Just y) = Just (x,y)- f _ = Nothing drawOne (name,pc) col- = Chart.plot_lines_values ^= [mapMaybe f $ zip xaxis (F.toList pc)]- $ Chart.plot_lines_style .> Chart.line_color ^= col--- $ Chart.plot_points_style ^= Chart.filledCircles 2 red- $ Chart.plot_lines_title ^= name- $ Chart.defaultPlotLines+ = 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.layout1_bottom_axis .> Chart.laxis_generate ^= Chart.autoScaledLogAxis Chart.defaultLogAxis+ LogScaling -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def LinearScaling -> case xRange of Nothing -> id- Just range -> Chart.layout1_bottom_axis .> Chart.laxis_generate ^= Chart.scaledAxis Chart.defaultLinearAxis range+ Just range -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.scaledAxis def range yscaleFun = case yScaling of- LogScaling -> Chart.layout1_left_axis .> Chart.laxis_generate ^= Chart.autoScaledLogAxis Chart.defaultLogAxis+ LogScaling -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def LinearScaling -> case yRange of Nothing -> id- Just range -> Chart.layout1_left_axis .> Chart.laxis_generate ^= Chart.scaledAxis Chart.defaultLinearAxis range+ Just range -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.scaledAxis def range - layout = Chart.layout1_plots ^= map (Left . Chart.toPlot) allLines--- $ Chart.layout1_title ^= "Wooo, Party Graph!"- $ Chart.layout1_bottom_axis .> Chart.laxis_title ^= xaxisName+ 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- Chart.defaultLayout1+ def
+ src/PlotHo.hs view
@@ -0,0 +1,332 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-}+{-# Language DeriveFunctor #-}++module PlotHo+ ( Lookup(..)+ , SignalTree+ , AccessorTree(..)+ , addChannel+ , makeSignalTree+ , runPlotter+ ) where++import Data.Monoid+import Data.Time ( NominalDiffTime )+import qualified Data.Sequence as S+import qualified Control.Concurrent as CC+import qualified Control.Concurrent.STM as STM+import Data.Time ( getCurrentTime, diffUTCTime )+import Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified Graphics.UI.Gtk as Gtk+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 Control.Applicative ( Applicative(..), liftA2 )++import qualified GHC.Stats++import PlotTypes --( Channel(..), SignalTree )+import Accessors+import GraphWidget ( newGraph )+import ReadMaybe ( readMaybe )++newtype Plotter a = Plotter { unPlotter :: IO (a, [ChannelStuff]) } deriving Functor++instance Applicative Plotter where+ pure x = Plotter $ pure (x, [])+ f <*> v = Plotter $ liftA2 k (unPlotter f) (unPlotter v)+ where k ~(a, w) ~(b, w') = (a b, w `mappend` w')++instance Monad Plotter where+ return a = Plotter $ return (a, [])+ m >>= k = Plotter $ do+ ~(a, w) <- unPlotter m+ ~(b, w') <- unPlotter (k a)+ return (b, w `mappend` w')+ fail msg = Plotter $ fail msg++liftIO :: IO a -> Plotter a+liftIO m = Plotter $ do+ a <- m+ return (a, mempty)++tell :: ChannelStuff -> Plotter ()+tell w = Plotter (return ((), [w]))++execPlotter :: Plotter a -> IO [ChannelStuff]+execPlotter m = do+ ~(_, w) <- unPlotter m+ return w++data ChannelStuff =+ 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+ (ATGetter _) -> error "makeSignalTree: got an accessor right away"+ d -> Tree.subForest $ head $ makeSignalTree' "" "" d+ where+ makeSignalTree' :: String -> String -> AccessorTree a -> SignalTree a+ makeSignalTree' myName parentName (Data (pn,_) children) =+ [Tree.Node+ (myName, parentName, Nothing)+ (concatMap (\(getterName,child) -> makeSignalTree' getterName pn child) children)+ ]+ makeSignalTree' myName parentName (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+++ 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++ -- 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++ -- grab the timestamp+ time <- getCurrentTime++ -- 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 ()++ -- loop forever+ serverLoop (k+1)++ let updateMaxHist k = CC.modifyMVar_ maxHistMv (const (return k))++ rebuildSignalTree signalTree0+ serverTid <- CC.forkIO (serverLoop 0)+ let writeToThread = STM.atomically . STM.writeTQueue trajChan+++ p <- CC.forkIO (action writeToThread (Gtk.postGUISync . rebuildSignalTree))++ return $+ ChannelStuff+ { csKillThreads = mapM_ CC.killThread [serverTid,p]+ , csMkChanEntry = newChannelWidget trajMv signalTreeStore updateMaxHist name+ , csClearChan = CC.modifyMVar_ trajMv (const (return S.empty))+ }+++runPlotter :: Plotter () -> IO ()+runPlotter plotterMonad = do+ statsEnabled <- GHC.Stats.getGCStatsEnabled++ _ <- Gtk.initGUI++ -- start the main window+ win <- Gtk.windowNew+ _ <- Gtk.set win [ Gtk.containerBorderWidth := 8+ , 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+ let statsWorker = do+ CC.threadDelay 500000+ msg <- if statsEnabled+ then do+ stats <- GHC.Stats.getGCStats+ return $ printf "The current memory usage is %.2f MB"+ ((realToFrac (GHC.Stats.currentBytesUsed stats) :: Double) /(1024*1024))+ else return "(enable GHC statistics with +RTS -T)"+ Gtk.postGUISync $ Gtk.labelSetText statsLabel ("Welcome to Plot-ho-matic!\n" ++ msg)+ statsWorker++ statsThread <- CC.forkIO statsWorker++ let killEverything = do+ CC.killThread statsThread+ gws <- CC.readMVar graphWindowsToBeKilled+ mapM_ Gtk.widgetDestroy gws+ mapM_ csKillThreads channels+ Gtk.mainQuit+ _ <- Gtk.onDestroy win killEverything++ --------------- main widget -----------------+ -- button to clear history+ buttonClear <- Gtk.buttonNewWithLabel "clear history"+ _ <- Gtk.onClicked buttonClear $ do+ mapM_ csClearChan channels++++ -- vbox to hold buttons+ 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.boxChildPacking x := Gtk.PackNatural+ ]) chanWidgets++ -- add widget to window and show+ _ <- Gtk.set win [ Gtk.containerChild := vbox ]+ 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+ vbox <- Gtk.vBoxNew False 4++ nameBox' <- Gtk.hBoxNew False 4+ nameBox <- labeledWidget name 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))+ return ()++ -- button to make a new graph+ buttonNew <- Gtk.buttonNewWithLabel "new graph"+ _ <- Gtk.onClicked buttonNew $ do+ graphWin <- newGraph name signalTreeStore logData++ -- 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:"+ entryEntry <- Gtk.entryNew+ Gtk.set entryEntry [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ 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 ++ "\""+ _ <- on entryEntry Gtk.entryActivate updateMaxHistory+ updateMaxHistory+++ Gtk.set entryAndLabel [ Gtk.containerChild := entryLabel+ , Gtk.boxChildPacking entryLabel := Gtk.PackNatural+ , Gtk.containerChild := entryEntry+ , Gtk.boxChildPacking entryEntry := Gtk.PackNatural+ ]+++ -- 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 := entryAndLabel+ , Gtk.boxChildPacking entryAndLabel := Gtk.PackNatural+ ]++ Gtk.set vbox [ Gtk.containerChild := nameBox+ , Gtk.boxChildPacking nameBox := Gtk.PackNatural+ , Gtk.containerChild := buttonsBox+ , Gtk.boxChildPacking buttonsBox := Gtk.PackNatural+ ]++ return vbox+++---- -- save all channel data when this button is pressed+---- _ <- on renderer3 Gtk.cellToggled $ \pathStr -> do+---- let (i:_) = Gtk.stringToTreePath pathStr+---- lv <- Gtk.listStoreGetValue model i+---- let writerThread = do+---- bct <- chanGetByteStrings (lvChan lv)+---- let filename = chanName (lvChan lv) ++ "_log.dat"+---- blah _ sizes [] = return (reverse sizes)+---- blah handle sizes ((x,_,_):xs) = do+---- BSL.hPut handle x+---- blah handle (BSL.length x : sizes) xs+---- putStrLn $ "trying to write file \"" ++ filename ++ "\"..."+---- sizes <- withFile filename WriteMode $ \handle -> blah handle [] bct+---- putStrLn $ "finished writing file, wrote " ++ show (length sizes) ++ " protos"+----+---- putStrLn "writing file with sizes..."+---- writeFile (filename ++ ".sizes") (unlines $ map show sizes)+---- putStrLn "done"+---- _ <- CC.forkIO writerThread+-- return ()+--+-- return treeview
src/PlotTypes.hs view
@@ -1,82 +1,24 @@ {-# OPTIONS_GHC -Wall #-}-{-# Language ExistentialQuantification #-}-{-# Language GADTs #-}+--{-# Language ExistentialQuantification #-}+--{-# Language GADTs #-} -module PlotTypes ( Channel(..)- , PbPrim(..)- , PbTree(..)- , PbTree'(..)- , XAxisType(..)- , pbTreeToTree- ) where+module PlotTypes+ ( ListViewInfo(..)+ , SignalTree+ , Getter+ ) where -import Control.Concurrent ( MVar, ThreadId )-import qualified Data.ByteString.Lazy as BSL-import Data.Sequence ( Seq ) import Data.Time ( NominalDiffTime )-import Data.Tree ( Tree(..) )-import qualified Text.ProtocolBuffers.Header as P'-import Data.Functor.Compose-import Data.Functor.Identity--data XAxisType a = XAxisTime- | XAxisCounter- | XAxisStaticCounter- | XAxisFun (String, a -> PbPrim)--data Channel = forall a. Channel { chanName :: String- , chanGetters :: Tree (String, String, Maybe (a -> PbPrim))- , chanSeq :: MVar (Seq (a,Int,NominalDiffTime))- , chanMaxHist :: MVar Int- , chanServerThreadId :: ThreadId- , chanGetByteStrings :: IO [(BSL.ByteString, Int, NominalDiffTime)]- }--data PbTree a where- PbtGetter :: (a -> PbPrim) -> PbTree a- PbtStruct :: [(String,PbTree a)] -> PbTree a- PbtFunctor :: Functor g => (g PbPrim -> PbPrim) -> (a -> g b) -> PbTree b -> (String -> String) -> PbTree a--data PbTree' a = PbtGetter' (a -> PbPrim)- | PbtStruct' [(String,PbTree' a)]- | PbtFunctor' (PbTree' a) (String -> String)--pbTreeToTree :: String -> PbTree a -> Tree (String, String, Maybe (a -> PbPrim))-pbTreeToTree name tree = pbTreeToTree' "" name (please tree)--cat :: String -> String -> String-cat [] y = y-cat x y = x ++ "." ++ y--pbTreeToTree' :: String -> String -> PbTree' a -> Tree (String, String, Maybe (a -> PbPrim))-pbTreeToTree' prefix name (PbtGetter' get) = Node (name, cat prefix name, Just get) []-pbTreeToTree' prefix name (PbtStruct' stuff) =- Node (name, cat prefix name, Nothing) (map (uncurry (pbTreeToTree' (cat prefix name))) stuff)-pbTreeToTree' prefix name (PbtFunctor' tree s2s) = pbTreeToTree' prefix (s2s name) tree+import qualified Data.Sequence as S+import qualified Data.Tree as Tree -please :: PbTree a -> PbTree' a-please = f Identity runIdentity+type Getter a = Either (a -> Double) (S.Seq (a, Int, NominalDiffTime) -> [[(Double,Double)]]) -f :: Functor f => (a -> f b) -> (f PbPrim -> PbPrim) -> PbTree b -> PbTree' a-f afb unfunct (PbtGetter get) = PbtGetter' $ \a -> unfunct $ fmap get (afb a)-f afb unfunct (PbtStruct stuff) = PbtStruct' $ zip names (map (f afb unfunct) trees)- where- (names,trees) = unzip stuff-f afb unfunct (PbtFunctor unfunct' h theRest s2s) = PbtFunctor' (f wow blah theRest) s2s- where- wow a = Compose (fmap h (afb a))- blah fga = unfunct $ fmap unfunct' (getCompose fga)+-- | a tree of name/getter pairs+type SignalTree a = Tree.Forest (String, String, Maybe (Getter a)) -data PbPrim = PbDouble Double- | PbFloat Float- | PbInt32 P'.Int32- | PbInt64 P'.Int64- | PbWord32 P'.Word32- | PbWord64 P'.Word64- | PbBool Bool- | PbUtf8 P'.Utf8--- | PbByteString P'.ByteString- | PbByteString BSL.ByteString- | PbSeq (Seq PbPrim)- | PbMaybe (Maybe PbPrim)- | PbEnum (Int,String)+data ListViewInfo a = ListViewInfo { lviName :: String+ , lviType :: String+ , lviGetter :: Maybe (Getter a)+ , lviMarked :: Bool+ }
− src/Plotter.hs
@@ -1,199 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Plotter ( newChannel, runPlotter, makeAccessors, Channel ) where--import Control.Monad ( void )-import qualified Control.Concurrent as CC-import qualified Data.Foldable as F-import Data.Sequence ( (|>) )-import qualified Data.Sequence as S-import Data.Time ( getCurrentTime, diffUTCTime )-import Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified Graphics.UI.Gtk as Gtk-import System.Glib.Signals ( on )-import System.IO ( withFile, IOMode ( WriteMode ) )-import qualified Text.ProtocolBuffers as PB-import qualified Data.ByteString.Lazy as BSL--import Accessors ( makeAccessors )-import PlotTypes ( Channel(..), PbTree, pbTreeToTree )-import GraphWidget ( newGraph )-import ReadMaybe ( readMaybe )--data ListView = ListView { lvChan :: Channel- , lvMaxHist :: Int- }--newChannel :: (PB.ReflectDescriptor a, PB.Wire a) => String -> PbTree a -> IO (Channel, a -> IO ())-newChannel name pbTree = do- time0 <- getCurrentTime- - seqChan <- CC.newChan- seqMv <- CC.newMVar S.empty- maxHistMv <- CC.newMVar (10000 :: Int)-- let serverLoop k = do- -- wait until a new message is written to the Chan- newMsg <- CC.readChan seqChan- -- grab the timestamp- time <- getCurrentTime- -- append this to the Seq in the MVar, dropping the excess old messages- maxNum <- CC.readMVar maxHistMv- let f seq0 = return $ S.drop (S.length seq0 + 1 - maxNum) (seq0 |> (newMsg, k, diffUTCTime time time0))- CC.modifyMVar_ seqMv f- -- loop forever- serverLoop (k+1)- - serverTid <- CC.forkIO $ serverLoop 0- let retChan = Channel { chanName = name- , chanGetters = pbTreeToTree name pbTree- , chanSeq = seqMv- , chanMaxHist = maxHistMv- , chanServerThreadId = serverTid- , chanGetByteStrings = cgb- }- cgb = do- s <- CC.readMVar seqMv- return $ map (\(x,y,z) -> (PB.messagePut x,y,z)) $ F.toList s-- return (retChan, CC.writeChan seqChan)--runPlotter :: [Channel] -> [CC.ThreadId] -> IO ()-runPlotter channels backgroundThreadsToKill = do- _ <- Gtk.initGUI-- -- start the main window- win <- Gtk.windowNew- _ <- Gtk.set win [ Gtk.containerBorderWidth := 8- , Gtk.windowTitle := "Plot-ho-matic"- ]-- -- on close, kill all the windows and threads- graphWindowsToBeKilled <- CC.newMVar []- let killEverything = do- gws <- CC.readMVar graphWindowsToBeKilled- mapM_ Gtk.widgetDestroy gws- mapM_ CC.killThread backgroundThreadsToKill- mapM_ (CC.killThread . chanServerThreadId) channels- Gtk.mainQuit- _ <- Gtk.onDestroy win killEverything-- --------------- main widget ------------------ -- button to clear history- buttonClear <- Gtk.buttonNewWithLabel "clear history"- _ <- Gtk.onClicked buttonClear $ do- let clearChan (Channel {chanSeq=cs}) = void (CC.swapMVar cs S.empty)- mapM_ clearChan channels-- -- list of channels- chanWidget <- newChannelWidget channels graphWindowsToBeKilled-- -- vbox to hold buttons- vbox <- Gtk.vBoxNew False 4- Gtk.set vbox [ Gtk.containerChild := buttonClear- , Gtk.containerChild := chanWidget- ]-- -- add widget to window and show- _ <- Gtk.set win [ Gtk.containerChild := vbox ]- Gtk.widgetShowAll win- Gtk.mainGUI----- the list of channels-newChannelWidget :: [Channel] -> CC.MVar [Gtk.Window] -> IO Gtk.TreeView-newChannelWidget channels graphWindowsToBeKilled = do- -- create a new tree model- let toListView ch = do- k <- CC.readMVar $ chanMaxHist ch- return ListView { lvChan = ch, lvMaxHist = k }- model <- mapM toListView channels >>= Gtk.listStoreNew- treeview <- Gtk.treeViewNewWithModel model- Gtk.treeViewSetHeadersVisible treeview True-- -- add some columns- col0 <- Gtk.treeViewColumnNew- col1 <- Gtk.treeViewColumnNew- col2 <- Gtk.treeViewColumnNew- col3 <- Gtk.treeViewColumnNew-- Gtk.treeViewColumnSetTitle col0 "channel"- Gtk.treeViewColumnSetTitle col1 "history"- Gtk.treeViewColumnSetTitle col2 "new"- Gtk.treeViewColumnSetTitle col3 "save"-- renderer0 <- Gtk.cellRendererTextNew- renderer1 <- Gtk.cellRendererTextNew- renderer2 <- Gtk.cellRendererToggleNew- renderer3 <- Gtk.cellRendererToggleNew-- Gtk.cellLayoutPackStart col0 renderer0 True- Gtk.cellLayoutPackStart col1 renderer1 True- Gtk.cellLayoutPackStart col2 renderer2 True- Gtk.cellLayoutPackStart col3 renderer3 True-- Gtk.cellLayoutSetAttributes col0 renderer0 model $ \lv -> [ Gtk.cellText := chanName (lvChan lv)]- Gtk.cellLayoutSetAttributes col1 renderer1 model $ \lv -> [ Gtk.cellText := show (lvMaxHist lv)- , Gtk.cellTextEditable := True- ]- Gtk.cellLayoutSetAttributes col2 renderer2 model $ const [ Gtk.cellToggleActive := False]- Gtk.cellLayoutSetAttributes col3 renderer3 model $ const [ Gtk.cellToggleActive := False]-- - _ <- Gtk.treeViewAppendColumn treeview col0- _ <- Gtk.treeViewAppendColumn treeview col1- _ <- Gtk.treeViewAppendColumn treeview col2- _ <- Gtk.treeViewAppendColumn treeview col3-- -- spawn a new graph when a checkbox is clicked- _ <- on renderer2 Gtk.cellToggled $ \pathStr -> do- let (i:_) = Gtk.stringToTreePath pathStr- lv <- Gtk.listStoreGetValue model i- graphWin <- newGraph (lvChan lv)- - -- add this window to the list to be killed on exit- CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:))--- -- save all channel data when this button is pressed- _ <- on renderer3 Gtk.cellToggled $ \pathStr -> do- let (i:_) = Gtk.stringToTreePath pathStr- lv <- Gtk.listStoreGetValue model i- let writerThread = do- bct <- chanGetByteStrings (lvChan lv)- let filename = chanName (lvChan lv) ++ "_log.dat"- blah _ sizes [] = return (reverse sizes)- blah handle sizes ((x,_,_):xs) = do- BSL.hPut handle x- blah handle (BSL.length x : sizes) xs- putStrLn $ "trying to write file \"" ++ filename ++ "\"..."- sizes <- withFile filename WriteMode $ \handle -> blah handle [] bct- putStrLn $ "finished writing file, wrote " ++ show (length sizes) ++ " protos"-- putStrLn "writing file with sizes..."- writeFile (filename ++ ".sizes") (unlines $ map show sizes)- putStrLn "done"- _ <- CC.forkIO writerThread- return ()--- -- how long to make the history- _ <- on renderer1 Gtk.edited $ \treePath txt -> do- let (i:_) = treePath- lv <- Gtk.listStoreGetValue model i- case readMaybe txt of- Nothing -> do- putStrLn $ "invalid non-integer range entry: " ++ txt- k0 <- CC.readMVar $ chanMaxHist (lvChan lv)- Gtk.listStoreSetValue model i (lv {lvMaxHist = k0})- Just k -> if k < 0- then do- putStrLn $ "invalid negative range entry: " ++ txt- k0 <- CC.readMVar $ chanMaxHist (lvChan lv)- Gtk.listStoreSetValue model i (lv {lvMaxHist = k0})- else do- _ <- CC.swapMVar (chanMaxHist (lvChan lv)) k- Gtk.listStoreSetValue model i (lv {lvMaxHist = k})- return ()-- return treeview
src/ReadMaybe.hs view
@@ -1,7 +1,10 @@ {-# OPTIONS_GHC -Wall #-} -module ReadMaybe ( readMaybe ) where+module ReadMaybe+ ( readMaybe+ ) where +-- | GHC 7.4 compatability readMaybe :: Read a => String -> Maybe a readMaybe s = case reads s of [(x, "")] -> Just x