From c7eceb233077047ce94b79c97bd5a2be1e4b1e4e Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sat, 25 Jun 2022 13:44:25 +0530 Subject: [PATCH 01/11] Adds GHCup.Prompt modules and its types to project --- ghcup.cabal | 2 ++ lib/GHCup/Prompts.hs | 20 ++++++++++++++++++++ lib/GHCup/Types/Prompts.hs | 8 ++++++++ 3 files changed, 30 insertions(+) create mode 100644 lib/GHCup/Prompts.hs create mode 100644 lib/GHCup/Types/Prompts.hs diff --git a/ghcup.cabal b/ghcup.cabal index c2094ea..3e51465 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -69,12 +69,14 @@ library GHCup.Prelude.Process GHCup.Prelude.String.QQ GHCup.Prelude.Version.QQ + GHCup.Prompts GHCup.Requirements GHCup.Stack GHCup.Types GHCup.Types.JSON GHCup.Types.JSON.Utils GHCup.Types.Optics + GHCup.Types.Prompts GHCup.Utils GHCup.Utils.Dirs GHCup.Version diff --git a/lib/GHCup/Prompts.hs b/lib/GHCup/Prompts.hs new file mode 100644 index 0000000..c1f537d --- /dev/null +++ b/lib/GHCup/Prompts.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module GHCup.Prompts + (module GHCup.Types.Prompts, + getUserPromptResponse) +where + +import GHCup.Types.Prompts +import qualified Data.Text.IO as TIO +import Control.Monad.IO.Class (MonadIO, liftIO) + +putPrompt :: MonadIO m => PromptQuestion -> m () +putPrompt prompt = liftIO $ TIO.putStrLn prompt + +getUserPromptResponse :: (MonadIO m) => PromptQuestion -> m PromptResponse +getUserPromptResponse prompt = do + putPrompt prompt + resp <- liftIO TIO.getLine + if resp `elem` ["YES", "yes", "y", "Y"] + then pure PromptYes + else pure PromptNo diff --git a/lib/GHCup/Types/Prompts.hs b/lib/GHCup/Types/Prompts.hs new file mode 100644 index 0000000..a2e753c --- /dev/null +++ b/lib/GHCup/Types/Prompts.hs @@ -0,0 +1,8 @@ +module GHCup.Types.Prompts where + +import Data.Text (Text) + +type PromptQuestion = Text + +data PromptResponse = PromptYes | PromptNo + deriving (Show, Eq) From 0e1fd68d9335ba16509008967e7fd8e5bc04a0c3 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sat, 25 Jun 2022 13:45:07 +0530 Subject: [PATCH 02/11] when setting an uninstalled tool in tui, asks user to install first --- app/ghcup/BrickMain.hs | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 1c3b323..ed2e652 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -17,6 +17,7 @@ import GHCup.Prelude ( decUTF8Safe ) import GHCup.Prelude.File import GHCup.Prelude.Logger import GHCup.Prelude.Process +import GHCup.Prompts import Brick import Brick.Widgets.Border @@ -98,7 +99,7 @@ keyHandlers KeyBindings {..} = [ (bQuit, const "Quit" , halt) , (bInstall, const "Install" , withIOAction install') , (bUninstall, const "Uninstall", withIOAction del') - , (bSet, const "Set" , withIOAction ((liftIO .) . set')) + , (bSet, const "Set" , withIOAction set') , (bChangelog, const "ChangeLog", withIOAction changelog') , ( bShowAllVersions , \BrickSettings {..} -> @@ -486,9 +487,13 @@ install' _ (_, ListResult {..}) = do <> "Also check the logs in ~/.ghcup/logs" -set' :: BrickState -> (Int, ListResult) -> IO (Either String ()) -set' _ (_, ListResult {..}) = do - settings <- readIORef settings' +set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) + => BrickState + -> (Int, ListResult) + -> m (Either String ()) + +set' bs input@(_, ListResult {..}) = do + settings <- liftIO $ readIORef settings' let run = flip runReaderT settings @@ -504,7 +509,16 @@ set' _ (_, ListResult {..}) = do ) >>= \case VRight _ -> pure $ Right () - VLeft e -> pure $ Left (prettyShow e) + VLeft e -> case e of + (V (NotInstalled tool tver)) -> do + promptAnswer <- liftIO $ getUserPromptResponse userPrompt + case promptAnswer of + PromptYes -> install' bs input + PromptNo -> pure $ Left (prettyShow e) + where + userPrompt = "The tool/version you're trying to set is not installed, would you like to install it first? " + _ -> pure $ Left (prettyShow e) + del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) From b8dac2d7cd6d1aff8309df44a6399df9304734e3 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 28 Jun 2022 19:45:17 +0530 Subject: [PATCH 03/11] Updates the Prompt module to use logInfo instead of putStrLn, makes the prompt look prettier --- lib/GHCup/Prompts.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/lib/GHCup/Prompts.hs b/lib/GHCup/Prompts.hs index c1f537d..08bed33 100644 --- a/lib/GHCup/Prompts.hs +++ b/lib/GHCup/Prompts.hs @@ -1,17 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + module GHCup.Prompts - (module GHCup.Types.Prompts, - getUserPromptResponse) + ( module GHCup.Types.Prompts, + getUserPromptResponse, + ) where -import GHCup.Types.Prompts +import Control.Monad.Reader import qualified Data.Text.IO as TIO -import Control.Monad.IO.Class (MonadIO, liftIO) +import GHCup.Prelude.Logger +import GHCup.Types.Optics +import GHCup.Types.Prompts -putPrompt :: MonadIO m => PromptQuestion -> m () -putPrompt prompt = liftIO $ TIO.putStrLn prompt +putPrompt :: (HasLog env, MonadReader env m, MonadIO m) + => PromptQuestion + -> m () +putPrompt prompt = logInfo prompt -getUserPromptResponse :: (MonadIO m) => PromptQuestion -> m PromptResponse +getUserPromptResponse :: ( HasLog env + , MonadReader env m + , MonadIO m) + => PromptQuestion + -> m PromptResponse getUserPromptResponse prompt = do putPrompt prompt resp <- liftIO TIO.getLine From 3bbc1edb198505c8b2ea4deb0b30dae7f5fea2a6 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 28 Jun 2022 19:49:00 +0530 Subject: [PATCH 04/11] updates user prompt message for "set" uninstalled version in BrickMain --- app/ghcup/BrickMain.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index ed2e652..1c75d1d 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -53,6 +53,8 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import URI.ByteString import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy as L import qualified Graphics.Vty as Vty import qualified Data.Vector as V import System.Environment (getExecutablePath) @@ -510,13 +512,18 @@ set' bs input@(_, ListResult {..}) = do >>= \case VRight _ -> pure $ Right () VLeft e -> case e of - (V (NotInstalled tool tver)) -> do - promptAnswer <- liftIO $ getUserPromptResponse userPrompt + (V (NotInstalled tool _)) -> do + promptAnswer <- getUserPromptResponse userPrompt case promptAnswer of PromptYes -> install' bs input PromptNo -> pure $ Left (prettyShow e) where - userPrompt = "The tool/version you're trying to set is not installed, would you like to install it first? " + userPrompt = L.toStrict $ + B.toLazyText $ + B.fromString " This Version of " <> + B.fromString (show tool) <> + B.fromString " you are trying to set is not installed.\n" <> + B.fromString " Would you like to install it first? [Y/N]: " _ -> pure $ Left (prettyShow e) From 7cbe38b01143c7a3bdb4f55b5b5f23692ceba62d Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 28 Jun 2022 19:50:22 +0530 Subject: [PATCH 05/11] Behavior Enhancement: make user press "S" only once to set, asks to install AND set if tool uninstalled --- app/ghcup/BrickMain.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 1c75d1d..cb1b83d 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -515,7 +515,14 @@ set' bs input@(_, ListResult {..}) = do (V (NotInstalled tool _)) -> do promptAnswer <- getUserPromptResponse userPrompt case promptAnswer of - PromptYes -> install' bs input + PromptYes -> do + res <- install' bs input + case res of + (Left err) -> pure $ Left (prettyShow err) + (Right _) -> do + logInfo "Setting now..." + set' bs input + PromptNo -> pure $ Left (prettyShow e) where userPrompt = L.toStrict $ From 9ceb66ef210d3c9e6562331d47f051192d94dda0 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 28 Jun 2022 22:10:02 +0530 Subject: [PATCH 06/11] chore: fix a hlint warning --- lib/GHCup/Prompts.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/GHCup/Prompts.hs b/lib/GHCup/Prompts.hs index 08bed33..5536ad7 100644 --- a/lib/GHCup/Prompts.hs +++ b/lib/GHCup/Prompts.hs @@ -16,7 +16,7 @@ import GHCup.Types.Prompts putPrompt :: (HasLog env, MonadReader env m, MonadIO m) => PromptQuestion -> m () -putPrompt prompt = logInfo prompt +putPrompt = logInfo getUserPromptResponse :: ( HasLog env , MonadReader env m From 0acccae5233243a4fc2a9cfd06253a55297c209d Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 10 Jul 2022 09:44:23 +0530 Subject: [PATCH 07/11] Removes `GHCup.Types.Prompts` module and stuffs it into `GHCup.Types` --- ghcup.cabal | 1 - lib/GHCup/Prompts.hs | 4 ++-- lib/GHCup/Types.hs | 9 +++------ lib/GHCup/Types/Prompts.hs | 8 -------- 4 files changed, 5 insertions(+), 17 deletions(-) delete mode 100644 lib/GHCup/Types/Prompts.hs diff --git a/ghcup.cabal b/ghcup.cabal index 3e51465..fafa47f 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -76,7 +76,6 @@ library GHCup.Types.JSON GHCup.Types.JSON.Utils GHCup.Types.Optics - GHCup.Types.Prompts GHCup.Utils GHCup.Utils.Dirs GHCup.Version diff --git a/lib/GHCup/Prompts.hs b/lib/GHCup/Prompts.hs index 5536ad7..c06fcd1 100644 --- a/lib/GHCup/Prompts.hs +++ b/lib/GHCup/Prompts.hs @@ -2,7 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} module GHCup.Prompts - ( module GHCup.Types.Prompts, + ( PromptQuestion, + PromptResponse (..), getUserPromptResponse, ) where @@ -11,7 +12,6 @@ import Control.Monad.Reader import qualified Data.Text.IO as TIO import GHCup.Prelude.Logger import GHCup.Types.Optics -import GHCup.Types.Prompts putPrompt :: (HasLog env, MonadReader env m, MonadIO m) => PromptQuestion diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 63761d2..bb0ae8f 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -654,10 +654,7 @@ isSafeDir (IsolateDirResolved _) = False isSafeDir (GHCupDir _) = True isSafeDir (GHCupBinDir _) = False +type PromptQuestion = Text - - - - - - +data PromptResponse = PromptYes | PromptNo + deriving (Show, Eq) diff --git a/lib/GHCup/Types/Prompts.hs b/lib/GHCup/Types/Prompts.hs deleted file mode 100644 index a2e753c..0000000 --- a/lib/GHCup/Types/Prompts.hs +++ /dev/null @@ -1,8 +0,0 @@ -module GHCup.Types.Prompts where - -import Data.Text (Text) - -type PromptQuestion = Text - -data PromptResponse = PromptYes | PromptNo - deriving (Show, Eq) From 2bd5a8fe1ac51a3a2b0801e18cf9216e3c63619b Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 10 Jul 2022 09:45:39 +0530 Subject: [PATCH 08/11] Removes redundant `putPrompt` function from Prompts module. --- lib/GHCup/Prompts.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/lib/GHCup/Prompts.hs b/lib/GHCup/Prompts.hs index c06fcd1..2b60845 100644 --- a/lib/GHCup/Prompts.hs +++ b/lib/GHCup/Prompts.hs @@ -12,19 +12,16 @@ import Control.Monad.Reader import qualified Data.Text.IO as TIO import GHCup.Prelude.Logger import GHCup.Types.Optics - -putPrompt :: (HasLog env, MonadReader env m, MonadIO m) - => PromptQuestion - -> m () -putPrompt = logInfo +import GHCup.Types (PromptQuestion, PromptResponse(..)) getUserPromptResponse :: ( HasLog env , MonadReader env m , MonadIO m) => PromptQuestion -> m PromptResponse + getUserPromptResponse prompt = do - putPrompt prompt + logInfo prompt resp <- liftIO TIO.getLine if resp `elem` ["YES", "yes", "y", "Y"] then pure PromptYes From e9740d13fc05b38351c110ae1a8c90a02e1b2e90 Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 10 Jul 2022 09:50:58 +0530 Subject: [PATCH 09/11] Updates `userPrompt` in BrickMain to a more efficient version --- app/ghcup/BrickMain.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index cb1b83d..7f80e12 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -525,12 +525,12 @@ set' bs input@(_, ListResult {..}) = do PromptNo -> pure $ Left (prettyShow e) where - userPrompt = L.toStrict $ - B.toLazyText $ - B.fromString " This Version of " <> - B.fromString (show tool) <> - B.fromString " you are trying to set is not installed.\n" <> - B.fromString " Would you like to install it first? [Y/N]: " + userPrompt = L.toStrict . B.toLazyText . B.fromString $ + "This Version of " + <> show tool + <> " you are trying to set is not installed.\n" + <> "Would you like to install it first? [Y/N]: " + _ -> pure $ Left (prettyShow e) From 3d49f79bebeb6503a7b227520b8f135d0578fc7b Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 10 Jul 2022 09:52:57 +0530 Subject: [PATCH 10/11] removes `prettyShow` from error case in BrickMain set' --- app/ghcup/BrickMain.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 7f80e12..81cfd22 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -518,7 +518,7 @@ set' bs input@(_, ListResult {..}) = do PromptYes -> do res <- install' bs input case res of - (Left err) -> pure $ Left (prettyShow err) + (Left err) -> pure $ Left err (Right _) -> do logInfo "Setting now..." set' bs input From ca5c5550ab468e56c19c53104c5d4153b1d6693f Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Sun, 10 Jul 2022 21:49:54 +0530 Subject: [PATCH 11/11] removes newline after set' function --- app/ghcup/BrickMain.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 81cfd22..4edad3a 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -493,7 +493,6 @@ set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask => BrickState -> (Int, ListResult) -> m (Either String ()) - set' bs input@(_, ListResult {..}) = do settings <- liftIO $ readIORef settings'