{-# OPTIONS_GHC -Wall #-} {-# Language ScopedTypeVariables #-} {-# Language DeriveFunctor #-} module PlotHo ( Plotter , XAxisType(..) , Lookup , addChannel , addHistoryChannel , runPlotter ) 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 ) 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 } addHistoryChannel :: Lookup a => String -> XAxisType -> ((a -> Bool -> IO ()) -> IO ()) -> 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 } addChannel :: String -> (a -> a -> Bool) -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -> ((a -> IO ()) -> IO ()) -> 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 | XAxisCount | XAxisTime0 | XAxisCount0 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 getter)) []] 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) 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 () -- button to make a new graph buttonNew <- Gtk.buttonNewWithLabel "new graph" _ <- Gtk.onClicked buttonNew $ do graphWin <- newGraph (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