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 "gtk" Graphics.UI.Gtk ( AttrOp( (:=) ) )
import qualified "gtk" Graphics.UI.Gtk as Gtk
import System.Glib.Signals ( on )
import qualified Data.Tree as Tree
import Text.Printf ( printf )
import Control.Applicative ( Applicative(..), liftA2 )
import qualified GHC.Stats
import PlotTypes
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
size <- Gtk.listStoreGetSize signalTreeStore
if size == 0
then Gtk.listStorePrepend signalTreeStore newSignalTree
else Gtk.listStoreSetValue signalTreeStore 0 newSignalTree
let serverLoop :: Int -> IO ()
serverLoop k = do
newPoint0 <- getLastValue
time <- getCurrentTime
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 ()
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
win <- Gtk.windowNew
_ <- Gtk.set win [ Gtk.containerBorderWidth := 8
, Gtk.windowTitle := "Plot-ho-matic"
]
graphWindowsToBeKilled <- CC.newMVar []
channels <- execPlotter plotterMonad
let windows = map csMkChanEntry channels
chanWidgets <- mapM (\x -> x graphWindowsToBeKilled) windows
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
let killEverything = do
CC.killThread statsThread
gws <- CC.readMVar graphWindowsToBeKilled
mapM_ Gtk.widgetDestroy gws
mapM_ csKillThreads channels
Gtk.mainQuit
_ <- Gtk.onDestroy win killEverything
buttonClear <- Gtk.buttonNewWithLabel "clear history"
_ <- Gtk.onClicked buttonClear $ do
mapM_ csClearChan channels
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
_ <- Gtk.set win [ Gtk.containerChild := vbox ]
Gtk.widgetShowAll win
Gtk.mainGUI
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
]
return hbox
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
buttonClear <- Gtk.buttonNewWithLabel "clear history"
_ <- Gtk.onClicked buttonClear $ do
CC.modifyMVar_ logData (const (return S.empty))
return ()
buttonNew <- Gtk.buttonNewWithLabel "new graph"
_ <- Gtk.onClicked buttonNew $ do
graphWin <- newGraph name signalTreeStore logData
CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:))
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
]
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