{-# 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