{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables #-} module SetHo.LookupTree ( GraphInfo(..) , ListViewInfo(..) , 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 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 ListViewInfo a = ListViewInfo { lviName :: String , lviType :: String , lviField :: Maybe (Field a) , lviMarked :: Bool , lviStagedMutator :: a -> a , lviUpstreamValue :: a , lviShownValue :: String } instance Show a => Show (ListViewInfo a) where show (ListViewInfo n t _ _ mut val m) = "ListViewInfo " ++ show (n,t,m,mut val) -- what the graph should draw data GraphInfo a = GraphInfo { giXScaling :: Bool , giXRange :: Maybe (Double,Double) , giValue :: a } type SignalTree a = Tree.Forest (String, String, Maybe (Field a)) 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 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) []] 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 Gtk.treeViewSetHeadersVisible treeview True Gtk.treeViewSetEnableTreeLines treeview True -- Gtk.treeViewSetGridLines treeview Gtk.TreeViewGridLinesVertical -- Gtk.treeViewSetGridLines treeview Gtk.TreeViewGridLinesBoth -- add some columns colName <- Gtk.treeViewColumnNew colType <- Gtk.treeViewColumnNew colUpstreamValue <- Gtk.treeViewColumnNew colStagedValue <- Gtk.treeViewColumnNew colBool <- 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" rendererName <- Gtk.cellRendererTextNew rendererBool <- Gtk.cellRendererToggleNew rendererType <- Gtk.cellRendererTextNew rendererStagedValue <- Gtk.cellRendererTextNew rendererUpstreamValue <- Gtk.cellRendererTextNew rendererSpin <- Gtk.cellRendererSpinNew 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.treeViewAppendColumn treeview colName _ <- Gtk.treeViewAppendColumn treeview colType _ <- Gtk.treeViewAppendColumn treeview colUpstreamValue _ <- Gtk.treeViewAppendColumn treeview colStagedValue _ <- Gtk.treeViewAppendColumn treeview colBool _ <- Gtk.treeViewAppendColumn treeview colSpin -- data name let showName (Just _) name _ = name showName Nothing name "" = name showName Nothing name typeName = name ++ " (" ++ typeName ++ ")" Gtk.cellLayoutSetAttributes colName rendererName treeStore $ \(ListViewInfo {lviName = name, lviType = typeName, lviField = field}) -> [ Gtk.cellText := showName field name typeName ] -- data type let showType (Just x) = describeField x showType Nothing = "" Gtk.cellLayoutSetAttributes colType rendererType treeStore $ \lvi -> [ Gtk.cellText := showType (lviField lvi) ] -- 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 Gtk.cellLayoutSetAttributes colUpstreamValue rendererUpstreamValue treeStore $ \lvi -> [ Gtk.cellText := showUpstreamValue lvi , Gtk.cellTextEditable := False ] -- 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 colStagedValue rendererStagedValue treeStore $ \lvi -> case lviField lvi of Just _ -> [ Gtk.cellText := showStagedValue lvi , Gtk.cellTextEditable := True ] Nothing -> [ Gtk.cellText := "" , Gtk.cellTextEditable := False ] _ <- 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 () -- 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 ] Gtk.cellLayoutSetAttributes colBool rendererBool treeStore $ \lvi -> toShownBool (lviMarked lvi) (lviField lvi) _ <- 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 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 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 latestUpstreamRef <- IORef.newIORef initialValue let gotNewValue val = do IORef.writeIORef latestUpstreamRef val forEach (\lvi -> return (lvi {lviUpstreamValue = val})) -- on insert or change, rebuild the signal tree _ <- on msgStore Gtk.rowChanged $ \_ changedPath -> do newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath) gotNewValue newMsg _ <- on msgStore Gtk.rowInserted $ \_ changedPath -> do newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath) gotNewValue newMsg scroll <- Gtk.scrolledWindowNew Nothing Nothing Gtk.containerAdd scroll treeview Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever , 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) return (scroll, getLatest) 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 -- 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