module PlotHo
( Plotter
, runPlotter
, XAxisType(..)
, addHistoryChannel
, Meta
, addHistoryChannel'
, addChannel
, Lookup
) where
import qualified GHC.Stats
import Control.Applicative ( Applicative(..), liftA2 )
import Control.Lens ( (^.) )
import Data.Monoid ( mappend, mempty )
import Control.Monad ( when )
import Control.Monad.IO.Class ( MonadIO(..) )
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 Data.Vector ( Vector )
import qualified Data.Vector as V
import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )
import qualified "gtk3" 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
instance MonadIO Plotter where
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
}
addHistoryChannel' ::
String
-> ((Double -> Vector Double -> Maybe Meta -> IO ()) -> IO ())
-> Plotter ()
addHistoryChannel' name action = do
(chan, newMessage) <- liftIO $ newHistoryChannel' name
workerTid <- liftIO $ CC.forkIO (action newMessage)
tell ChannelStuff { csKillThreads = CC.killThread workerTid
, csMkChanEntry = newChannelWidget chan
}
addChannel ::
String
-> (a -> a -> Bool)
-> (a -> [Tree ([String], Either String (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], Either String (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 HistorySignalTree a = Tree.Forest ([String], Either String (History a -> [[(Double, Double)]]))
data XAxisType =
XAxisTime
| XAxisTime0
| XAxisCount
| XAxisCount0
historySignalTree :: forall a . Lookup a => XAxisType -> HistorySignalTree a
historySignalTree axisType = case accessors of
Left _ -> error "historySignalTree: got a Field right away"
acc -> Tree.subForest $ head $ makeSignalTree' [] acc
where
makeSignalTree' :: [String] -> AccessorTree a -> HistorySignalTree a
makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) =
[Tree.Node
(reverse myFieldName, Left cname)
(concatMap (\(getterName, child) -> makeSignalTree' (fromMName getterName:myFieldName) child) children)
]
makeSignalTree' myFieldName (Right (GAData _ (GASum enum))) =
[Tree.Node (reverse myFieldName, Right (toHistoryGetter (fromIntegral . eToIndex enum))) []]
makeSignalTree' myFieldName (Left field) =
[Tree.Node (reverse myFieldName, Right (toHistoryGetter (toDoubleGetter field))) []]
fromMName (Just x) = x
fromMName Nothing = "()"
toDoubleGetter :: GAField a -> (a -> Double)
toDoubleGetter (FieldDouble f) = (^. f)
toDoubleGetter (FieldFloat f) = realToFrac . (^. f)
toDoubleGetter (FieldInt f) = fromIntegral . (^. f)
toDoubleGetter (FieldString _) = const 0
toDoubleGetter FieldSorry = 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
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 dropped = S.drop (1 + S.length vals0 maxHistory) (vals0 S.|> val)
Gtk.listStoreSetValue msgStore 0 (History dropped)
when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val))
let tst :: History a -> [Tree ( [String]
, Either String (History a -> [[(Double, Double)]])
)]
tst = const (historySignalTree xaxisType)
let retChan = Channel { chanName = name
, chanMsgStore = msgStore
, chanSameSignalTree = \_ _ -> True
, chanToSignalTree = tst
, chanMaxHistory = maxHist
}
return (retChan, newMessage)
type Meta = [Tree ([String], Either String Int)]
data History' = History' Bool (S.Seq (Double, Vector Double)) Meta
newHistoryChannel' ::
String -> IO (Channel History', Double -> Vector Double -> Maybe Meta -> IO ())
newHistoryChannel' name = do
maxHist <- IORef.newIORef 200
msgStore <- Gtk.listStoreNew []
let newMessage :: Double -> Vector Double -> Maybe Meta -> IO ()
newMessage nextTime nextVal maybeMeta = do
Gtk.postGUIAsync $ do
let val = (nextTime, nextVal)
size <- Gtk.listStoreGetSize msgStore
if size == 0
then case maybeMeta of
Just meta -> Gtk.listStorePrepend msgStore (History' True (S.singleton val) meta)
Nothing -> error $ unlines
[ "error: History channel has size 0 message store but no reset."
, "This means that the first message the plotter saw didn't contain the meta-data."
, "This was probably caused by starting the plotter AFTER sending the first telemetry message."
]
else do History' _ vals0 meta <- Gtk.listStoreGetValue msgStore 0
maxHistory <- IORef.readIORef maxHist
let dropped = S.drop (1 + S.length vals0 maxHistory) (vals0 S.|> val)
Gtk.listStoreSetValue msgStore 0 (History' False dropped meta)
case maybeMeta of
Nothing -> return ()
Just meta -> Gtk.listStoreSetValue msgStore 0 (History' True (S.singleton val) meta)
let toSignalTree :: History'
-> [Tree ( [String]
, Either String (History' -> [[(Double, Double)]])
)]
toSignalTree (History' _ _ meta) = map (fmap f) meta
where
f :: ([String], Either String Int)
-> ([String], Either String (History' -> [[(Double, Double)]]))
f (n0, Left n1) = (n0, Left n1)
f (n0, Right k) = (n0, Right g)
where
g :: History' -> [[(Double, Double)]]
g (History' _ vals _) = [map toVal (F.toList vals)]
where
toVal (t, x) = (t, x V.! k)
sameSignalTree :: History' -> History' -> Bool
sameSignalTree (History' _ _ _) (History' False _ _) = True
sameSignalTree (History' _ _ old) (History' True _ new) = old == new
let retChan = Channel { chanName = name
, chanMsgStore = msgStore
, chanSameSignalTree = sameSignalTree
, chanToSignalTree = toSignalTree
, 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 $ 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 :: IO ()
killEverything = do
CC.killThread statsThread
gws <- CC.readMVar graphWindowsToBeKilled
mapM_ Gtk.widgetDestroy gws
mapM_ csKillThreads channels
Gtk.mainQuit
_ <- on win Gtk.deleteEvent $ liftIO (killEverything >> return False)
buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing"
_ <- on buttonDoNothing Gtk.buttonActivated $
putStrLn "seriously, it does nothing"
channelBox <- Gtk.vBoxNew False 4
Gtk.set channelBox $
concatMap (\x -> [ Gtk.containerChild := x
, Gtk.boxChildPacking x := Gtk.PackNatural
]) chanWidgets
scroll <- Gtk.scrolledWindowNew Nothing Nothing
Gtk.scrolledWindowAddWithViewport scroll channelBox
Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever
, Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic
]
vbox <- Gtk.vBoxNew False 4
Gtk.set vbox $
[ Gtk.containerChild := statsLabel
, Gtk.boxChildPacking statsLabel := Gtk.PackNatural
, Gtk.containerChild := buttonDoNothing
, Gtk.boxChildPacking buttonDoNothing := Gtk.PackNatural
, Gtk.containerChild := scroll
]
_ <- 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 = on buttonAlsoDoNothing Gtk.buttonActivated action >> return ()
buttonNew <- Gtk.buttonNewWithLabel "new graph"
_ <- on buttonNew Gtk.buttonActivated $ 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