diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 diff --git a/examples/SetExample.hs b/examples/SetExample.hs --- a/examples/SetExample.hs +++ b/examples/SetExample.hs @@ -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 diff --git a/src/PlotHo.hs b/src/PlotHo.hs --- a/src/PlotHo.hs +++ b/src/PlotHo.hs @@ -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) diff --git a/src/PlotHo/GraphWidget.hs b/src/PlotHo/GraphWidget.hs --- a/src/PlotHo/GraphWidget.hs +++ b/src/PlotHo/GraphWidget.hs @@ -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 diff --git a/src/PlotHo/PlotChart.hs b/src/PlotHo/PlotChart.hs --- a/src/PlotHo/PlotChart.hs +++ b/src/PlotHo/PlotChart.hs @@ -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 diff --git a/src/PlotHo/PlotTypes.hs b/src/PlotHo/PlotTypes.hs --- a/src/PlotHo/PlotTypes.hs +++ b/src/PlotHo/PlotTypes.hs @@ -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 = diff --git a/src/SetHo.hs b/src/SetHo.hs --- a/src/SetHo.hs +++ b/src/SetHo.hs @@ -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 diff --git a/src/SetHo/LookupTree.hs b/src/SetHo/LookupTree.hs --- a/src/SetHo/LookupTree.hs +++ b/src/SetHo/LookupTree.hs @@ -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) diff --git a/src/SetHo/OptionsWidget.hs b/src/SetHo/OptionsWidget.hs new file mode 100644 --- /dev/null +++ b/src/SetHo/OptionsWidget.hs @@ -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