{-# OPTIONS_GHC -Wall #-} {-# Language ScopedTypeVariables #-} {-# Language DeriveFunctor #-} module PlotHo ( Plotter , runPlotter , XAxisType(..) , addHistoryChannel , addChannel -- * re-exported for convenience , Lookup ) where import qualified GHC.Stats import Control.Applicative ( Applicative(..), liftA2 ) import Data.Monoid ( mappend, mempty ) import Control.Monad ( when ) import qualified Control.Concurrent as CC import qualified Data.Foldable as F import qualified Data.IORef as IORef import Data.Time ( NominalDiffTime, getCurrentTime, diffUTCTime ) import Data.Tree ( Tree ) import qualified Data.Tree as Tree import Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified Graphics.UI.Gtk as Gtk import Text.Printf ( printf ) import Text.Read ( readMaybe ) import System.Glib.Signals ( on ) --import System.IO ( withFile, IOMode ( WriteMode ) ) --import qualified Data.ByteString.Lazy as BSL import qualified Data.Sequence as S import Accessors import PlotHo.PlotTypes ( Channel(..) ) import PlotHo.GraphWidget ( newGraph ) -- | add channels to this, then run it with 'runPlotter' 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 } -- | Simplified time-series channel which passes a "send message" function to a worker and forks it using 'forkIO'. -- The plotter will plot a time series of messages sent by the worker. -- The worker should pass True to reset the message history, so sending True the first message and False subsequent messages is a good starting place. addHistoryChannel :: Lookup a => String -- ^ channel name -> XAxisType -- ^ what to use for the X axis -> ((a -> Bool -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO' -> Plotter () addHistoryChannel name xaxisType action = do (chan, newMessage) <- liftIO $ newHistoryChannel name xaxisType workerTid <- liftIO $ CC.forkIO (action newMessage) tell ChannelStuff { csKillThreads = CC.killThread workerTid , csMkChanEntry = newChannelWidget chan } -- | This is the general interface to plot whatever you want. -- Use this when you want to give the whole time series in one go, rather than one at a time -- such as with 'addHistoryChannel'. -- Using types or data, you must encode the signal tree with the message so that -- the plotter can build you the nice message toggle tree. addChannel :: String -- ^ channel name -> (a -> a -> Bool) -- ^ Is the signal tree the same? This is used for instance if signals have changed and the plotter needs to rebuild the signal tree. This lets you keep the plotter running and change other programs which send messages to the plotter. -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -- ^ how to build the signal tree -> ((a -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO' -> Plotter () addChannel name sameSignalTree toSignalTree action = do (chan, newMessage) <- liftIO $ newChannel name sameSignalTree toSignalTree workerTid <- liftIO $ CC.forkIO (action newMessage) tell ChannelStuff { csKillThreads = CC.killThread workerTid , csMkChanEntry = newChannelWidget chan } newChannel :: forall a . String -> (a -> a -> Bool) -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -> IO (Channel a, a -> IO ()) newChannel name sameSignalTree toSignalTree = do msgStore <- Gtk.listStoreNew [] maxHist <- IORef.newIORef 0 let newMessage :: a -> IO () newMessage next = do -- grab the time and counter Gtk.postGUIAsync $ do size <- Gtk.listStoreGetSize msgStore if size == 0 then Gtk.listStorePrepend msgStore next else Gtk.listStoreSetValue msgStore 0 next let retChan = Channel { chanName = name , chanMsgStore = msgStore , chanSameSignalTree = sameSignalTree , chanToSignalTree = toSignalTree , chanMaxHistory = maxHist } return (retChan, newMessage) data History a = History (S.Seq (a, Int, NominalDiffTime)) type SignalTree a = Tree.Forest (String, String, Maybe (History a -> [[(Double, Double)]])) data XAxisType = XAxisTime -- ^ time since the first message | XAxisTime0 -- ^ time since the first message, normalized to 0 (to reduce plot jitter) | XAxisCount -- ^ message index | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter) sameHistorySignalTree :: Lookup a => XAxisType -> a -> a -> Bool sameHistorySignalTree xaxisType x y = hx == hy where hx = map (fmap f) $ historySignalTree x xaxisType hy = map (fmap f) $ historySignalTree y xaxisType f (n1, n2, mg) = (n1, n2, fmap (const ()) mg) historySignalTree :: forall a . Lookup a => a -> XAxisType -> SignalTree a historySignalTree x axisType = case accessors x of (ATGetter _) -> error "makeSignalTree: got an accessor right away" d -> Tree.subForest $ head $ makeSignalTree' "" "" d where 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 (toHistoryGetter (toDoubleGetter getter))) []] toDoubleGetter :: Getter a -> (a -> Double) toDoubleGetter (GetDouble f) = f toDoubleGetter (GetFloat f) = realToFrac . f toDoubleGetter (GetBool f) = fromIntegral . fromEnum . f toDoubleGetter (GetInt f) = fromIntegral . f toDoubleGetter GetSorry = const 0 toHistoryGetter :: (a -> Double) -> History a -> [[(Double, Double)]] toHistoryGetter = case axisType of XAxisTime -> timeGetter XAxisTime0 -> timeGetter0 XAxisCount -> countGetter XAxisCount0 -> countGetter0 timeGetter get (History s) = [map (\(val, _, time) -> (realToFrac time, get val)) (F.toList s)] timeGetter0 get (History s) = [map (\(val, _, time) -> (realToFrac time - time0, get val)) (F.toList s)] where time0 :: Double time0 = case S.viewl s of (_, _, time0') S.:< _ -> realToFrac time0' S.EmptyL -> 0 countGetter get (History s) = [map (\(val, k, _) -> (fromIntegral k, get val)) (F.toList s)] countGetter0 get (History s) = [map (\(val, k, _) -> (fromIntegral k - k0, get val)) (F.toList s)] where k0 :: Double k0 = case S.viewl s of (_, k0', _) S.:< _ -> realToFrac k0' S.EmptyL -> 0 newHistoryChannel :: forall a . Lookup a => String -> XAxisType -> IO (Channel (History a), a -> Bool -> IO ()) newHistoryChannel name xaxisType = do time0 <- getCurrentTime >>= IORef.newIORef counter <- IORef.newIORef 0 maxHist <- IORef.newIORef 200 msgStore <- Gtk.listStoreNew [] let newMessage :: a -> Bool -> IO () newMessage next reset = do -- grab the time and counter time <- getCurrentTime when reset $ do IORef.writeIORef time0 time IORef.writeIORef counter 0 k <- IORef.readIORef counter time0' <- IORef.readIORef time0 IORef.writeIORef counter (k+1) Gtk.postGUIAsync $ do let val = (next, k, diffUTCTime time time0') size <- Gtk.listStoreGetSize msgStore if size == 0 then Gtk.listStorePrepend msgStore (History (S.singleton val)) else do History vals0 <- Gtk.listStoreGetValue msgStore 0 maxHistory <- IORef.readIORef maxHist let undropped = vals0 S.|> val dropped = S.drop (S.length undropped - maxHistory) undropped Gtk.listStoreSetValue msgStore 0 (History dropped) when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val)) let -- todo: cache this so i don't have to keep building an accessor tree to compare sst :: History a -> History a -> Bool sst (History x) (History y) = case (S.viewr x, S.viewr y) of (_ S.:> (x',_,_), _ S.:> (y',_,_)) -> sameHistorySignalTree xaxisType x' y' _ -> error "sameSignalTree got an empty history :(" tst :: History a -> [Tree ( String , String , Maybe (History a -> [[(Double, Double)]]) )] tst (History x) = case (S.viewr x) of (_ S.:> (x',_,_)) -> historySignalTree x' xaxisType S.EmptyR -> error "toSignalTree got an empty history" let retChan = Channel { chanName = name , chanMsgStore = msgStore , chanSameSignalTree = sst , chanToSignalTree = tst , chanMaxHistory = maxHist } return (retChan, newMessage) -- | fire up the the GUI runPlotter :: Plotter () -> IO () runPlotter plotterMonad = do statsEnabled <- GHC.Stats.getGCStatsEnabled _ <- Gtk.initGUI _ <- Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50 -- start the main window win <- Gtk.windowNew _ <- Gtk.set win [ Gtk.containerBorderWidth := 8 , Gtk.windowTitle := "Plot-ho-matic" ] statsLabel <- Gtk.labelNew (Nothing :: Maybe String) 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 -- on close, kill all the windows and threads graphWindowsToBeKilled <- CC.newMVar [] channels <- execPlotter plotterMonad let windows = map csMkChanEntry channels chanWidgets <- mapM (\x -> x graphWindowsToBeKilled) windows let killEverything = do CC.killThread statsThread gws <- CC.readMVar graphWindowsToBeKilled mapM_ Gtk.widgetDestroy gws mapM_ csKillThreads channels Gtk.mainQuit _ <- Gtk.onDestroy win killEverything --------------- main widget ----------------- -- button to clear history buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing" _ <- Gtk.onClicked buttonDoNothing $ putStrLn "seriously, it does nothing" -- vbox to hold buttons and list of channel vbox <- Gtk.vBoxNew False 4 Gtk.set vbox $ [ Gtk.containerChild := statsLabel , Gtk.boxChildPacking statsLabel := Gtk.PackNatural , Gtk.containerChild := buttonDoNothing ] ++ 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 -- the list of channels newChannelWidget :: Channel a -> CC.MVar [Gtk.Window] -> IO Gtk.VBox newChannelWidget channel graphWindowsToBeKilled = do vbox <- Gtk.vBoxNew False 4 nameBox' <- Gtk.hBoxNew False 4 nameBox <- labeledWidget (chanName channel) nameBox' buttonsBox <- Gtk.hBoxNew False 4 -- button to clear history buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing" -- _ <- Gtk.onClicked buttonAlsoDoNothing $ do -- putStrLn "i promise, nothing happens" -- -- CC.modifyMVar_ logData (const (return S.empty)) -- return () let triggerYo action = Gtk.onClicked buttonAlsoDoNothing action >> return () -- button to make a new graph buttonNew <- Gtk.buttonNewWithLabel "new graph" _ <- Gtk.onClicked buttonNew $ do graphWin <- newGraph triggerYo (chanName channel) (chanSameSignalTree channel) (chanToSignalTree channel) (chanMsgStore channel) -- add this window to the list to be killed on exit CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:)) -- entry to set history length entryAndLabel <- Gtk.hBoxNew False 4 entryLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "max history:" 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 let reset = Gtk.entrySetText entryEntry "(max)" case readMaybe txt :: Maybe Int of Nothing -> putStrLn ("max history: couldn't make an Int out of \"" ++ show txt ++ "\"") >> reset Just 0 -> putStrLn ("max history: must be greater than 0") >> reset Just k -> IORef.writeIORef (chanMaxHistory channel) k _ <- on entryEntry Gtk.entryActivate updateMaxHistory updateMaxHistory 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 := buttonAlsoDoNothing , Gtk.boxChildPacking buttonAlsoDoNothing := 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 -- 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