diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -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 diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -Wall #-} +{-# Language DeriveGeneric #-} + +module Main where + +import qualified Control.Concurrent as CC +import GHC.Generics ( Generic ) +--import qualified System.Remote.Monitoring as EKG + +import PlotHo ( Lookup, 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) diff --git a/src/Accessors.hs b/src/Accessors.hs --- a/src/Accessors.hs +++ b/src/Accessors.hs @@ -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 diff --git a/src/GraphWidget.hs b/src/GraphWidget.hs --- a/src/GraphWidget.hs +++ b/src/GraphWidget.hs @@ -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 diff --git a/src/PlotChart.hs b/src/PlotChart.hs --- a/src/PlotChart.hs +++ b/src/PlotChart.hs @@ -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 diff --git a/src/PlotHo.hs b/src/PlotHo.hs new file mode 100644 --- /dev/null +++ b/src/PlotHo.hs @@ -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 diff --git a/src/PlotTypes.hs b/src/PlotTypes.hs --- a/src/PlotTypes.hs +++ b/src/PlotTypes.hs @@ -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 + } diff --git a/src/Plotter.hs b/src/Plotter.hs deleted file mode 100644 --- a/src/Plotter.hs +++ /dev/null @@ -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 diff --git a/src/ReadMaybe.hs b/src/ReadMaybe.hs --- a/src/ReadMaybe.hs +++ b/src/ReadMaybe.hs @@ -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