Merge pull request #7 from bradrn/main

Kleidukos · Jun 16, 2023 · b66e93d · b66e93d
2 parents 8641afa + 239c017
commit b66e93d
Show file tree

Hide file tree

Showing 3 changed files with 79 additions and 52 deletions.
diff --git a/src/UI.hs b/src/UI.hs
@@ -30,8 +30,8 @@ main = do
   progName <- getProgName
   void (app.run $ Just $ progName : args)
 
-tools :: Adw.ToastOverlay -> IO Gtk.ListBox
-tools toastOverlay = do
+tools :: Adw.ToastOverlay -> Adw.ApplicationWindow -> IO Gtk.ListBox
+tools toastOverlay app = do
   toolsList <- new Gtk.ListBox [#showSeparators := True]
 
   ghcRow <-
@@ -55,13 +55,13 @@ tools toastOverlay = do
       , #expanded := True
       ]
 
-  compilers <- getGHCVersions toastOverlay
+  compilers <- getGHCVersions toastOverlay app
   traverse_ (expanderRowAddRow ghcRow) compilers
 
-  cabalVersions <- getCabalVersions toastOverlay
+  cabalVersions <- getCabalVersions toastOverlay app
   traverse_ (expanderRowAddRow cabalRow) cabalVersions
 
-  hlsVersions <- getHLSVersions toastOverlay
+  hlsVersions <- getHLSVersions toastOverlay app
   traverse_ (expanderRowAddRow hlsRow) hlsVersions
 
   toolsList.append ghcRow
@@ -72,30 +72,30 @@ tools toastOverlay = do
 
 activate :: Adw.Application -> IO ()
 activate app = do
-  let ?self = app
+  window <-
+    new
+      Adw.ApplicationWindow
+      [ #application := app
+      , #defaultWidth := 400
+      , #title := "Haskell Toolchain Installer"
+      ]
+
   content <- new Gtk.Box [#orientation := Gtk.OrientationVertical]
-  titlebar <- genHeaderbar
+  titlebar <- let ?self = app in genHeaderbar
   content.append titlebar
 
   toastOverlay <- new Adw.ToastOverlay []
 
-  toolsContainer <- tools toastOverlay
+  toolsContainer <- tools toastOverlay window
   content.append toolsContainer
   content.append toastOverlay
 
+  set window [#content := content]
+
   -- menuUI <- Text.readFile "./ui/menu.ui"
   -- builder <- Gtk.builderNewFromString menuUI (-1)
   -- menu <- getCastedObjectFromBuilder builder "menu" Gio.MenuModel
 
-  window <-
-    new
-      Adw.ApplicationWindow
-      [ #application := app
-      , #content := content
-      , #defaultWidth := 400
-      , #title := "Haskell Toolchain Installer"
-      ]
-
   window.present
 castWOMaybe :: forall o o'. (GObject o, GObject o') => (ManagedPtr o' -> o') -> o -> IO o'
 castWOMaybe typeToCast obj = castTo typeToCast obj <&> fromJust

diff --git a/src/UI/Compiler.hs b/src/UI/Compiler.hs
@@ -7,8 +7,8 @@ import GI.Gtk qualified as Gtk
 
 import UI.Install
 
-getGHCVersions :: Adw.ToastOverlay -> IO [Adw.ActionRow]
-getGHCVersions toastOverlay = traverse (toActionRow toastOverlay) compilerList
+getGHCVersions :: Adw.ToastOverlay -> Adw.ApplicationWindow -> IO [Adw.ActionRow]
+getGHCVersions toastOverlay app = traverse (toActionRow toastOverlay app "GHC") compilerList
   where
     compilerList =
       [ "9.4.3 (latest)"
@@ -17,36 +17,36 @@ getGHCVersions toastOverlay = traverse (toActionRow toastOverlay) compilerList
       , "8.10.7"
       ]
 
-getCabalVersions :: Adw.ToastOverlay -> IO [Adw.ActionRow]
-getCabalVersions toastOverlay = traverse (toActionRow toastOverlay) cabalVersions
+getCabalVersions :: Adw.ToastOverlay -> Adw.ApplicationWindow -> IO [Adw.ActionRow]
+getCabalVersions toastOverlay app = traverse (toActionRow toastOverlay app "Cabal") cabalVersions
   where
     cabalVersions =
       [ "3.8.1.0 (latest)"
       , "3.6.2.0"
       ]
 
-getHLSVersions :: Adw.ToastOverlay -> IO [Adw.ActionRow]
-getHLSVersions toastOverlay = traverse (toActionRow toastOverlay) hlsVersions
+getHLSVersions :: Adw.ToastOverlay -> Adw.ApplicationWindow -> IO [Adw.ActionRow]
+getHLSVersions toastOverlay app = traverse (toActionRow toastOverlay app "HLS") hlsVersions
   where
     hlsVersions =
       [ "1.8.0.0 (latest)"
       , "1.7.0.0"
       ]
 
-toActionRow :: Adw.ToastOverlay -> Text -> IO Adw.ActionRow
-toActionRow toastOverlay compilerLabel = do
+toActionRow :: Adw.ToastOverlay -> Adw.ApplicationWindow -> Text -> Text -> IO Adw.ActionRow
+toActionRow toastOverlay app toolLabel versionLabel = do
   installButton <-
     new
       Gtk.Switch
       [ #valign := Gtk.AlignCenter
       ]
   on installButton #stateSet $ \state -> do
-    mockInstall toastOverlay state
+    mockInstall installButton toastOverlay app state (toolLabel <> " " <> versionLabel)
 
   actionRow <-
     new
       Adw.ActionRow
-      [ #title := compilerLabel
+      [ #title := versionLabel
       ]
 
   -- setToggle <- new Gtk.CheckButton

diff --git a/src/UI/Install.hs b/src/UI/Install.hs
@@ -1,31 +1,58 @@
-{-# LANGUAGE ImplicitParams #-}
-
 module UI.Install where
 
+import Control.Monad (when)
 import Data.GI.Base
+import Data.Text (Text)
 import GI.Adw qualified as Adw
 import GI.Gtk qualified as Gtk
 
-mockInstall :: (?self :: Gtk.Switch) => Adw.ToastOverlay -> Bool -> IO Bool
-mockInstall toastOverlay state = do
-  if state
-    then do
-      notificationToast <-
-        new
-          Adw.Toast
-          [ #title := "Installing…"
-          , #timeout := 3
-          ]
-      Adw.toastOverlayAddToast toastOverlay notificationToast
-      set ?self [#state := state]
-      pure True
-    else do
-      notificationToast <-
-        new
-          Adw.Toast
-          [ #title := "Uninstalling…"
-          , #timeout := 3
-          ]
-      Adw.toastOverlayAddToast toastOverlay notificationToast
-      set ?self [#state := state]
-      pure True
+mockInstall :: Gtk.Switch -> Adw.ToastOverlay -> Adw.ApplicationWindow -> Bool -> Text -> IO Bool
+mockInstall selfSwitch toastOverlay app state toolDescription = do
+  curState <- selfSwitch.getState
+  -- don't handle case when state is being reset: e.g. when 'Cancel'
+  -- button is pressed on message box
+  (True <$) $ when (curState /= state) $ do
+    let stateText = if state then "install" else "uninstall"
+        stateTextUpper = if state then "Install" else "Uninstall"
+        messageText =
+          "Are you sure you want to "
+            <> stateText
+            <> " "
+            <> toolDescription
+            <> "?"
+
+    messageDialog <-
+      Adw.messageDialogNew
+        (Just app)
+        (Just $ "Confirm " <> stateText)
+        (Just messageText)
+    messageDialog.addResponse "cancel" "Cancel"
+    messageDialog.addResponse "doit" stateTextUpper
+
+    messageDialog.setResponseAppearance "doit" Adw.ResponseAppearanceDestructive
+    messageDialog.setDefaultResponse (Just "cancel")
+    messageDialog.setCloseResponse "cancel"
+
+    on messageDialog #response $ \case
+      "doit" ->
+        if state
+          then do
+            notificationToast <-
+              new
+                Adw.Toast
+                [ #title := "Installing…"
+                , #timeout := 3
+                ]
+            Adw.toastOverlayAddToast toastOverlay notificationToast
+            set selfSwitch [#state := state]
+          else do
+            notificationToast <-
+              new
+                Adw.Toast
+                [ #title := "Uninstalling…"
+                , #timeout := 3
+                ]
+            Adw.toastOverlayAddToast toastOverlay notificationToast
+            set selfSwitch [#state := state]
+      _ -> set selfSwitch [#active := not state] -- reset position
+    messageDialog.present