module SetHo
( runSetter
, Lookup
) where
import qualified GHC.Stats
import qualified Control.Concurrent as CC
import Graphics.UI.Gtk ( AttrOp( (:=) ) )
import qualified Graphics.UI.Gtk as Gtk
import Text.Printf ( printf )
import Accessors
import SetHo.LookupTree ( GraphInfo(..), newLookupTreeview, makeOptionsWidget )
runSetter :: forall a . Lookup a => a -> IO a -> (a -> IO ()) -> IO ()
runSetter initialValue refresh commit = do
statsEnabled <- GHC.Stats.getGCStatsEnabled
_ <- Gtk.initGUI
_ <- Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50
win <- Gtk.windowNew
_ <- Gtk.set win [ Gtk.containerBorderWidth := 8
, Gtk.windowTitle := "set-ho-matic"
]
statsLabel <- Gtk.labelNew (Nothing :: Maybe String)
let statsWorker = do
CC.threadDelay 500000
msg <- if statsEnabled
then do
stats <- GHC.Stats.getGCStats
return $ printf "The current memory usage is %.2f MB"
((realToFrac (GHC.Stats.currentBytesUsed stats) :: Double) /(1024*1024))
else return "(enable GHC statistics with +RTS -T)"
Gtk.postGUISync $ Gtk.labelSetText statsLabel ("Welcome to set-ho-matic!\n" ++ msg)
statsWorker
statsThread <- CC.forkIO statsWorker
graphWindowsToBeKilled <- CC.newMVar []
let killEverything = do
CC.killThread statsThread
_gws <- CC.readMVar graphWindowsToBeKilled
Gtk.mainQuit
_ <- Gtk.onDestroy win killEverything
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 =
Gtk.postGUIAsync $ do
size <- Gtk.listStoreGetSize msgStore
if size == 0
then Gtk.listStorePrepend msgStore next
else Gtk.listStoreSetValue msgStore 0 next
graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = True
, giXRange = Nothing
, giValue = initialValue
} :: IO (CC.MVar (GraphInfo a))
optionsWidget <- makeOptionsWidget graphInfoMVar
options <- Gtk.expanderNew "options"
Gtk.set options [ Gtk.containerChild := optionsWidget
, Gtk.expanderExpanded := False
]
(treeview, getLatestStaged) <- newLookupTreeview initialValue msgStore
treeviewExpander <- Gtk.expanderNew "signals"
Gtk.set treeviewExpander
[ Gtk.containerChild := treeview
, Gtk.expanderExpanded := True
]
vbox <- Gtk.vBoxNew False 4
Gtk.set vbox
[ Gtk.containerChild := statsLabel
, Gtk.boxChildPacking statsLabel := Gtk.PackNatural
, Gtk.containerChild := buttonCommit
, Gtk.boxChildPacking buttonCommit := Gtk.PackNatural
, Gtk.containerChild := buttonRefresh
, Gtk.boxChildPacking buttonRefresh := Gtk.PackNatural
, Gtk.containerChild := options
, Gtk.boxChildPacking options := Gtk.PackNatural
, Gtk.containerChild := treeviewExpander
, Gtk.boxChildPacking treeviewExpander := Gtk.PackGrow
]
_ <- Gtk.onClicked buttonCommit $ do
val <- getLatestStaged
commit val
_ <- Gtk.onClicked buttonRefresh $ do
newVal <- refresh
newMessage newVal
_ <- Gtk.set win [ Gtk.containerChild := vbox ]
Gtk.widgetShowAll win
Gtk.mainGUI