Plot-ho-matic (empty) → 0.1.0.0
raw patch · 13 files changed
+964/−0 lines, 13 filesdep +Chartdep +basedep +bytestringsetup-changed
Dependencies added: Chart, base, bytestring, containers, data-accessor, glib, gtk, protocol-buffers, template-haskell, time, transformers
Files
- .gitignore +1/−0
- .travis.yml +3/−0
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- Plot-ho-matic.cabal +46/−0
- README.md +6/−0
- Setup.hs +2/−0
- src/Accessors.hs +116/−0
- src/GraphWidget.hs +327/−0
- src/PlotChart.hs +141/−0
- src/PlotTypes.hs +82/−0
- src/Plotter.hs +199/−0
- src/ReadMaybe.hs +8/−0
+ .gitignore view
@@ -0,0 +1,1 @@+dist
+ .travis.yml view
@@ -0,0 +1,3 @@+language: haskell+before_install:+ - travis/cabal-apt-install
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.1+---+* Initial release (moved from rawesome repo)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Greg Horn++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Greg Horn nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Plot-ho-matic.cabal view
@@ -0,0 +1,46 @@+name: Plot-ho-matic+version: 0.1.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+category: Graphics+build-type: Simple+cabal-version: >=1.8+extra-source-files:+ .gitignore+ .travis.yml+ CHANGELOG.md+ 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,+ PlotChart,+ PlotTypes,+ ReadMaybe+ build-depends: base >= 4.5.0 && < 4.7,+ protocol-buffers,+ template-haskell,+ containers,+ glib,+ gtk,+ Chart,+ time,+ data-accessor,+ bytestring,+ transformers++ ghc-options: -O2 -Wall+ ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts+ other-extensions: TemplateHaskell
+ README.md view
@@ -0,0 +1,6 @@+Plot-ho-matic+==++[](https://travis-ci.org/ghorn/Plot-ho-matic)++todo: a readme, for one
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Accessors.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language TemplateHaskell #-}+{-# Language ExistentialQuantification #-}++module Accessors ( makeAccessors ) 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 PlotTypes ( PbTree(..), PbPrim(..) )++data AccessorTree = APrim ExpQ+ | AStruct [(Name,AccessorTree)]+ | ASeq AccessorTree+ | AMaybe AccessorTree++atToPbt :: ExpQ -> AccessorTree -> ExpQ+atToPbt getDouble (APrim pbCon) = [| PbtGetter ($pbCon . $getDouble) |]+atToPbt getStruct (AStruct forest) = [| PbtStruct (zip strNames $forestQ) |]+ 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++")")|]+++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+++-- | 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)++ -- empty protobuf+ [NormalC _ []] -> return (AStruct [])++ -- 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+++-- | 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"+++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++ outputs' <- handleConstructor constructor+ atToPbt [| id |] outputs'
+ src/GraphWidget.hs view
@@ -0,0 +1,327 @@+{-# OPTIONS_GHC -Wall #-}++module GraphWidget ( newGraph ) where++import qualified Control.Concurrent as CC+import Control.Monad ( unless )+import Data.Maybe ( mapMaybe, 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 PlotTypes ( Channel(..), XAxisType(..), PbPrim )+import PlotChart ( GraphInfo(..), AxisScaling(..), newChartCanvas )+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+ win <- Gtk.windowNew++ _ <- Gtk.set win [ Gtk.containerBorderWidth := 8+ , Gtk.windowTitle := chanName chan+ ]++ -- 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+ , giGetters = []+ }+ + -- the thing where users select stuff+ options' <- makeOptionsWidget graphInfoMVar changetters+ options <- Gtk.expanderNew "options"+ Gtk.set options [ Gtk.containerChild := options'+ , Gtk.expanderExpanded := True+ ]+ + + -- create a new tree model+ treeview' <- newTreeViewArea changetters graphInfoMVar+ 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+ ]+ + -- 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 ]++ 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++ 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))}+ return ()+ updateXAxis+ _ <- on xaxisSelector Gtk.changed updateXAxis+++ -- 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)+ ["linear (auto)","linear (manual)","logarithmic (auto)"]+ mapM_ (Gtk.comboBoxAppendText yScalingSelector)+ ["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++ -- 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.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+++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
+ src/PlotChart.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -Wall #-}++module PlotChart ( AxisScaling(..), GraphInfo(..), newChartCanvas, updateCanvas ) where++import qualified Control.Concurrent as CC+import Data.Accessor+import qualified Data.Foldable as F+import Data.Maybe ( mapMaybe )+import Data.Sequence ( Seq, ViewR(..) )+import qualified Data.Sequence as S+import Data.Time ( NominalDiffTime )+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.Rendering.Chart as Chart++import PlotTypes ( XAxisType(..), PbPrim(..) )++data AxisScaling = LogScaling+ | LinearScaling++-- 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)]+ }++-- milliseconds for draw time+animationWaitTime :: Int+animationWaitTime = 33++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+ 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 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)++ -- convert to list of (name,Seq PbPrim)+ namePcs' :: [(String, Seq PbPrim)]+ namePcs' = map f (giGetters gi)++ -- convert Seq PbPrim to [Maybe Double]+ namePcs = map (\(name,xs) -> (name, getSeq xs)) namePcs'++ 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++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+ 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+ allLines = zipWith drawOne namePcs Chart.defaultColorSeq++ xscaleFun = case xScaling of+ LogScaling -> Chart.layout1_bottom_axis .> Chart.laxis_generate ^= Chart.autoScaledLogAxis Chart.defaultLogAxis+ LinearScaling -> case xRange of+ Nothing -> id+ Just range -> Chart.layout1_bottom_axis .> Chart.laxis_generate ^= Chart.scaledAxis Chart.defaultLinearAxis range++ yscaleFun = case yScaling of+ LogScaling -> Chart.layout1_left_axis .> Chart.laxis_generate ^= Chart.autoScaledLogAxis Chart.defaultLogAxis+ LinearScaling -> case yRange of+ Nothing -> id+ Just range -> Chart.layout1_left_axis .> Chart.laxis_generate ^= Chart.scaledAxis Chart.defaultLinearAxis range++ layout = Chart.layout1_plots ^= map (Left . Chart.toPlot) allLines+-- $ Chart.layout1_title ^= "Wooo, Party Graph!"+ $ Chart.layout1_bottom_axis .> Chart.laxis_title ^= xaxisName+ $ xscaleFun+ $ yscaleFun+ Chart.defaultLayout1
+ src/PlotTypes.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ExistentialQuantification #-}+{-# Language GADTs #-}++module PlotTypes ( Channel(..)+ , PbPrim(..)+ , PbTree(..)+ , PbTree'(..)+ , XAxisType(..)+ , pbTreeToTree+ ) 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++please :: PbTree a -> PbTree' a+please = f Identity runIdentity++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)++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)
+ src/Plotter.hs view
@@ -0,0 +1,199 @@+{-# 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, CC.Chan a)+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, 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
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wall #-}++module ReadMaybe ( readMaybe ) where++readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing