Merge remote-tracking branch 'origin/pr/1090'

lib-tui/GHCup/Brick/Actions.hs

@@ -501,15 +501,20 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do
                   ]
   compileResult <- run (do
       AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-      let vi = getVersionInfo (mkTVer lVer) GHC dls
-      forM_ (_viPreCompile =<< vi) $ \msg -> do
-        logInfo msg
-        logInfo
-          "...waiting for 5 seconds, you can still abort..."
-        liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+      ghcVer <- case compopts ^. CompileGHC.gitRef of
+        Just ref -> pure (GHC.GitDist (GitBranch ref Nothing))
+        Nothing -> do
+          -- Compile the version user is pointing to in the tui
+          let vi = getVersionInfo (mkTVer lVer) GHC dls
+          forM_ (_viPreCompile =<< vi) $ \msg -> do
+            logInfo msg
+            logInfo
+              "...waiting for 5 seconds, you can still abort..."
+            liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+          pure (GHC.SourceDist lVer)
 
       targetVer <- liftE $ GHCup.compileGHC
-                    (GHC.SourceDist lVer)
+                    ghcVer
                     (compopts ^. CompileGHC.crossTarget)
                     (compopts ^. CompileGHC.overwriteVer)
                     (compopts ^. CompileGHC.bootstrapGhc)
@@ -584,18 +589,23 @@ compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do
                   ]
   compileResult <- run (do
       AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-      let vi = getVersionInfo (mkTVer lVer) GHC dls
-      forM_ (_viPreCompile =<< vi) $ \msg -> do
-        logInfo msg
-        logInfo
-          "...waiting for 5 seconds, you can still abort..."
-        liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+      hlsVer <- case compopts ^. CompileHLS.gitRef of
+        Just ref -> pure (HLS.GitDist (GitBranch ref Nothing))
+        Nothing -> do
+          -- Compile the version user is pointing to in the tui
+          let vi = getVersionInfo (mkTVer lVer) HLS dls
+          forM_ (_viPreCompile =<< vi) $ \msg -> do
+            logInfo msg
+            logInfo
+              "...waiting for 5 seconds, you can still abort..."
+            liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
+          pure (HLS.SourceDist lVer)
 
       ghcs <-
         liftE $ forM (compopts ^. CompileHLS.targetGHCs)
                      (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) $ GHC)
       targetVer <- liftE $ GHCup.compileHLS
-                      (HLS.SourceDist lVer)
+                      hlsVer
                       ghcs
                       (compopts ^. CompileHLS.jobs)
                       (compopts ^. CompileHLS.overwriteVer)

lib-tui/GHCup/Brick/App.hs

@@ -147,7 +147,8 @@ advanceInstallHandler ev = do
     (VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods -> mode .= ContextPanel
     (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
         let iopts = ctx ^. Menu.menuStateL
-        Actions.withIOAction $ Actions.installWithOptions iopts
+        when (Menu.isValidMenu ctx) $
+          Actions.withIOAction $ Actions.installWithOptions iopts
     _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev
 
 compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState ()

lib-tui/GHCup/Brick/Common.hs

@@ -47,7 +47,7 @@ module GHCup.Brick.Common  (
     , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox
     , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton
     , CompileGHCButton, CompileHLSButton, CabalProjectEditBox
-    , CabalProjectLocalEditBox, UpdateCabalCheckBox
+    , CabalProjectLocalEditBox, UpdateCabalCheckBox, GitRefEditBox
   ) ) where
 
 import           GHCup.List ( ListResult )
@@ -121,6 +121,8 @@ pattern CabalProjectLocalEditBox  = ResourceId 17
 pattern UpdateCabalCheckBox  :: ResourceId
 pattern UpdateCabalCheckBox  = ResourceId 18
 
+pattern GitRefEditBox  :: ResourceId
+pattern GitRefEditBox  = ResourceId 19
 
 -- | Name data type. Uniquely identifies each widget in the TUI.
 -- some constructors might end up unused, but still is a good practise

lib-tui/GHCup/Brick/Widgets/Menu.hs

@@ -286,24 +286,27 @@ data Menu s n
     = Menu
     { menuFields    :: [MenuField s n]   -- ^ The datatype representing the list of entries. Precisely, any array-like data type is highly unconvinient.
     , menuState     :: s
+    , menuValidator :: s -> Maybe ErrorMessage  -- ^ A validator function
     , menuButtons   :: [Button s n]      -- ^ The buttons. Commonly, the handlers for buttons are defined outside the menu handler.
     , menuFocusRing :: FocusRing n       -- ^ The focus ring with the resource name for each entry and each button, in the order you want to loop them.
     , menuExitKey   :: KeyCombination    -- ^ The key to exit the Menu
     , menuName      :: n                 -- ^ The resource Name.
     }
 
 makeLensesFor
-  [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL")
+  [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL"), ("menuValidator", "menuValidatorL")
   , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL")
   , ("menuExitKey", "menuExitKeyL"), ("menuName", "menuNameL")
   ]
   ''Menu
 
 isValidMenu :: Menu s n -> Bool
-isValidMenu = all isValidField . menuFields
+isValidMenu m = (all isValidField $ menuFields m)
+  && (case (menuValidator m) (menuState m) of { Nothing -> True; _ -> False })
 
-createMenu :: n -> s -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n
-createMenu n initial exitK buttons fields = Menu fields initial buttons ring exitK n
+createMenu :: n -> s -> (s -> Maybe ErrorMessage)
+  -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n
+createMenu n initial validator exitK buttons fields = Menu fields initial validator buttons ring exitK n
   where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons]
 
 handlerMenu :: forall n e s. Eq n => BrickEvent n e -> EventM n (Menu s n) ()
@@ -320,8 +323,12 @@ handlerMenu ev =
         Nothing -> pure ()
         Just n  -> do
           updated_fields <- updateFields n (VtyEvent e) fields
+          validator  <- use menuValidatorL
+          state <- use menuStateL
           if all isValidField updated_fields
-            then menuButtonsL %= fmap (fieldStatusL .~ Valid)
+            then case validator state of
+              Nothing -> menuButtonsL %= fmap (fieldStatusL .~ Valid)
+              Just err -> menuButtonsL %= fmap (fieldStatusL .~ Invalid err)
             else menuButtonsL %= fmap (fieldStatusL .~ Invalid "Some fields are invalid")
           menuFieldsL .= updated_fields
     _ -> pure ()
@@ -372,5 +379,3 @@ drawMenu menu =
        in fmap (\f b -> ((leftify (maxWidth + 2) . Border.border $ f b) <+>) ) buttonAsWidgets
     drawButtons = fmap drawField buttonAmplifiers
     buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL)
-
-

lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs

@@ -66,9 +66,12 @@ makeLensesFor [
 type AdvanceInstallMenu = Menu InstallOptions Name
 
 create :: KeyCombination -> AdvanceInstallMenu
-create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields
+create k = Menu.createMenu AdvanceInstallBox initialState validator k [ok] fields
   where
     initialState = InstallOptions Nothing False Nothing False []
+    validator InstallOptions {..} = case (instSet, isolateDir) of
+      (True, Just _) -> Just "Cannot set active when doing an isolated install"
+      _ -> Nothing
     -- Brick's internal editor representation is [mempty].
     emptyEditor i = T.null i || (i == "\n")
 

lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs

@@ -31,6 +31,7 @@ module GHCup.Brick.Widgets.Menus.CompileGHC (
   buildFlavour,
   buildSystem,
   isolateDir,
+  gitRef,
 ) where
 
 import GHCup.Brick.Widgets.Menu (Menu)
@@ -69,14 +70,15 @@ data CompileGHCOptions = CompileGHCOptions
   , _buildFlavour :: Maybe String
   , _buildSystem  :: Maybe BuildSystem
   , _isolateDir   :: Maybe FilePath
+  , _gitRef       :: Maybe String
   } deriving (Eq, Show)
 
 makeLenses ''CompileGHCOptions
 
 type CompileGHCMenu = Menu CompileGHCOptions Name
 
 create :: KeyCombination -> CompileGHCMenu
-create k = Menu.createMenu CompileGHCBox initialState k buttons fields
+create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields
   where
     initialState =
       CompileGHCOptions
@@ -91,6 +93,12 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
         Nothing
         Nothing
         Nothing
+        Nothing
+    validator CompileGHCOptions {..} = case (_setCompile, _isolateDir) of
+      (True, Just _) -> Just "Cannot set active when doing an isolated install"
+      _ -> case (_buildConfig, _buildSystem) of
+        (Just _, Just Hadrian) -> Just "Build config can be specified only for make build system"
+        _ -> Nothing
     -- Brick's internal editor representation is [mempty].
     emptyEditor i = T.null i || (i == "\n")
     whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a
@@ -150,33 +158,36 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
       , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs
           & Menu.fieldLabelL .~ "jobs"
           & Menu.fieldHelpMsgL .~ "How many jobs to use for make"
+      , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
+          & Menu.fieldLabelL .~ "set"
+          & Menu.fieldHelpMsgL .~ "Set as active version after install"
+      , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour
+          & Menu.fieldLabelL .~ "flavour"
+          & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
+      , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs
+          & Menu.fieldLabelL .~ "CONFIGURE_ARGS"
+          & Menu.fieldHelpMsgL .~ "Additional arguments to compile configure"
       , Menu.createEditableField (Common.MenuElement Common.BuildConfigEditBox) filepathV buildConfig
           & Menu.fieldLabelL .~ "build config"
-          & Menu.fieldHelpMsgL .~ "Absolute path to build config file"
+          & Menu.fieldHelpMsgL .~ "Absolute path to build config file (make build system only)"
       , Menu.createEditableField (Common.MenuElement Common.PatchesEditBox) patchesV patches
           & Menu.fieldLabelL .~ "patches"
           & Menu.fieldHelpMsgL .~ "Either a URI to a patch (https/http/file) or Absolute path to patch directory"
       , Menu.createEditableField (Common.MenuElement Common.CrossTargetEditBox) (Right . Just) crossTarget
           & Menu.fieldLabelL .~ "cross target"
           & Menu.fieldHelpMsgL .~ "Build cross-compiler for this platform"
-      , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs
-          & Menu.fieldLabelL .~ "CONFIGURE_ARGS"
-          & Menu.fieldHelpMsgL .~ "Additional arguments to compile configure"
-      , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
-          & Menu.fieldLabelL .~ "set"
-          & Menu.fieldHelpMsgL .~ "Set as active version after install"
-      , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV overwriteVer
-          & Menu.fieldLabelL .~ "overwrite-version"
-          & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
       , Menu.createEditableField (Common.MenuElement Common.BuildSystemEditBox) systemV buildSystem
           & Menu.fieldLabelL .~ "build system"
           & Menu.fieldHelpMsgL .~ "either 'make' or 'hadrian'"
-      , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour
-          & Menu.fieldLabelL .~ "flavour"
-          & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
+      , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV overwriteVer
+          & Menu.fieldLabelL .~ "overwrite-version"
+          & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
       , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir
           & Menu.fieldLabelL .~ "isolated"
           & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one"
+      , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef
+          & Menu.fieldLabelL .~ "git-ref"
+          & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from"
       ]
 
     buttons = [

lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs

@@ -30,6 +30,7 @@ module GHCup.Brick.Widgets.Menus.CompileHLS (
   patches,
   targetGHCs,
   cabalArgs,
+  gitRef,
 )
 where
 
@@ -65,14 +66,15 @@ data CompileHLSOptions = CompileHLSOptions
   , _patches      :: Maybe (Either FilePath [URI])
   , _targetGHCs   :: [ToolVersion]
   , _cabalArgs    :: [T.Text]
+  , _gitRef       :: Maybe String
   } deriving (Eq, Show)
 
 makeLenses ''CompileHLSOptions
 
 type CompileHLSMenu = Menu CompileHLSOptions Name
 
 create :: KeyCombination -> CompileHLSMenu
-create k = Menu.createMenu CompileGHCBox initialState k buttons fields
+create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields
   where
     initialState =
       CompileHLSOptions
@@ -86,6 +88,13 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
         Nothing
         []
         []
+        Nothing
+
+    validator CompileHLSOptions {..} = case (_setCompile, _isolateDir) of
+      (True, Just _) -> Just "Cannot set active when doing an isolated install"
+      _ -> if null _targetGHCs
+        then Just "Specify at least one valid target GHC"
+        else Nothing
     -- Brick's internal editor representation is [mempty].
     emptyEditor i = T.null i || (i == "\n")
     whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a
@@ -139,8 +148,8 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
           & Menu.fieldLabelL .~ "jobs"
           & Menu.fieldHelpMsgL .~ "How many jobs to use for make"
       , Menu.createEditableField (Common.MenuElement Common.TargetGhcEditBox) ghcVersionTagEither targetGHCs
-          & Menu.fieldLabelL .~ "target GHC"
-          & Menu.fieldHelpMsgL .~ "For which GHC version to compile for (can be specified multiple times)"
+          & Menu.fieldLabelL .~ "target GHC(s)"
+          & Menu.fieldHelpMsgL .~ "space separated list of GHC versions to compile for"
       , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
           & Menu.fieldLabelL .~ "set"
           & Menu.fieldHelpMsgL .~ "Set as active version after install"
@@ -162,6 +171,9 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
       , Menu.createEditableField (Common.MenuElement Common.CabalProjectLocalEditBox) cabalProjectLocalV cabalProjectLocal
           & Menu.fieldLabelL .~ "cabal project local"
           & Menu.fieldHelpMsgL .~ "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
+      , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef
+          & Menu.fieldLabelL .~ "git-ref"
+          & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from"
       ]
 
     buttons = [

lib-tui/GHCup/Brick/Widgets/Menus/Context.hs

@@ -29,7 +29,7 @@ import Data.Foldable (foldl')
 type ContextMenu = Menu ListResult Name
 
 create :: ListResult -> KeyCombination -> ContextMenu
-create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons []
+create lr exit_key = Menu.createMenu Common.ContextBox lr validator exit_key buttons []
  where
   advInstallButton =
     Menu.createButtonField (MenuElement Common.AdvanceInstallButton)
@@ -48,6 +48,7 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons []
       GHC -> [advInstallButton, compileGhcButton]
       HLS -> [advInstallButton, compileHLSButton]
       _ -> [advInstallButton]
+  validator = const Nothing
 
 draw :: ContextMenu -> Widget Name
 draw menu =