Plot-ho-matic 0.8.0.0 → 0.9.0.0
raw patch · 10 files changed
+691/−361 lines, 10 filesdep +gtk3dep +transformersdep −gtkdep ~generic-accessorsPVP ok
version bump matches the API change (PVP)
Dependencies added: gtk3, transformers
Dependencies removed: gtk
Dependency ranges changed: generic-accessors
API changes (from Hackage documentation)
- SetHo: class Lookup a
+ PlotHo: instance Control.Monad.IO.Class.MonadIO PlotHo.Plotter
- SetHo: runSetter :: Lookup a => a -> IO a -> (a -> IO ()) -> IO ()
+ SetHo: runSetter :: String -> DTree -> IO (Maybe DTree) -> IO () -> (DTree -> IO ()) -> IO ()
Files
- CHANGELOG.md +6/−0
- Plot-ho-matic.cabal +5/−3
- examples/SetExample.hs +86/−11
- src/PlotHo.hs +25/−19
- src/PlotHo/GraphWidget.hs +6/−4
- src/PlotHo/PlotChart.hs +9/−8
- src/PlotHo/PlotTypes.hs +2/−1
- src/SetHo.hs +27/−32
- src/SetHo/LookupTree.hs +425/−283
- src/SetHo/OptionsWidget.hs +100/−0
CHANGELOG.md view
@@ -52,3 +52,9 @@ --- * Switch from Tree ([String], String, Maybe (a -> [[(Double, Double)]])) to Tree ([String], Either String (a -> [[(Double, Double)]]))++0.9.0.0+---+* generic-accessors 0.6.0.0 compatibility+* rewrite settings app to use dynamic data+* upgrade to GTK3
Plot-ho-matic.cabal view
@@ -1,5 +1,5 @@ name: Plot-ho-matic-version: 0.8.0.0+version: 0.9.0.0 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE@@ -29,19 +29,21 @@ PlotHo.PlotChart, PlotHo.PlotTypes, SetHo.LookupTree+ SetHo.OptionsWidget build-depends: base >= 4.6.0.0 && < 5 , containers , lens , data-default-class , glib- , gtk >= 0.13+ , gtk3 >= 0.14.2 , time , Chart >= 1.1 , Chart-cairo >= 1.1 , cairo , text , vector- , generic-accessors >= 0.5.0.0+ , transformers+ , generic-accessors >= 0.6.0.0 ghc-options: -O2 -Wall ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts
examples/SetExample.hs view
@@ -6,10 +6,12 @@ import GHC.Generics ( Generic ) -import Data.IORef ( newIORef, readIORef, writeIORef )+import Accessors ( Lookup )+import Accessors.Dynamic+import Control.Monad ( forever, void, when )+import qualified Control.Concurrent as CC import SetHo ( runSetter )-import Accessors ( Lookup ) data Bar = Bar@@ -19,20 +21,93 @@ } deriving (Generic, Show) instance Lookup Bar -data Foo =+data Foo a = Foo { foo1 :: Double , foo2 :: Int- , fooBar :: Bar+ , fooRec0 :: a+ , fooRec1 :: a } deriving (Generic, Show)-instance Lookup Foo+instance Lookup a => Lookup (Foo a) -initialFoo :: Foo-initialFoo = Foo pi 42 (Bar 1 2 True)+initialFoo :: Foo Bar+initialFoo = Foo pi 42 (Bar 21 (-2) True) (Bar 21 (-2) True) +initialBar :: Foo Int+initialBar = Foo 2.2 22 (-22) 84+ main :: IO () main = do- fooRef <- newIORef initialFoo- let refresh = readIORef fooRef- commit x = print x >> writeIORef fooRef x- runSetter initialFoo refresh commit+ upMsg <- CC.newEmptyMVar :: IO (CC.MVar (Maybe DTree))+ downMsg <- CC.newEmptyMVar :: IO (CC.MVar DTree)+ counterVar <- CC.newMVar (0::Int)++ let upstreamProcess = do+ upValue <- CC.newMVar (Left (initialFoo {foo2 = 999})) :: IO (CC.MVar (Either (Foo Bar) (Foo Int)))+ let sendState = do+ x <- CC.readMVar upValue :: IO (Either (Foo Bar) (Foo Int))+ putStrLn " upstream sending state"+ let d = case x of+ Left r -> toDData r+ Right r -> toDData r+ CC.putMVar downMsg d++ forever $ do+ putStrLn " upstream waiting for message"+ msg <- CC.takeMVar upMsg+ case msg of+ Nothing -> do+ putStrLn " upstream got refresh request"+ CC.threadDelay 500000+ CC.modifyMVar_ counterVar (return . (+1))+ count <- CC.readMVar counterVar+ putStrLn $ " upstream count: " ++ show count+ when (mod count 3 == 0) $ do+ putStrLn " upstream swapping data"+ let swapData (Left _) = Right initialBar+ swapData (Right _) = Left initialFoo+ CC.modifyMVar_ upValue (return . swapData)+ sendState+ Just newDVal -> do+ putStrLn " upstream got commit request"+ CC.threadDelay 500000+ let modify (Left oldVal) = case updateLookupable oldVal newDVal of+ Right newVal -> return (Left newVal)+ Left err -> do+ putStrLn $+ " upstream got update error:\n" +++ " " ++ err+ putStrLn "newDVal:"+ print newDVal+ return (Left oldVal)+ modify (Right oldVal) = case updateLookupable oldVal newDVal of+ Right newVal -> return (Right newVal)+ Left err -> do+ putStrLn $+ " upstream got update error:\n" +++ " " ++ err+ return (Right oldVal)++ CC.modifyMVar_ upValue modify+ sendState++ void $ CC.forkIO upstreamProcess++ let refresh = do+ putStrLn "downstream sending refresh request"+ CC.putMVar upMsg Nothing++ commit x = void $ do+ putStrLn "downstream starting to commit"+ CC.threadDelay 500000+ void $ CC.putMVar upMsg (Just x)+ putStrLn "downstream finished commit"++ pollForNewMessage = do+ mx <- CC.tryTakeMVar downMsg+ case mx of+ Nothing -> return ()+ Just _ -> putStrLn "downstream poll got msg"+ return mx++ runSetter "settings" (toDData initialFoo) pollForNewMessage refresh commit
src/PlotHo.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall #-} {-# Language ScopedTypeVariables #-} {-# Language DeriveFunctor #-}+{-# LANGUAGE PackageImports #-} module PlotHo ( Plotter@@ -20,6 +21,7 @@ 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@@ -28,8 +30,8 @@ import qualified Data.Tree as Tree import Data.Vector ( Vector ) import qualified Data.Vector as V-import Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified Graphics.UI.Gtk as Gtk+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 )@@ -58,10 +60,10 @@ return (b, w `mappend` w') fail msg = Plotter $ fail msg -liftIO :: IO a -> Plotter a-liftIO m = Plotter $ do- a <- m- return (a, mempty)+instance MonadIO Plotter where+ liftIO m = Plotter $ do+ a <- m+ return (a, mempty) tell :: ChannelStuff -> Plotter () tell w = Plotter (return ((), [w]))@@ -167,22 +169,25 @@ 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+ Left _ -> error "historySignalTree: got a Field right away"+ acc -> Tree.subForest $ head $ makeSignalTree' [] acc where makeSignalTree' :: [String] -> AccessorTree a -> HistorySignalTree a- makeSignalTree' myFieldName (Data (ptn,_) children) =+ makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) = [Tree.Node- (reverse myFieldName, Left ptn)- (concatMap (\(getterName, child) -> makeSignalTree' (getterName:myFieldName) child) children)+ (reverse myFieldName, Left cname)+ (concatMap (\(getterName, child) -> makeSignalTree' (fromMName getterName:myFieldName) child) children) ]- makeSignalTree' myFieldName (Field field) =+ 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 :: Field a -> (a -> Double)+ toDoubleGetter :: GAField a -> (a -> Double) toDoubleGetter (FieldDouble f) = (^. f) toDoubleGetter (FieldFloat f) = realToFrac . (^. f)- toDoubleGetter (FieldBool f) = fromIntegral . fromEnum . (^. f) toDoubleGetter (FieldInt f) = fromIntegral . (^. f) toDoubleGetter (FieldString _) = const 0 toDoubleGetter FieldSorry = const 0@@ -367,18 +372,19 @@ - let killEverything = do+ let killEverything :: IO ()+ killEverything = do CC.killThread statsThread gws <- CC.readMVar graphWindowsToBeKilled mapM_ Gtk.widgetDestroy gws mapM_ csKillThreads channels Gtk.mainQuit- _ <- Gtk.onDestroy win killEverything+ _ <- on win Gtk.deleteEvent $ liftIO (killEverything >> return False) --------------- main widget ----------------- -- button to clear history buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing"- _ <- Gtk.onClicked buttonDoNothing $+ _ <- on buttonDoNothing Gtk.buttonActivated $ putStrLn "seriously, it does nothing" -- box to hold list of channels@@ -428,11 +434,11 @@ -- putStrLn "i promise, nothing happens" -- -- CC.modifyMVar_ logData (const (return S.empty)) -- return ()- let triggerYo action = Gtk.onClicked buttonAlsoDoNothing action >> return ()+ let triggerYo action = on buttonAlsoDoNothing Gtk.buttonActivated action >> return () -- button to make a new graph buttonNew <- Gtk.buttonNewWithLabel "new graph"- _ <- Gtk.onClicked buttonNew $ do+ _ <- on buttonNew Gtk.buttonActivated $ do graphWin <- newGraph triggerYo (chanName channel)
src/PlotHo/GraphWidget.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-}-{-# Language ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-} module PlotHo.GraphWidget ( newGraph@@ -7,14 +8,15 @@ import qualified Control.Concurrent as CC import Control.Monad ( void, when, unless )+import Control.Monad.IO.Class ( liftIO ) import Data.Either ( isRight ) import qualified Data.IORef as IORef import Data.List ( intercalate ) import qualified Data.Map as M import Data.Maybe ( isNothing, fromJust ) import qualified Data.Tree as Tree-import Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified Graphics.UI.Gtk as Gtk+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk import System.Glib.Signals ( on ) import Text.Read ( readMaybe ) import qualified Data.Text as T@@ -82,7 +84,7 @@ chartGtkUpdateCanvas latestRenderable chartCanvas return False -- we're done now, don't call this again - _ <- Gtk.onExpose chartCanvas $ const (redraw >> return True)+ _ <- on chartCanvas Gtk.exposeEvent $ liftIO (redraw >> return True) -- the options widget
src/PlotHo/PlotChart.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-} module PlotHo.PlotChart ( AxisScaling(..)@@ -11,12 +12,13 @@ import Data.Default.Class ( def ) --import qualified Data.Foldable as F --import qualified Data.Sequence as S-import qualified Graphics.UI.Gtk as Gtk+import qualified "gtk3" Graphics.UI.Gtk as Gtk import qualified Graphics.Rendering.Chart as Chart import Graphics.Rendering.Chart.Backend.Cairo ( runBackend, defaultEnv )-import Graphics.Rendering.Cairo hiding (width, height)- --( Render, Format(..)- --, renderWith, setSourceSurface, withImageSurface )+import Graphics.Rendering.Cairo+ ( Render, Format(..)+ , renderWith, withImageSurface, setSourceSurface, paint+ ) import PlotHo.PlotTypes ( AxisScaling(..) ) @@ -27,8 +29,7 @@ case maybeWin of Nothing -> Gtk.threadsLeave >> return () Just win -> do- (width, height) <- Gtk.widgetGetSize canvas- regio <- Gtk.regionRectangle $ Gtk.Rectangle 0 0 width height+ Gtk.Rectangle _ _ width height <- Gtk.widgetGetAllocation canvas Gtk.threadsLeave let sz = (fromIntegral width,fromIntegral height) let render0 :: Render (Chart.PickFn ())@@ -38,8 +39,8 @@ _ <- renderWith surface render0 let render1 = setSourceSurface surface 0 0 >> paint Gtk.threadsEnter- Gtk.drawWindowBeginPaintRegion win regio- _ <- Gtk.renderWithDrawable win render1+ Gtk.drawWindowBeginPaintRect win (Gtk.Rectangle 0 0 width height)+ _ <- Gtk.renderWithDrawWindow win render1 Gtk.drawWindowEndPaint win Gtk.threadsLeave
src/PlotHo/PlotTypes.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall #-} --{-# Language ExistentialQuantification #-} --{-# Language GADTs #-}+{-# Language PackageImports #-} module PlotHo.PlotTypes ( Channel(..)@@ -11,7 +12,7 @@ ) where import Data.Tree ( Tree )-import qualified Graphics.UI.Gtk as Gtk+import qualified "gtk3" Graphics.UI.Gtk as Gtk import Data.IORef ( IORef ) data MarkedState =
src/SetHo.hs view
@@ -1,30 +1,30 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# Language PackageImports #-} -- | This is an experimental and unstable interface for -- generating a GUI for getting/setting options. module SetHo ( runSetter- -- * re-exported for convenience- , Lookup ) where import qualified GHC.Stats +import Accessors.Dynamic ( DTree ) import qualified Control.Concurrent as CC-import Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified Graphics.UI.Gtk as Gtk+import Control.Monad.IO.Class ( liftIO )+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk import Text.Printf ( printf )---import System.Glib.Signals ( on )--import Accessors+import System.Glib.Signals ( on ) -import SetHo.LookupTree ( GraphInfo(..), newLookupTreeview, makeOptionsWidget )+import SetHo.LookupTree ( newLookupTreeview )+import SetHo.OptionsWidget ( GraphInfo(..), makeOptionsWidget ) -- | fire up the the GUI-runSetter :: forall a . Lookup a => a -> IO a -> (a -> IO ()) -> IO ()-runSetter initialValue refresh commit = do+runSetter :: String -> DTree -> IO (Maybe DTree) -> IO () -> (DTree -> IO ()) -> IO ()+runSetter rootName initialValue userPollForNewMessage sendRequest commit = do statsEnabled <- GHC.Stats.getGCStatsEnabled _ <- Gtk.initGUI@@ -63,28 +63,17 @@ -- mapM_ Gtk.widgetDestroy gws -- mapM_ csKillThreads channels Gtk.mainQuit- _ <- Gtk.onDestroy win killEverything+ _ <- on win Gtk.deleteEvent $ liftIO (killEverything >> return False) --------------- main widget ----------------- buttonCommit <- Gtk.buttonNewWithLabel "commit" buttonRefresh <- Gtk.buttonNewWithLabel "refresh" Gtk.widgetSetTooltipText buttonCommit (Just "SET ME SET ME GO HEAD DO IT COME ON SET ME") - msgStore <- Gtk.listStoreNew [initialValue]- let newMessage :: a -> IO ()- newMessage next =- -- grab the time and counter- Gtk.postGUIAsync $ do- size <- Gtk.listStoreGetSize msgStore- if size == 0- then Gtk.listStorePrepend msgStore next- else Gtk.listStoreSetValue msgStore 0 next- -- mvar with all the user input graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = True , giXRange = Nothing- , giValue = initialValue- } :: IO (CC.MVar (GraphInfo a))+ } :: IO (CC.MVar GraphInfo) -- the options widget optionsWidget <- makeOptionsWidget graphInfoMVar@@ -94,7 +83,7 @@ ] -- the signal selector- (treeview, getLatestStaged) <- newLookupTreeview initialValue msgStore+ (treeview, getLatestStaged, receiveNewValue) <- newLookupTreeview rootName initialValue treeviewExpander <- Gtk.expanderNew "signals" Gtk.set treeviewExpander [ Gtk.containerChild := treeview@@ -116,15 +105,21 @@ , Gtk.boxChildPacking treeviewExpander := Gtk.PackGrow ] - _ <- Gtk.onClicked buttonCommit $ do- val <- getLatestStaged- commit val- - _ <- Gtk.onClicked buttonRefresh $ do- newVal <- refresh- newMessage newVal+ _ <- on buttonCommit Gtk.buttonActivated $ do+ val <- getLatestStaged+ commit val --- add widget to window and show+ _ <- on buttonRefresh Gtk.buttonActivated sendRequest++ let pollForNewMessage = do+ mmsg <- userPollForNewMessage+ case mmsg of+ Nothing -> return ()+ Just newVal -> receiveNewValue newVal++ _ <- Gtk.timeoutAddFull (pollForNewMessage >> return True) Gtk.priorityDefault 300++ -- add widget to window and show _ <- Gtk.set win [ Gtk.containerChild := vbox ] Gtk.widgetShowAll win Gtk.mainGUI
src/SetHo/LookupTree.hs view
@@ -1,77 +1,127 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# Language PackageImports #-} module SetHo.LookupTree- ( GraphInfo(..)- , ListViewInfo(..)+ ( ListViewElement(..) , newLookupTreeview- , makeOptionsWidget ) where -import qualified Control.Concurrent as CC-import Data.List ( foldl' )-import qualified Data.IORef as IORef-import qualified Data.Tree as Tree-import Control.Lens ( (.~), (^.) )-import Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified Graphics.UI.Gtk as Gtk+import Accessors.Dynamic+ ( DTree, DData(..), DConstructor(..), DSimpleEnum(..), DField(..)+ , describeDField, sameDFieldType+ , denumToString, denumToStringOrMsg, denumSetString+ )+import Control.Monad ( void, when )+import qualified Data.Text as T+import Data.Tree ( Tree(..) )+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk import System.Glib.Signals ( on ) import Text.Read ( readMaybe )-import qualified Data.Text as T import Text.Printf ( printf ) -import Accessors ( Lookup, AccessorTree(..), Field(..), accessors, describeField )+data FieldElem =+ FieldElem+ { feName :: Maybe String+ , feUpstreamField :: DField+ , feStagedField :: DField+ } deriving Show -data ListViewInfo a =- ListViewInfo- { lviName :: String- , lviType :: String- , lviField :: Maybe (Field a)- , lviMarked :: Bool- , lviStagedMutator :: a -> a- , lviUpstreamValue :: a- , lviShownValue :: String- }+data ConstructorElem =+ ConstructorElem+ { ceName :: Maybe String+ , ceDName :: String+ , ceCName :: String+ } deriving (Show, Eq) -instance Show a => Show (ListViewInfo a) where- show (ListViewInfo n t _ _ mut val m) = "ListViewInfo " ++ show (n,t,m,mut val)+data SumElem =+ SumElem+ { seName :: Maybe String+ , seDName :: String+ , seUpstreamSum :: DSimpleEnum+ , seStagedSum :: DSimpleEnum+ , seListStore :: Gtk.ListStore String+-- , seSpinAdjustment :: Gtk.Adjustment+ } -- deriving Show --- what the graph should draw-data GraphInfo a =- GraphInfo { giXScaling :: Bool- , giXRange :: Maybe (Double,Double)- , giValue :: a- }+data ListViewElement =+ LveField FieldElem+ | LveConstructor ConstructorElem+ | LveSum SumElem+-- deriving Show -type SignalTree a = Tree.Forest (String, String, Maybe (Field a))+ddataToTree :: Maybe String -> Either DField DData -> IO (Tree ListViewElement)+ddataToTree name (Left field) = return $ Node (LveField fe) []+ where+ fe =+ FieldElem+ { feName = name+ , feUpstreamField = field+ , feStagedField = field+ }+ddataToTree name (Right (DData dname (DConstructor cname fields))) = do+ let ce =+ ConstructorElem+ { ceName = name+ , ceDName = dname+ , ceCName = cname+ }+ children <- mapM (uncurry ddataToTree) fields+ return $ Node (LveConstructor ce) children+ddataToTree name (Right (DData dname (DSum s))) = do+ -- Dummy list store. We'll set the options ourselves in the editingStarted signal+ listStore <- Gtk.listStoreNew []+ Gtk.treeModelSetColumn listStore (Gtk.makeColumnIdString 0) id+-- let value = 0+-- lower = 0+-- upper = realToFrac (length options - 1)+-- stepIncrement = 1+-- pageIncrement = 1+-- pageSize = 0+-- adjustment <- Gtk.adjustmentNew value lower upper stepIncrement pageIncrement pageSize+ let se =+ SumElem+ { seName = name+ , seDName = dname+ , seUpstreamSum = s+ , seStagedSum = s+ , seListStore = listStore+-- , seSpinAdjustment = adjustment+ }+ return $ Node (LveSum se) [] -toSignalTree :: forall a . Lookup a => SignalTree a-toSignalTree = case (accessors :: AccessorTree a) of- (Field _) -> error "toSignalTree: got an accessor right away"- d -> Tree.subForest $ head $ makeSignalTree' "" "" d+treeToStagedDData :: Tree ListViewElement -> Either DField DData+treeToStagedDData (Node (LveField fe) []) = Left (feStagedField fe)+treeToStagedDData (Node (LveField fe) _) =+ error $ "treeToStagedDData: LveField " ++ show fe ++ " has children"+treeToStagedDData (Node (LveConstructor ce) fields) =+ Right (DData dname (DConstructor cname (map f fields))) 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 (Field f) =- [Tree.Node (myName, parentName, Just f) []]+ dname = ceDName ce+ cname = ceCName ce + getName :: Tree ListViewElement -> Maybe String+ getName (Node (LveSum se) _) = seName se+ getName (Node (LveConstructor ce') _) = ceName ce'+ getName (Node (LveField fe) _) = feName fe + f x = (getName x, treeToStagedDData x)+treeToStagedDData (Node (LveSum se) []) =+ Right (DData dname (DSum s))+ where+ dname = seDName se+ s = seStagedSum se+treeToStagedDData (Node (LveSum _) _) =+ error $ "treeToStagedDData: LveSum has children" newLookupTreeview ::- forall a- . Lookup a- => a- -> Gtk.ListStore a- -> IO (Gtk.ScrolledWindow, IO a)-newLookupTreeview initialValue msgStore = do- let signalTree = toSignalTree-- treeStore <- Gtk.treeStoreNew []- treeview <- Gtk.treeViewNewWithModel treeStore+ String+ -> DTree+ -> IO (Gtk.ScrolledWindow, IO DTree, DTree -> IO ())+newLookupTreeview rootName initialValue = do+ treeStore <- Gtk.treeStoreNew [] :: IO (Gtk.TreeStore ListViewElement)+ treeview <- Gtk.treeViewNewWithModel treeStore :: IO Gtk.TreeView Gtk.treeViewSetHeadersVisible treeview True Gtk.treeViewSetEnableTreeLines treeview True@@ -79,194 +129,232 @@ -- Gtk.treeViewSetGridLines treeview Gtk.TreeViewGridLinesBoth -- add some columns- colName <- Gtk.treeViewColumnNew- colType <- Gtk.treeViewColumnNew+ colName <- Gtk.treeViewColumnNew+ colType <- Gtk.treeViewColumnNew colUpstreamValue <- Gtk.treeViewColumnNew- colStagedValue <- Gtk.treeViewColumnNew- colBool <- Gtk.treeViewColumnNew- colSpin <- Gtk.treeViewColumnNew+ colStagedValue <- Gtk.treeViewColumnNew+ colCombo <- Gtk.treeViewColumnNew+-- colSpin <- Gtk.treeViewColumnNew Gtk.treeViewColumnSetTitle colName "name"- Gtk.treeViewColumnSetTitle colBool "bool" Gtk.treeViewColumnSetTitle colType "type" Gtk.treeViewColumnSetTitle colUpstreamValue "upstream" Gtk.treeViewColumnSetTitle colStagedValue "staged"- Gtk.treeViewColumnSetTitle colSpin "spin"+ Gtk.treeViewColumnSetTitle colCombo "combo"+-- Gtk.treeViewColumnSetTitle colSpin "enum" rendererName <- Gtk.cellRendererTextNew- rendererBool <- Gtk.cellRendererToggleNew rendererType <- Gtk.cellRendererTextNew rendererStagedValue <- Gtk.cellRendererTextNew rendererUpstreamValue <- Gtk.cellRendererTextNew- rendererSpin <- Gtk.cellRendererSpinNew+ rendererCombo <- Gtk.cellRendererComboNew+-- rendererSpin <- Gtk.cellRendererSpinNew - Gtk.cellLayoutPackStart colName rendererName True- Gtk.cellLayoutPackStart colType rendererType True+ Gtk.cellLayoutPackStart colName rendererName True+ Gtk.cellLayoutPackStart colType rendererType True Gtk.cellLayoutPackStart colUpstreamValue rendererUpstreamValue True- Gtk.cellLayoutPackStart colStagedValue rendererStagedValue True- Gtk.cellLayoutPackStart colBool rendererBool True- Gtk.cellLayoutPackStart colSpin rendererSpin True+ Gtk.cellLayoutPackStart colStagedValue rendererStagedValue True+ Gtk.cellLayoutPackStart colCombo rendererCombo True+-- Gtk.cellLayoutPackStart colSpin rendererSpin True _ <- Gtk.treeViewAppendColumn treeview colName _ <- Gtk.treeViewAppendColumn treeview colType _ <- Gtk.treeViewAppendColumn treeview colUpstreamValue _ <- Gtk.treeViewAppendColumn treeview colStagedValue- _ <- Gtk.treeViewAppendColumn treeview colBool- _ <- Gtk.treeViewAppendColumn treeview colSpin+ _ <- Gtk.treeViewAppendColumn treeview colCombo+-- _ <- Gtk.treeViewAppendColumn treeview colSpin -- data name- let showName (Just _) name _ = name- showName Nothing name "" = name- showName Nothing name typeName = name ++ " (" ++ typeName ++ ")"+ let showName :: ListViewElement -> String+ showName (LveSum se) = fromMName $ seName se+ showName (LveField fe) = fromMName $ feName fe+ showName (LveConstructor ce) = fromMName $ ceName ce+ fromMName (Just r) = r+ fromMName Nothing = "()" Gtk.cellLayoutSetAttributes colName rendererName treeStore $- \(ListViewInfo {lviName = name, lviType = typeName, lviField = field}) ->- [ Gtk.cellText := showName field name typeName- ]+ \lve -> [Gtk.cellText := showName lve] -- data type- let showType (Just x) = describeField x- showType Nothing = ""+ let showType :: ListViewElement -> String+ showType (LveSum se) = seDName se+ showType (LveConstructor ce) = ceDName ce+ showType (LveField fe) = describeDField (feStagedField fe) Gtk.cellLayoutSetAttributes colType rendererType treeStore $- \lvi -> [ Gtk.cellText := showType (lviField lvi) ]+ \lve -> [ Gtk.cellText := showType lve ] - -- upstream value- let showUpstreamValue lvi = case lviField lvi of- (Just (FieldBool f)) -> show (upstream ^. f)- (Just (FieldDouble f)) -> printf "%.2g" (upstream ^. f)- (Just (FieldFloat f)) -> printf "%.2g" (upstream ^. f)- (Just (FieldInt f)) -> show (upstream ^. f)- (Just (FieldString f)) -> upstream ^. f- Just FieldSorry -> ""- Nothing -> ""- where- upstream = lviUpstreamValue lvi+ -- upstream+ let showField :: DField -> String+ showField (DDouble x) = printf "%.2g" x+ showField (DFloat x) = printf "%.2g" x+ showField (DInt x) = show x+ showField (DString x) = x+ showField DSorry = "" - Gtk.cellLayoutSetAttributes colUpstreamValue rendererUpstreamValue treeStore $- \lvi -> [ Gtk.cellText := showUpstreamValue lvi- , Gtk.cellTextEditable := False- ]+ showSum :: DSimpleEnum -> String+ showSum denum = case denumToString denum of+ Left msg -> msg+ Right r -> r - -- staged value- let showStagedValue lvi = case lviField lvi of- Just (FieldBool f) -> show (staged ^. f)- Just (FieldDouble f) -> printf "%.2g" (staged ^. f)- Just (FieldFloat f) -> printf "%.2g" (staged ^. f)- Just (FieldInt f) -> show (staged ^. f)- Just (FieldString f) -> staged ^. f- Just FieldSorry -> ""- Nothing -> ""- where- staged = lviStagedMutator lvi (lviUpstreamValue lvi)+ Gtk.cellLayoutSetAttributes colUpstreamValue rendererUpstreamValue treeStore $+ \lve -> case lve of+ LveField fe -> [ Gtk.cellText := showField (feUpstreamField fe)+ , Gtk.cellTextEditable := False+ ]+ LveSum se -> [ Gtk.cellText := showSum (seUpstreamSum se)+ , Gtk.cellTextEditable := False+ ]+ LveConstructor _ -> [ Gtk.cellText := ""+ , Gtk.cellTextEditable := False+ ] + -- staged Gtk.cellLayoutSetAttributes colStagedValue rendererStagedValue treeStore $- \lvi -> case lviField lvi of- Just _ -> [ Gtk.cellText := showStagedValue lvi- , Gtk.cellTextEditable := True- ]- Nothing -> [ Gtk.cellText := ""- , Gtk.cellTextEditable := False- ]+ \lve -> case lve of+ LveField fe ->+ [ Gtk.cellText := showField (feStagedField fe)+ , Gtk.cellTextEditable := True+ ]+ LveSum se ->+ [ Gtk.cellText := showSum (seStagedSum se)+ , Gtk.cellTextEditable := False+ ]+ LveConstructor _ ->+ [ Gtk.cellText := ""+ , Gtk.cellTextEditable := False+ ]++ let modifyField :: DField -> String -> DField+ modifyField f0@(DDouble _) txt = case readMaybe txt of+ Nothing -> f0+ Just x -> DDouble x+ modifyField f0@(DFloat _) txt = case readMaybe txt of+ Nothing -> f0+ Just x -> DFloat x+ modifyField f0@(DInt _) txt = case readMaybe txt of+ Nothing -> f0+ Just x -> DInt x+ modifyField (DString _) txt = DString txt+ modifyField DSorry _ = DSorry++ modifySum :: DSimpleEnum -> String -> DSimpleEnum+ modifySum denum txt = case denumSetString denum txt of+ Left _ -> denum+ Right r -> r+ _ <- on rendererStagedValue Gtk.edited $ \treePath txt -> do- let _ = txt :: String- lvi0 <- Gtk.treeStoreGetValue treeStore treePath- let lvi = case lviField lvi0 of- Just (FieldBool f)- | txt `elem` ["t","true","True","1"] ->- lvi0 { lviStagedMutator = f .~ True, lviMarked = True }- | txt `elem` ["f","false","False","0"] ->- lvi0 {lviStagedMutator = f .~ False, lviMarked = False }- | otherwise -> lvi0- Just (FieldDouble f) -> case readMaybe txt of- Nothing -> lvi0- Just x -> lvi0 { lviStagedMutator = f .~ x }- Just (FieldFloat f) -> case readMaybe txt of- Nothing -> lvi0- Just x -> lvi0 { lviStagedMutator = f .~ x }- Just (FieldInt f) -> case readMaybe txt of- Nothing -> lvi0- Just x -> lvi0 { lviStagedMutator = f .~ x }- Just (FieldString f) -> lvi0 { lviStagedMutator = f .~ txt }- Just FieldSorry -> lvi0- Nothing -> lvi0- Gtk.treeStoreSetValue treeStore treePath lvi- return ()+ lve0 <- Gtk.treeStoreGetValue treeStore treePath+ let lve = case lve0 of+ LveField fe -> LveField (fe {feStagedField = modifyField (feStagedField fe) txt})+ LveSum se -> LveSum (se {seStagedSum = modifySum (seStagedSum se) txt})+ ce@(LveConstructor _) -> ce -- not editible anyway+ Gtk.treeStoreSetValue treeStore treePath lve - -- bool- let toShownBool marked (Just (FieldBool _)) =- [ Gtk.cellToggleInconsistent := False- , Gtk.cellToggleActive := marked- , Gtk.cellToggleActivatable := True- , Gtk.cellToggleRadio := True- , Gtk.cellToggleIndicatorSize := 12- ]- toShownBool _ _ =- [ Gtk.cellToggleInconsistent := True- , Gtk.cellToggleActive := False- , Gtk.cellToggleActivatable := False- , Gtk.cellToggleRadio := True- , Gtk.cellToggleIndicatorSize := 0- ]+ -- combo box+ Gtk.cellLayoutSetAttributes colCombo rendererCombo treeStore $ \lve ->+ case lve of+ LveSum (SumElem {seStagedSum = denum, seListStore = listStore}) ->+ [ Gtk.cellComboHasEntry := False+ , Gtk.cellTextEditable := True+ , Gtk.cellComboTextModel := (listStore, Gtk.makeColumnIdString 0 :: Gtk.ColumnId String String)+ , Gtk.cellText := denumToStringOrMsg denum+ ]+ _ -> [ Gtk.cellMode := Gtk.CellRendererModeInert+ , Gtk.cellText := ""+ ] - Gtk.cellLayoutSetAttributes colBool rendererBool treeStore $- \lvi -> toShownBool (lviMarked lvi) (lviField lvi)+ _ <- on rendererCombo Gtk.editingStarted $ \widget treePath -> do+ lve <- Gtk.treeStoreGetValue treeStore treePath+ case lve of+ LveField _ -> error "Combo renderer is Field"+ LveConstructor _ -> error "Combo renderer is Constructor"+ LveSum se -> do+ let comboBox = Gtk.castToComboBox widget+ comboListStore <- Gtk.comboBoxSetModelText comboBox+ let DSimpleEnum constructors active = seStagedSum se+ mapM_ (Gtk.listStoreAppend comboListStore . T.pack) constructors+ Gtk.comboBoxSetActive comboBox active - _ <- on rendererBool Gtk.cellToggled $ \pathStr -> do- let treePath = Gtk.stringToTreePath pathStr- lvi0 <- Gtk.treeStoreGetValue treeStore treePath- let newMarked :: Bool- newMarked = not (lviMarked lvi0)- newMutator :: a -> a- newMutator = case lviField lvi0 of- Just (FieldBool f) -> f .~ newMarked- Just f -> error $ "the new mutator must be a bool mutator, got "- ++ describeField f- Nothing -> error "the new mutator must be not Nothing"- Gtk.treeStoreSetValue treeStore treePath- (lvi0 {lviMarked = newMarked, lviStagedMutator = newMutator})- return () - -- spin- let toSpin _lvi = []- Gtk.cellLayoutSetAttributes colSpin rendererSpin treeStore toSpin+ _ <- on rendererCombo Gtk.edited $ \treePath newVal -> do+ lve0 <- Gtk.treeStoreGetValue treeStore treePath+ let newLve = case lve0 of+ LveSum se -> LveSum (se {seStagedSum = case denumSetString (seStagedSum se) newVal of+ Left msg -> error $ "error updating sum elem: " ++ msg+ Right r -> r+ })+ LveField _ -> error "cell renderer edited on Field"+ LveConstructor _ -> error "cell renderer edited on Constructor"+ Gtk.treeStoreSetValue treeStore treePath newLve - let -- build the signal tree- convert :: Tree.Tree (String, String, Maybe (Field a))- -> Tree.Tree (ListViewInfo a)- convert (Tree.Node (name, typ, getter) others) =- Tree.Node (ListViewInfo name typ getter marked id initialValue "")- (map convert others)- where- marked = case (getter :: Maybe (Field a)) of- Just (FieldBool f) -> initialValue ^. f- _ -> False+-- -- spin button for enums+-- Gtk.cellLayoutSetAttributes colSpin rendererSpin treeStore $ \lve ->+-- case lve of+---- LveField _ -> [ Gtk.cellText := ""+---- , Gtk.cellComboHasEntry := False+---- ]+---- LveConstructor _ -> [ Gtk.cellText := ""+---- , Gtk.cellComboHasEntry := False+---- ]+-- LveSum (SumElem {seStagedSum = denum, seSpinAdjustment = adjustment}) ->+-- [ Gtk.cellRendererSpinAdjustment := adjustment+---- , Gtk.cellText := denumToStringOrMsg denum+-- , Gtk.cellMode := Gtk.CellRendererModeActivatable+---- , Gtk.cellMode := Gtk.CellRendererModeEditable+-- , Gtk.cellTextEditable := True+-- , Gtk.cellVisible := True+-- , Gtk.cellSensitive := True+---- , Gtk.cellComboHasEntry := False+-- ]+-- _ -> []+--+-- _ <- on rendererSpin Gtk.editingStarted $ \widget treePath -> do+-- putStrLn "spin renderer is being edited"+--+---- _ <- Gtk.onValueChanged AdjChangedon rendererSpin Gtk.edited $ \treePath (newVal :: String) -> do+---- putStrLn "combo box is being edited"+---- lve0 <- Gtk.treeStoreGetValue treeStore treePath+---- let newLve = case lve0 of+---- LveSum se -> LveSum (se {seStagedSum = case denumSetString (seStagedSum se) newVal of+---- Left msg -> error $ "error updating sum elem: " ++ msg+---- Right r -> r+---- })+---- LveField _ -> error "cell renderer edited on Field"+---- LveConstructor _ -> error "cell renderer edited on Constructor"+---- Gtk.treeStoreSetValue treeStore treePath newLve - Gtk.treeStoreClear treeStore- Gtk.treeStoreInsertForest treeStore [] 0 (map convert signalTree) - let forEach :: (ListViewInfo a -> IO (ListViewInfo a)) -> IO ()- forEach f = Gtk.treeModelForeach treeStore $ \treeIter -> do- treePath <- Gtk.treeModelGetPath treeStore treeIter- lvi0 <- Gtk.treeStoreGetValue treeStore treePath- lvi1 <- f lvi0- Gtk.treeStoreSetValue treeStore treePath lvi1- return False+ Gtk.treeStoreClear treeStore+ tree <- ddataToTree (Just rootName) initialValue+ Gtk.treeStoreInsertTree treeStore [] 0 tree - latestUpstreamRef <- IORef.newIORef initialValue- let gotNewValue val = do- IORef.writeIORef latestUpstreamRef val- forEach (\lvi -> return (lvi {lviUpstreamValue = val}))+-- let forEach :: (ListViewElement -> IO ListViewElement) -> IO ()+-- forEach f = Gtk.treeModelForeach treeStore $ \treeIter -> do+-- treePath <- Gtk.treeModelGetPath treeStore treeIter+-- lve0 <- Gtk.treeStoreGetValue treeStore treePath+-- lve1 <- f lve0+-- Gtk.treeStoreSetValue treeStore treePath lve1+-- return False - -- on insert or change, rebuild the signal tree- _ <- on msgStore Gtk.rowChanged $ \_ changedPath -> do- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)- gotNewValue newMsg+-- let gotNewValue val = do+-- moldTree <- Gtk.treeStoreLookup treeStore [0]+-- oldTree <- case moldTree of+-- Nothing -> error "failed looking up treestore"+-- Just r -> return r+--+-- -- forEach (\lve -> return (lve {lveUpstreamValue = val}))+-- return () - _ <- on msgStore Gtk.rowInserted $ \_ changedPath -> do- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)- gotNewValue newMsg+-- -- on insert or change, rebuild the signal tree+-- _ <- on treeStore Gtk.rowChanged $ \_ changedPath -> do+-- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)+-- gotNewValue newMsg+--+-- _ <- on treeStore Gtk.rowInserted $ \_ changedPath -> do+-- newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)+-- gotNewValue newMsg scroll <- Gtk.scrolledWindowNew Nothing Nothing Gtk.containerAdd scroll treeview@@ -274,99 +362,153 @@ , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic ] - let getAll :: IO [ListViewInfo a]- getAll = do- lvisRef <- IORef.newIORef []- Gtk.treeModelForeach treeStore $ \treeIter -> do- treePath <- Gtk.treeModelGetPath treeStore treeIter- lvi <- Gtk.treeStoreGetValue treeStore treePath- IORef.modifyIORef lvisRef (lvi:)- return False- fmap reverse (IORef.readIORef lvisRef)- let getLatest = do- lvis <- getAll- latestUpstream <- IORef.readIORef latestUpstreamRef- return (foldl' (flip lviStagedMutator) latestUpstream lvis)+ let mergeTrees :: Gtk.TreePath -> Tree ListViewElement -> IO ()+ mergeTrees treePath newTree = do+ moldTree <- Gtk.treeStoreLookup treeStore treePath+ oldTree <- case moldTree of+ Nothing -> error "failed looking up treestore"+ Just r -> return r+ :: IO (Tree ListViewElement) - return (scroll, getLatest)+ let assertCompatible :: Bool -> IO ()+ assertCompatible False = error "the \"impossible\" happened: trees aren't compatible"+ assertCompatible True = return () + case (oldTree, newTree) of+ -- sums+ (Node (LveSum oldSum) [], Node (LveSum newSum) []) -> do+ let (compatible, mergedSum) = mergeSums oldSum newSum+ assertCompatible compatible+ changed <- Gtk.treeStoreChange treeStore treePath (const (LveSum mergedSum))+ case changed of+ False -> error $ "merged sums didn't change"+ True -> return ()+ (_, Node (LveSum _) []) -> assertCompatible False+ (_, Node (LveSum _) _) -> error "mergeTrees: new LveSum has children" + -- fields+ (Node (LveField oldField) [], Node (LveField newField) []) -> do+ let (compatible, mergedField) = mergeFields oldField newField+ assertCompatible compatible+ changed <- Gtk.treeStoreChange treeStore treePath (const (LveField mergedField))+ case changed of+ False -> error $ "merged fields didn't change"+ True -> return ()+ (_, Node (LveField _) []) -> assertCompatible False+ (_, Node (LveField _) _) -> error "mergeTrees: new LveField has children" -makeOptionsWidget :: CC.MVar (GraphInfo a) -> IO Gtk.VBox-makeOptionsWidget graphInfoMVar = do- -- user selectable range- xRange <- Gtk.entryNew- Gtk.set xRange [ Gtk.entryEditable := False- , Gtk.widgetSensitive := False- ]- xRangeBox <- labeledWidget "x range:" xRange- Gtk.set xRange [Gtk.entryText := "(-10,10)"]- let updateXRange = do- Gtk.set xRange [ Gtk.entryEditable := True- , Gtk.widgetSensitive := True- ]- txt <- Gtk.get xRange Gtk.entryText- gi <- CC.readMVar graphInfoMVar- case readMaybe txt of- Nothing -> do- putStrLn $ "invalid x range entry: " ++ txt- Gtk.set xRange [Gtk.entryText := "(min,max)"]- Just (z0,z1) -> if z0 >= z1- then do- putStrLn $ "invalid x range entry (min >= max): " ++ txt- Gtk.set xRange [Gtk.entryText := "(min,max)"]- return ()- else do- _ <- CC.swapMVar graphInfoMVar (gi {giXRange = Just (z0,z1)})- return ()- _ <- on xRange Gtk.entryActivate updateXRange+ -- constructors+ (Node (LveConstructor oldCons) oldChildren, Node (LveConstructor newCons) newChildren)+ | oldCons /= newCons -> assertCompatible False+ | length oldChildren /= length newChildren -> assertCompatible False+ | otherwise -> do+ mtreeIter <- Gtk.treeModelGetIter treeStore treePath+ treeIter <- case mtreeIter of+ Nothing -> error "error looking up tree iter"+ Just r -> return r+ nchildren <- Gtk.treeModelIterNChildren treeStore (Just treeIter)+ void $ when (nchildren /= length oldChildren) $+ error "error $ treeModelIterNChildren /= length oldChildren"+ let mergeNthChild _ [] = return ()+ mergeNthChild k (newChild:others) = do+ mtreeIter' <- Gtk.treeModelGetIter treeStore treePath+ treeIter' <- case mtreeIter' of+ Nothing -> error "error looking up tree iter"+ Just r -> return r+ mchildIter <- Gtk.treeModelIterNthChild treeStore (Just treeIter') k+ childIter <- case mchildIter of+ Nothing -> error "treeModelIterNthChild failed"+ Just r -> return r+ mchildPath <- Gtk.treeModelGetPath treeStore childIter+ childPath <- case mchildPath of+ [] -> error "child TreePath is invalid"+ r -> return r+ mergeTrees childPath newChild+ mergeNthChild (k + 1) others+ mergeNthChild 0 newChildren+ (_, Node (LveConstructor _) _) -> assertCompatible False - -- linear or log scaling on the x and y axis?- xScalingSelector <- Gtk.comboBoxNewText- mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack)- ["linear (auto)","linear (manual)","logarithmic (auto)"]- Gtk.comboBoxSetActive xScalingSelector 0- xScalingBox <- labeledWidget "x scaling:" xScalingSelector- let updateXScaling = do- k <- Gtk.comboBoxGetActive xScalingSelector- case k of- 0 -> do- Gtk.set xRange [ Gtk.entryEditable := False- , Gtk.widgetSensitive := False- ]- CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXScaling = False, giXRange = Nothing}- 1 -> do- Gtk.set xRange [ Gtk.entryEditable := False- , Gtk.widgetSensitive := False- ]- CC.modifyMVar_ graphInfoMVar $- \gi -> return $ gi {giXScaling = True, giXRange = Nothing}- _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 3"- updateXScaling- _ <- on xScalingSelector Gtk.changed updateXScaling+ receiveNewValue :: DTree -> IO ()+ receiveNewValue newMsg = do+ moldTree <- Gtk.treeStoreLookup treeStore [0]+ oldTree <- case moldTree of+ Nothing -> error "failed looking up old treestore"+ Just r -> return r - -- vbox to hold the little window on the left- vbox <- Gtk.vBoxNew False 4+ newTree <- ddataToTree (Just rootName) newMsg :: IO (Tree ListViewElement)+ let (compatible, mergedTree) = compatibleTrees oldTree newTree+ if compatible+ then mergeTrees [0] newTree -- merge in place so that the expando doesn't collapse+ else do+ putStrLn "settings app rebuilding tree..."+ Gtk.treeStoreClear treeStore+ Gtk.treeStoreInsertTree treeStore [] 0 mergedTree - Gtk.set vbox [ Gtk.containerChild := xScalingBox- , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural- , Gtk.containerChild := xRangeBox- , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural- ]+ getLatestStaged = do+ mtree <- Gtk.treeStoreLookup treeStore [0]+ case mtree of+ Nothing -> error "failed looking up treestore"+ Just r -> return (treeToStagedDData r) - return vbox+ return (scroll, getLatestStaged, receiveNewValue) +mergeSums :: SumElem -> SumElem -> (Bool, SumElem)+mergeSums oldSum newSum+ | seName oldSum /= seName newSum = (False, newSum)+ | seDName oldSum /= seDName newSum = (False, newSum)+ | oldOptions /= newOptions = (False, newSum)+ | otherwise = (True, newSum {seStagedSum = seStagedSum oldSum})+ where+ DSimpleEnum oldOptions _ = seStagedSum oldSum+ DSimpleEnum newOptions _ = seStagedSum newSum +mergeFields :: FieldElem -> FieldElem -> (Bool, FieldElem)+mergeFields oldElem newElem+ | feName oldElem /= feName newElem = (False, newElem)+ | not (sameDFieldType oldField newField) = (False, newElem)+ | otherwise = (True, newElem {feStagedField = oldField})+ where+ oldField = feStagedField oldElem+ newField = feStagedField newElem --- helper to make an hbox with a label-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--- , Gtk.boxChildPacking widget := Gtk.PackNatural- ]- return hbox+-- return the merged trees and a flag saying if the trees have the same structure+compatibleTrees :: Tree ListViewElement -> Tree ListViewElement -> (Bool, Tree ListViewElement)+-- sums+compatibleTrees (Node (LveSum oldSum) []) (Node (LveSum newSum) []) =+ (compatible, Node (LveSum merged) [])+ where+ (compatible, merged) = mergeSums oldSum newSum+compatibleTrees _ newNode@(Node (LveSum _) []) = (False, newNode)+compatibleTrees _ (Node (LveSum _) _) = error "compatibleTrees: new LveSum has children"+-- fields+compatibleTrees (Node (LveField oldField) []) (Node (LveField newField) []) =+ (compatible, Node (LveField merged) [])+ where+ (compatible, merged) = mergeFields oldField newField+compatibleTrees _ newNode@(Node (LveField _) []) = (False, newNode)+compatibleTrees _ (Node (LveField _) _) = error "compatibleTrees: new LveField has children"+-- constructors+compatibleTrees (Node (LveConstructor oldCons) _) newNode@(Node (LveConstructor newCons) _)+ | oldCons /= newCons = (False, newNode)+compatibleTrees (Node (LveConstructor _) oldChildren) (Node (LveConstructor newCons) newChildren) =+ (childrenCompatible, Node (LveConstructor newCons) mergedChildren)+ where+ (childrenCompatible, mergedChildren) = mergeChildren newChildren++ mergeChild :: Tree ListViewElement -> (Bool, Tree ListViewElement)+ mergeChild newChild = tryOldChildren oldChildren+ where+ tryOldChildren [] = (False, newChild)+ tryOldChildren (oldChild:others)+ | compatible = (True, mergedChild)+ | otherwise = tryOldChildren others+ where+ (compatible, mergedChild) = compatibleTrees oldChild newChild++ mergeChildren :: [Tree ListViewElement] -> (Bool, [Tree ListViewElement])+ mergeChildren (newChild:others) = (childCompatible && othersCompatible, mergedChild:mergedOthers)+ where+ (childCompatible, mergedChild) = mergeChild newChild+ (othersCompatible, mergedOthers) = mergeChildren others+ mergeChildren [] = (True, [])+compatibleTrees _ newNode@(Node (LveConstructor _) _) = (False, newNode)
+ src/SetHo/OptionsWidget.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# Language PackageImports #-}++module SetHo.OptionsWidget+ ( GraphInfo(..)+ , makeOptionsWidget+ ) where++import qualified Control.Concurrent as CC+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk+import System.Glib.Signals ( on )+import Text.Read ( readMaybe )+import qualified Data.Text as T++-- what the graph should draw+data GraphInfo =+ GraphInfo { giXScaling :: Bool+ , giXRange :: Maybe (Double,Double)+ }++makeOptionsWidget :: CC.MVar GraphInfo -> IO Gtk.VBox+makeOptionsWidget graphInfoMVar = do+ -- user selectable range+ xRange <- Gtk.entryNew+ Gtk.set xRange [ Gtk.entryEditable := False+ , Gtk.widgetSensitive := False+ ]+ xRangeBox <- labeledWidget "x range:" xRange+ Gtk.set xRange [Gtk.entryText := "(-10,10)"]+ let updateXRange = do+ Gtk.set xRange [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ txt <- Gtk.get xRange Gtk.entryText+ gi <- CC.readMVar graphInfoMVar+ case readMaybe txt of+ Nothing -> do+ putStrLn $ "invalid x range entry: " ++ txt+ Gtk.set xRange [Gtk.entryText := "(min,max)"]+ Just (z0,z1) -> if z0 >= z1+ then do+ putStrLn $ "invalid x range entry (min >= max): " ++ txt+ Gtk.set xRange [Gtk.entryText := "(min,max)"]+ return ()+ else do+ _ <- CC.swapMVar graphInfoMVar (gi {giXRange = Just (z0,z1)})+ return ()+ _ <- on xRange Gtk.entryActivate updateXRange++ -- linear or log scaling on the x and y axis?+ xScalingSelector <- Gtk.comboBoxNewText+ mapM_ (Gtk.comboBoxAppendText xScalingSelector . T.pack)+ ["linear (auto)","linear (manual)","logarithmic (auto)"]+ Gtk.comboBoxSetActive xScalingSelector 0+ xScalingBox <- labeledWidget "x scaling:" xScalingSelector+ let updateXScaling = do+ k <- Gtk.comboBoxGetActive xScalingSelector+ case k of+ 0 -> do+ Gtk.set xRange [ Gtk.entryEditable := False+ , Gtk.widgetSensitive := False+ ]+ CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXScaling = False, giXRange = Nothing}+ 1 -> do+ Gtk.set xRange [ Gtk.entryEditable := False+ , Gtk.widgetSensitive := False+ ]+ CC.modifyMVar_ graphInfoMVar $+ \gi -> return $ gi {giXScaling = True, giXRange = Nothing}+ _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 3"+ updateXScaling+ _ <- on xScalingSelector Gtk.changed updateXScaling++ -- vbox to hold the little window on the left+ vbox <- Gtk.vBoxNew False 4++ Gtk.set vbox [ Gtk.containerChild := xScalingBox+ , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural+ , Gtk.containerChild := xRangeBox+ , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural+ ]++ return vbox++++-- helper to make an hbox with a label+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+-- , Gtk.boxChildPacking widget := Gtk.PackNatural+ ]+ return hbox