module PlotHo
( Plotter
, runPlotter
, XAxisType(..)
, addHistoryChannel
, addChannel
, 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 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
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
| XAxisTime0
| XAxisCount
| 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
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
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
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 $ init $ unlines
[ 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
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
buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing"
_ <- Gtk.onClicked buttonDoNothing $
putStrLn "seriously, it does nothing"
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
_ <- Gtk.set win [ Gtk.containerChild := vbox ]
Gtk.widgetShowAll win
Gtk.mainGUI
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
buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing"
let triggerYo action = Gtk.onClicked buttonAlsoDoNothing action >> return ()
buttonNew <- Gtk.buttonNewWithLabel "new graph"
_ <- Gtk.onClicked buttonNew $ do
graphWin <- newGraph
triggerYo
(chanName channel)
(chanSameSignalTree channel)
(chanToSignalTree channel)
(chanMsgStore channel)
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
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
]
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
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