diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -43,3 +43,12 @@ 0.7.0.0 --- * Better legend and title. + +0.7.0.1 +--- +* Make the list of channels a scrollable thing. + +0.8.0.0 +--- +* Switch from Tree ([String], String, Maybe (a -> [[(Double, Double)]])) + to Tree ([String], Either String (a -> [[(Double, Double)]])) diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -1,5 +1,5 @@ name: Plot-ho-matic -version: 0.7.0.1 +version: 0.8.0.0 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE diff --git a/examples/PlotExample.hs b/examples/PlotExample.hs --- a/examples/PlotExample.hs +++ b/examples/PlotExample.hs @@ -9,39 +9,41 @@ import PlotHo ( Lookup, XAxisType(..), runPlotter, addHistoryChannel ) -data Xyz a = MkXyz { x :: Double +data Foo a = MkFoo { x :: Double , y :: Double , z :: Double - , zz :: a + , w :: a } deriving Generic -data Axyz = MkAxyz { lol :: Double +data Bar = MkBar { lol :: Double -- , xyzList :: S.Seq Xyz - , xyz1 :: Xyz (Xyz (Xyz Double)) - , xyz2 :: Xyz Double - } deriving Generic -instance Lookup a => Lookup (Xyz a) -instance Lookup Axyz + , foos :: Foo (Foo (Foo Double)) + , foo :: Foo Double + } deriving Generic +instance Lookup a => Lookup (Foo a) +instance Lookup Bar -axyz0 :: Axyz -axyz0 = MkAxyz - 7 --- (S.fromList [MkXyz 1 2 3]) - (MkXyz 1 2 3 (MkXyz 4 5 6 (MkXyz 7 8 9 10))) - (MkXyz 1 2 3 4) +bar0 :: Bar +bar0 = + MkBar + 7 +-- (S.fromList [MkFoo 1 2 3]) + (MkFoo 1 2 3 (MkFoo 4 5 6 (MkFoo 7 8 9 10))) + (MkFoo 1 2 3 4) -xyz0 :: Xyz Double -xyz0 = MkXyz 1 2 3 0.1 +foo0 :: Foo Double +foo0 = MkFoo 1 2 3 0.1 -incrementAxyz :: Axyz -> Axyz -incrementAxyz (MkAxyz a _ _) = MkAxyz - (a+0.2) - (xyz' (xyz' (xyz' (sin (3*a))))) - (xyz' (sin (2*a))) +incrementBar :: Bar -> Bar +incrementBar (MkBar a _ _) = + MkBar + (a+0.2) + (foo' (foo' (foo' (sin (3*a))))) + (foo' (sin (2*a))) where - xyz' w = MkXyz (sin a) (cos a) (sin a * cos a) w + foo' t = MkFoo (sin a) (cos a) (sin a * cos a) t -incrementXyz :: Xyz a -> Xyz a -incrementXyz (MkXyz a _ _ b) = MkXyz (a+0.3) (2 * sin a) (3 * cos a) b +incrementFoo :: Foo a -> Foo a +incrementFoo (MkFoo a _ _ b) = MkFoo (a+0.3) (2 * sin a) (3 * cos a) b -- a random function to write a bunch of data to a chan channelWriter :: Int -> Int -> (a -> a) -> a -> (a -> Bool -> IO ()) -> IO () @@ -56,7 +58,7 @@ -- ekgTid <- fmap EKG.serverThreadId $ EKG.forkServer "localhost" 8000 runPlotter $ do - addHistoryChannel "posPlos" XAxisTime $ channelWriter 0 50000 incrementAxyz axyz0 - addHistoryChannel "pos" XAxisCount $ channelWriter 0 60000 incrementXyz xyz0 - addHistoryChannel "posPlos" XAxisTime0 $ channelWriter 0 50000 incrementAxyz axyz0 - addHistoryChannel "pos" XAxisCount0 $ channelWriter 0 60000 incrementXyz xyz0 + addHistoryChannel "Foo (XAxisTime)" XAxisTime $ channelWriter 0 50000 incrementFoo foo0 + addHistoryChannel "Bar (XAxisCount)" XAxisCount $ channelWriter 0 60000 incrementBar bar0 + addHistoryChannel "Foo (XAxisTime0)" XAxisTime0 $ channelWriter 0 50000 incrementFoo foo0 + addHistoryChannel "Bar (XAxisCount0)" XAxisCount0 $ channelWriter 0 60000 incrementBar bar0 diff --git a/src/PlotHo.hs b/src/PlotHo.hs --- a/src/PlotHo.hs +++ b/src/PlotHo.hs @@ -116,7 +116,7 @@ addChannel :: String -- ^ channel name -> (a -> a -> Bool) -- ^ Is the signal tree the same? This is used for instance if signals have changed and the plotter needs to rebuild the signal tree. This lets you keep the plotter running and change other programs which send messages to the plotter. - -> (a -> [Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) -- ^ how to build the signal tree + -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))]) -- ^ how to build the signal tree -> ((a -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO' -> Plotter () addChannel name sameSignalTree toSignalTree action = do @@ -131,7 +131,7 @@ forall a . String -> (a -> a -> Bool) - -> (a -> [Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) + -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))]) -> IO (Channel a, a -> IO ()) newChannel name sameSignalTree toSignalTree = do msgStore <- Gtk.listStoreNew [] @@ -157,7 +157,7 @@ data History a = History (S.Seq (a, Int, NominalDiffTime)) -type HistorySignalTree a = Tree.Forest ([String], String, Maybe (History a -> [[(Double, Double)]])) +type HistorySignalTree a = Tree.Forest ([String], Either String (History a -> [[(Double, Double)]])) data XAxisType = XAxisTime -- ^ time since the first message @@ -168,16 +168,16 @@ historySignalTree :: forall a . Lookup a => XAxisType -> HistorySignalTree a historySignalTree axisType = case accessors of (Field _) -> error "historySignalTree: got a Field right away" - d -> Tree.subForest $ head $ makeSignalTree' [] "" d + d -> Tree.subForest $ head $ makeSignalTree' [] d where - makeSignalTree' :: [String] -> String -> AccessorTree a -> HistorySignalTree a - makeSignalTree' myFieldName parentTypeName (Data (ptn,_) children) = + makeSignalTree' :: [String] -> AccessorTree a -> HistorySignalTree a + makeSignalTree' myFieldName (Data (ptn,_) children) = [Tree.Node - (reverse myFieldName, parentTypeName, Nothing) - (concatMap (\(getterName, child) -> makeSignalTree' (getterName:myFieldName) ptn child) children) + (reverse myFieldName, Left ptn) + (concatMap (\(getterName, child) -> makeSignalTree' (getterName:myFieldName) child) children) ] - makeSignalTree' myFieldName parentTypeName (Field field) = - [Tree.Node (reverse myFieldName, parentTypeName, Just (toHistoryGetter (toDoubleGetter field))) []] + makeSignalTree' myFieldName (Field field) = + [Tree.Node (reverse myFieldName, Right (toHistoryGetter (toDoubleGetter field))) []] toDoubleGetter :: Field a -> (a -> Double) toDoubleGetter (FieldDouble f) = (^. f) @@ -251,8 +251,7 @@ when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val)) let tst :: History a -> [Tree ( [String] - , String - , Maybe (History a -> [[(Double, Double)]]) + , Either String (History a -> [[(Double, Double)]]) )] tst = const (historySignalTree xaxisType) @@ -265,7 +264,7 @@ return (retChan, newMessage) -type Meta = [Tree ([String], String, Maybe Int)] +type Meta = [Tree ([String], Either String Int)] data History' = History' Bool (S.Seq (Double, Vector Double)) Meta -- History channel which does NOT automatically generates the signal tree for you. @@ -285,7 +284,11 @@ if size == 0 then case maybeMeta of Just meta -> Gtk.listStorePrepend msgStore (History' True (S.singleton val) meta) - Nothing -> error "history channel got size 0 message store but no reset" + 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) @@ -298,15 +301,14 @@ let toSignalTree :: History' -> [Tree ( [String] - , String - , Maybe (History' -> [[(Double, Double)]]) + , Either String (History' -> [[(Double, Double)]]) )] toSignalTree (History' _ _ meta) = map (fmap f) meta where - f :: ([String], String, Maybe Int) - -> ([String], String, Maybe (History' -> [[(Double, Double)]])) - f (n0, n1, Nothing) = (n0, n1, Nothing) - f (n0, n1, Just k) = (n0, n1, Just g) + 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)] diff --git a/src/PlotHo/GraphWidget.hs b/src/PlotHo/GraphWidget.hs --- a/src/PlotHo/GraphWidget.hs +++ b/src/PlotHo/GraphWidget.hs @@ -7,10 +7,11 @@ import qualified Control.Concurrent as CC import Control.Monad ( void, when, unless ) +import Data.Either ( isRight ) import qualified Data.IORef as IORef import Data.List ( intercalate ) import qualified Data.Map as M -import Data.Maybe ( isNothing, isJust, fromJust ) +import Data.Maybe ( isNothing, fromJust ) import qualified Data.Tree as Tree import Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified Graphics.UI.Gtk as Gtk @@ -28,7 +29,7 @@ . (IO () -> IO ()) -> String -> (a -> a -> Bool) - -> (a -> [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) + -> (a -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))]) -> Gtk.ListStore a -> IO Gtk.Window newGraph onButton channame sameSignalTree forestFromMeta msgStore = do win <- Gtk.windowNew @@ -156,7 +157,7 @@ forall a . (IO () -> IO ()) -> (a -> a -> Bool) - -> (a -> [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) + -> (a -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))]) -> CC.MVar (GraphInfo a) -> Gtk.ListStore a -> IO () -> IO Gtk.ScrolledWindow @@ -179,19 +180,19 @@ Gtk.cellLayoutPackStart col1 renderer1 True Gtk.cellLayoutPackStart col2 renderer2 True - let showName :: Maybe (a -> [[(Double, Double)]]) -> [String] -> String -> String + let showName :: Either String (a -> [[(Double, Double)]]) -> [String] -> String -- show a getter name - showName (Just _) (name:_) _ = name - showName (Just _) [] _ = error "showName on field got an empty list" + showName (Right _) (name:_) = name + showName (Right _) [] = error "showName on field got an empty list" -- show a parent without type info - showName Nothing (name:_) "" = name + showName (Left "") (name:_) = name -- show a parent with type info - showName Nothing (name:_) typeName = name ++ " (" ++ typeName ++ ")" - showName Nothing [] _ = error "showName on parent got an empty list" + showName (Left typeName) (name:_) = name ++ " (" ++ typeName ++ ")" + showName (Left _) [] = error "showName on parent got an empty list" Gtk.cellLayoutSetAttributes col1 renderer1 treeStore $ - \(ListViewInfo {lviName = name, lviType = typeName, lviGetter = getter}) -> - [ Gtk.cellText := showName getter (reverse name) typeName + \(ListViewInfo {lviName = name, lviTypeOrGetter = typeOrGetter}) -> + [ Gtk.cellText := showName typeOrGetter (reverse name) ] Gtk.cellLayoutSetAttributes col2 renderer2 treeStore $ \lvi -> case lviMarked lvi of On -> [ Gtk.cellToggleInconsistent := False @@ -216,11 +217,13 @@ case tree' of Nothing -> return [] Just tree -> fmap (tree:) (getTrees (k+1)) theTrees <- getTrees 0 - let newGetters0 :: [([String], a -> [[(Double, Double)]])] - newGetters0 = [ (lviName lvi, fromJust $ lviGetter lvi) + let fromRight (Right r) = r + fromRight (Left _) = error "PlotHo GraphWidget: fromRight got Left, this should be impossible" + newGetters0 :: [([String], a -> [[(Double, Double)]])] + newGetters0 = [ (lviName lvi, fromRight $ lviTypeOrGetter lvi) | lvi <- concatMap Tree.flatten theTrees , lviMarked lvi == On - , isJust (lviGetter lvi) + , isRight (lviTypeOrGetter lvi) ] let newGetters :: [(String, a -> [[(Double, Double)]])] newTitle :: Maybe String @@ -282,17 +285,17 @@ -- toggle the check mark val <- Gtk.treeStoreGetValue treeStore treePath case val of - (ListViewInfo _ _ Nothing Off) -> + (ListViewInfo _ (Left _) Off) -> changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath - (ListViewInfo _ _ Nothing On) -> + (ListViewInfo _ (Left _) On) -> changeSelfAndChildren (\lvi -> lvi {lviMarked = Off}) treePath - (ListViewInfo _ _ Nothing Inconsistent) -> + (ListViewInfo _ (Left _) Inconsistent) -> changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath - lvi@(ListViewInfo _ _ (Just _) On) -> + lvi@(ListViewInfo _ (Right _) On) -> Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = Off} - lvi@(ListViewInfo _ _ (Just _) Off) -> + lvi@(ListViewInfo _ (Right _) Off) -> Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = On} - (ListViewInfo _ _ (Just _) Inconsistent) -> error "cell getter can't be inconsistent" + (ListViewInfo _ (Right _) Inconsistent) -> error "cell getter can't be inconsistent" fixInconsistent treePath updateGraphInfo @@ -306,7 +309,7 @@ mapM treeFromJust mnodes -- rebuild the signal tree - let rebuildSignalTree :: [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))] + let rebuildSignalTree :: [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))] -> IO () rebuildSignalTree meta = do putStrLn "rebuilding signal tree" @@ -316,19 +319,28 @@ merge :: forall b . [Tree.Tree (ListViewInfo b)] - -> [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))] + -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))] -> [Tree.Tree (ListViewInfo a)] merge old new = map convert new where - oldMap :: M.Map ([String], String) (ListViewInfo b, [Tree.Tree (ListViewInfo b)]) - oldMap = M.fromList $ - map (\(Tree.Node lvi lvis) -> ((lviName lvi, lviType lvi), (lvi, lvis))) old + oldMap :: M.Map ([String], Maybe String) (ListViewInfo b, [Tree.Tree (ListViewInfo b)]) + oldMap = M.fromList $ map f old + where + f (Tree.Node lvi lvis) = ((lviName lvi, maybeType), (lvi, lvis)) + where + maybeType = case lviTypeOrGetter lvi of + Left typ -> Just typ + Right _ -> Nothing - convert :: Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]])) + convert :: Tree.Tree ([String], Either String (a -> [[(Double, Double)]])) -> Tree.Tree (ListViewInfo a) - convert (Tree.Node (name, typ, getter) others) = case M.lookup (name, typ) oldMap of - Nothing -> Tree.Node (ListViewInfo name typ getter Off) (merge [] others) - Just (lvi, oldOthers) -> Tree.Node (ListViewInfo name typ getter (lviMarked lvi)) (merge oldOthers others) + convert (Tree.Node (name, tog) others) = case M.lookup (name, maybeType) oldMap of + Nothing -> Tree.Node (ListViewInfo name tog Off) (merge [] others) + Just (lvi, oldOthers) -> Tree.Node (ListViewInfo name tog (lviMarked lvi)) (merge oldOthers others) + where + maybeType = case tog of + Left r -> Just r + Right _ -> Nothing newTrees = merge oldTrees meta diff --git a/src/PlotHo/PlotTypes.hs b/src/PlotHo/PlotTypes.hs --- a/src/PlotHo/PlotTypes.hs +++ b/src/PlotHo/PlotTypes.hs @@ -20,13 +20,13 @@ data ListViewInfo a = ListViewInfo { lviName :: [String] - , lviType :: String - , lviGetter :: Maybe (a -> [[(Double,Double)]]) + , lviTypeOrGetter :: Either String (a -> [[(Double,Double)]]) , lviMarked :: MarkedState } instance Show (ListViewInfo a) where - show (ListViewInfo n t _ m) = "ListViewInfo " ++ show (n,t,m) + show (ListViewInfo n (Left t) m) = "ListViewInfo " ++ show (n,t,m) + show (ListViewInfo n (Right _) m) = "ListViewInfo " ++ show (n,m) data AxisScaling = LogScaling | LinearScaling @@ -46,8 +46,7 @@ , chanMsgStore :: Gtk.ListStore a , chanSameSignalTree :: a -> a -> Bool , chanToSignalTree :: a -> [Tree ( [String] - , String - , Maybe (a -> [[(Double, Double)]]) + , Either String (a -> [[(Double, Double)]]) )] , chanMaxHistory :: IORef Int }