Add a button / hook for reverting to default settings

ghorn · Mar 31, 2021 · c181d5a · c181d5a
1 parent e9cedec
commit c181d5a
Showing 1 changed file with 15 additions and 2 deletions.
diff --git a/src/SetHo.hs b/src/SetHo.hs
@@ -39,8 +39,8 @@ defaultSetHoConfig =
   }
 
 -- | fire up the the GUI
-runSetter :: Maybe SetHoConfig -> String -> DTree -> IO (Maybe (Int, DTree)) -> (Int -> IO ()) -> (Int -> DTree -> IO ()) -> IO ()
-runSetter mconfig rootName initialValue userPollForNewMessage sendRequest userCommit = do
+runSetter :: Maybe SetHoConfig -> String -> DTree -> IO (Maybe (Int, DTree)) -> (Int -> IO ()) -> (Int -> DTree -> IO ()) -> (Int -> DTree -> IO ()) -> IO ()
+runSetter mconfig rootName initialValue userPollForNewMessage sendRequest userCommit userRevertToDefaults = do
   let config = case mconfig of
         Just r -> r
         Nothing -> defaultSetHoConfig
@@ -100,6 +100,7 @@ runSetter mconfig rootName initialValue userPollForNewMessage sendRequest userCo
   buttonCommit <- Gtk.buttonNewWithLabel "commit"
   buttonRefresh <- Gtk.buttonNewWithLabel "refresh"
   buttonTakeUpstream <- Gtk.buttonNewWithLabel "take upstream"
+  buttonRevertToDefaults <- Gtk.buttonNewWithLabel "revert to defaults"
   Gtk.widgetSetTooltipText buttonCommit
     (Just "SET ME SET ME GO HEAD DO IT COME ON SET ME")
   buttonDiff <- Gtk.buttonNewWithLabel "diff"
@@ -127,6 +128,13 @@ runSetter mconfig rootName initialValue userPollForNewMessage sendRequest userCo
         makeStatsMessage >>= Gtk.labelSetText statsLabel
         userCommit counter val
 
+  let revertToDefaults val = do
+        counter <- readIORef counterRef
+        putStrLn $ "sending revert-to-default message " ++ show counter
+        writeIORef counterRef $ 1 + counter
+        makeStatsMessage >>= Gtk.labelSetText statsLabel
+        userRevertToDefaults counter val
+
   -- the signal selector
   let getAutoCommitStatus = case mbuttonAutoCommit of
         Nothing -> return False
@@ -176,6 +184,8 @@ runSetter mconfig rootName initialValue userPollForNewMessage sendRequest userCo
     , Gtk.boxChildPacking buttonTakeUpstream := Gtk.PackNatural
     , Gtk.containerChild := buttonDiff
     , Gtk.boxChildPacking buttonDiff := Gtk.PackNatural
+    , Gtk.containerChild := buttonRevertToDefaults
+    , Gtk.boxChildPacking buttonRevertToDefaults := Gtk.PackNatural
     , Gtk.containerChild := options
     , Gtk.boxChildPacking options := Gtk.PackNatural
     , Gtk.containerChild := treeviewExpander
@@ -194,6 +204,9 @@ runSetter mconfig rootName initialValue userPollForNewMessage sendRequest userCo
 
   _ <- on buttonDiff Gtk.buttonActivated printDiff
 
+  _ <- on buttonRevertToDefaults Gtk.buttonActivated
+       ((getLatestStaged >>= revertToDefaults) *> takeLatestUpstream)
+
   let pollForNewMessage = do
         mmsg <- userPollForNewMessage
         case mmsg of