module PlotHo.HistoryChannel
( Meta
, XAxisType(..)
, newHistoryChannel
, newHistoryChannel'
) where
import qualified Control.Concurrent as CC
import Control.Lens ( (^.) )
import Control.Monad ( when )
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 qualified Data.Sequence as S
import Accessors
import PlotHo.Channel ( newChannel' )
import PlotHo.PlotTypes ( Channel(..), Channel'(..), SignalTree, debug )
type Meta = Tree ([String], Either String Int)
newtype History a = History (S.Seq (a, Int, NominalDiffTime))
data History' = History' !Bool !(S.Seq (Double, Vector Double)) !Meta
data XAxisType =
XAxisTime
| XAxisTime0
| XAxisCount
| XAxisCount0
historySignalTree :: forall a . Lookup a => XAxisType -> String -> SignalTree (History a)
historySignalTree axisType topName = makeSignalTree' [topName] accessors
where
makeSignalTree' :: [String] -> AccessorTree a -> SignalTree (History a)
makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) =
Tree.Node
(reverse myFieldName, Left cname)
(map (\(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, a -> Bool -> IO ())
newHistoryChannel name xaxisType = do
time0 <- getCurrentTime >>= IORef.newIORef
counter <- IORef.newIORef 0
let toSignalTree :: History a -> SignalTree (History a)
toSignalTree = const (historySignalTree xaxisType name)
sameSignalTree _ _ = True
(channel', newHistoryMessage) <- newChannel' name sameSignalTree toSignalTree
:: IO (Channel' (History a), History a -> IO ())
newHistoryMessage (History mempty)
let newMessage :: a -> Bool -> IO ()
newMessage next reset = do
debug "newMessage(newHistoryChannel): message received"
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)
let val = (next, k, diffUTCTime time time0')
latestChanValue <- CC.readMVar (chanLatestValueMVar channel')
oldTimeSeries <- case latestChanValue of
Just (History r, _) -> return r
Nothing -> error "newMessage(newHistoryChannel): the 'impossible' happened: channel has no latest message"
maxHistory <- IORef.readIORef (chanMaxHistory channel')
let newTimeSeries
| reset = S.singleton val
| otherwise = S.drop (1 + S.length oldTimeSeries maxHistory) (oldTimeSeries S.|> val)
debug "newMessage(newHistoryChannel): new history message calling internal newMessage"
newHistoryMessage (History newTimeSeries)
clearHistory :: History a -> History a
clearHistory = const (History mempty)
return (Channel (channel' {chanClearHistory = Just clearHistory}) , newMessage)
newHistoryChannel' ::
String
-> IO (Channel, Either Meta (Double, Vector Double) -> IO ())
newHistoryChannel' name = do
let toSignalTree :: History'
-> Tree ( [String]
, Either String (History' -> [[(Double, Double)]])
)
toSignalTree (History' _ _ meta) = 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
(channel', newHistoryMessage) <- newChannel' name sameSignalTree toSignalTree
:: IO (Channel' History', History' -> IO ())
let newMessage :: Either Meta (Double, Vector Double) -> IO ()
newMessage msg = do
latestChannelValue <- CC.readMVar (chanLatestValueMVar channel')
case (latestChannelValue, msg) of
(Nothing, Right _) ->
putStr $ unlines
[ "WARNING: First message seen by Plot-ho-matic doesn't have signal tree meta-data."
, "This was probably caused by starting the plotter AFTER sending the first telemetry message."
, "Try restarting the application sending messages."
]
(_, Left meta) -> newHistoryMessage (History' True mempty meta)
(Just (History' _ oldTimeSeries meta, _), Right (nextTime, nextVal)) -> do
maxHistory <- IORef.readIORef (chanMaxHistory channel')
let newTimeSeries =
S.drop (1 + S.length oldTimeSeries maxHistory) (oldTimeSeries S.|> (nextTime, nextVal))
newHistoryMessage (History' False newTimeSeries meta)
clearHistory :: History' -> History'
clearHistory (History' reset _ meta) = History' reset mempty meta
return (Channel (channel' {chanClearHistory = Just clearHistory}) , newMessage)