Fix for screen readers

ghcup.cabal

@@ -334,6 +334,7 @@ library ghcup-tui
     GHCup.Brick.Widgets.Menus.Context
     GHCup.Brick.Widgets.Menus.AdvanceInstall
     GHCup.Brick.Widgets.Menus.CompileGHC
+    GHCup.Brick.Widgets.Menus.CompileHLS
     GHCup.Brick.Actions
     GHCup.Brick.App
     GHCup.Brick.BrickState

lib-tui/GHCup/Brick/Actions.hs

@@ -18,7 +18,7 @@ import           GHCup.Types.Optics ( getDirs, getPlatformReq )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
 import           GHCup.OptParse.Common (logGHCPostRm)
-import           GHCup.Prelude ( decUTF8Safe )
+import           GHCup.Prelude ( decUTF8Safe, runBothE' )
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.Process
 import           GHCup.Prompts
@@ -75,6 +75,11 @@ import           Optics.Operators ((.~),(%~))
 import           Optics.Getter (view)
 import Optics.Optic ((%))
 import Optics ((^.), to)
+import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
+import Control.Concurrent (threadDelay)
+import qualified GHCup.GHC as GHC
+import qualified GHCup.OptParse.Common as OptParse
+import qualified GHCup.HLS as HLS
 
 
 
@@ -173,12 +178,19 @@ withIOAction action = do
             pure (updateList data' as)
           Left err -> throwIO $ userError err
 
-install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
-         => (Int, ListResult)
+installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
+         => AdvanceInstall.InstallOptions
+         -> (Int, ListResult)
          -> m (Either String ())
-install' (_, ListResult {..}) = do
+installWithOptions opts (_, ListResult {..}) = do
   AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-
+  let
+    misolated = opts ^. AdvanceInstall.isolateDirL
+    shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvanceInstall.isolateDirL)
+    shouldForce   = opts ^. AdvanceInstall.forceInstallL
+    shouldSet     = opts ^. AdvanceInstall.instSetL
+    extraArgs     = opts ^. AdvanceInstall.addConfArgsL
+    v = GHCTargetVersion lCross lVer
   let run =
         runResourceT
           . runE
@@ -208,6 +220,7 @@ install' (_, ListResult {..}) = do
               , UnsupportedSetupCombo
               , DistroNotFound
               , NoCompatibleArch
+              , InstallSetError
               ]
 
   run (do
@@ -216,20 +229,81 @@ install' (_, ListResult {..}) = do
       dirs <- lift getDirs
       case lTool of
         GHC   -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
-          liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
+          let vi = getVersionInfo v GHC dls
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $
+                runBothE'
+                  (installGHCBin v shouldIsolate shouldForce  extraArgs)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing))
+              pure (vi, dirs, ce)
+            Just uri -> do
+              liftE $
+                runBothE'
+                  (installGHCBindist
+                      (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
+                      v
+                      shouldIsolate
+                      shouldForce
+                      extraArgs)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing))
+              pure (vi, dirs, ce)
+
         Cabal -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls
-          liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
+          let vi = getVersionInfo v Cabal dls
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $
+                runBothE'
+                  (installCabalBin lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
+              pure (vi, dirs, ce)
+            Just uri -> do
+              liftE $
+                runBothE'
+                  (installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
+              pure (vi, dirs, ce)
+
         GHCup -> do
           let vi = snd <$> getLatest dls GHCup
           liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
         HLS   -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
-          liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
+          let vi = getVersionInfo v HLS dls
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $
+                runBothE'
+                  (installHLSBin lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing))
+              pure (vi, dirs, ce)
+            Just uri -> do
+              liftE $
+                runBothE'
+                  (installHLSBindist
+                    (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
+                    lVer
+                    shouldIsolate
+                    shouldForce)
+                  (when (shouldSet && isNothing misolated)  (liftE $ void $ setHLS lVer SetHLSOnly Nothing))
+              pure (vi, dirs, ce)
+
         Stack -> do
-          let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
-          liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
+          let vi = getVersionInfo v Stack dls
+          case opts ^. AdvanceInstall.instBindistL of
+            Nothing -> do
+              liftE $
+                runBothE'
+                  (installStackBin lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
+              pure (vi, dirs, ce)
+            Just uri -> do
+              liftE $
+                runBothE'
+                  (installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce)
+                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
+              pure (vi, dirs, ce)
+
     )
     >>= \case
           VRight (vi, Dirs{..}, Just ce) -> do
@@ -256,6 +330,9 @@ install' (_, ListResult {..}) = do
           VLeft e -> pure $ Left $ prettyHFError e <> "\n"
             <> "Also check the logs in ~/.ghcup/logs"
 
+install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
+         => (Int, ListResult) -> m (Either String ())
+install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing False [])
 
 set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
      => (Int, ListResult)
@@ -384,6 +461,175 @@ changelog' (_, ListResult {..}) = do
         Right _ -> pure $ Right ()
         Left  e -> pure $ Left $ prettyHFError e
 
+compileGHC :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
+           => CompileGHC.CompileGHCOptions -> (Int, ListResult) -> m (Either String ())
+compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do
+  appstate <- ask
+  let run =
+        runResourceT
+         . runE @'[ AlreadyInstalled
+                  , BuildFailed
+                  , DigestError
+                  , ContentLengthError
+                  , GPGError
+                  , DownloadFailed
+                  , GHCupSetError
+                  , NoDownload
+                  , NotFoundInPATH
+                  , PatchFailed
+                  , UnknownArchive
+                  , TarDirDoesNotExist
+                  , NotInstalled
+                  , DirNotEmpty
+                  , ArchiveResult
+                  , FileDoesNotExistError
+                  , HadrianNotFound
+                  , InvalidBuildConfig
+                  , ProcessError
+                  , CopyError
+                  , BuildFailed
+                  , UninstallFailed
+                  , MergeFileTreeError
+                  ]
+  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
+
+      targetVer <- liftE $ GHCup.compileGHC
+                    (GHC.SourceDist lVer)
+                    (compopts ^. CompileGHC.crossTarget)
+                    (compopts ^. CompileGHC.overwriteVer)
+                    (compopts ^. CompileGHC.bootstrapGhc)
+                    (compopts ^. CompileGHC.jobs)
+                    (compopts ^. CompileGHC.buildConfig)
+                    (compopts ^. CompileGHC.patches)
+                    (compopts ^. CompileGHC.addConfArgs)
+                    (compopts ^. CompileGHC.buildFlavour)
+                    (compopts ^. CompileGHC.buildSystem)
+                    (maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir)
+      AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
+      let vi2 = getVersionInfo targetVer GHC dls2
+      when
+        (compopts ^. CompileGHC.setCompile)
+        (liftE . void $ GHCup.setGHC targetVer SetGHCOnly Nothing)
+      pure (vi2, targetVer)
+      )
+  case compileResult of
+      VRight (vi, tv) -> do
+        logInfo "GHC successfully compiled and installed"
+        forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+        liftIO $ putStr (T.unpack $ tVerToText tv)
+        pure $ Right ()
+      VLeft (V (AlreadyInstalled _ v)) -> do
+        logWarn $
+          "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
+        pure $ Right ()
+      VLeft (V (DirNotEmpty fp)) -> do
+        logError $
+          "Install directory " <> T.pack fp <> " is not empty."
+        pure $ Right ()
+      VLeft err@(V (BuildFailed tmpdir _)) -> do
+        case keepDirs (appstate & settings) of
+          Never -> logError $ T.pack $ prettyHFError err
+          _ -> logError $ T.pack (prettyHFError err) <> "\n"
+            <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir)
+            <> " and the build directory "
+            <> T.pack tmpdir <> " for more clues." <> "\n"
+            <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards."
+        pure $ Right ()
+      VLeft e -> do
+        logError $ T.pack $ prettyHFError e
+        pure $ Right ()
+-- This is the case when the tool is not GHC... which should be impossible but,
+-- it exhaustes pattern matches
+compileGHC _ (_, ListResult{lTool = _}) = pure (Right ())
+
+
+compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
+           => CompileHLS.CompileHLSOptions -> (Int, ListResult) -> m (Either String ())
+compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do
+  appstate <- ask
+  let run =
+        runResourceT
+         . runE @'[ AlreadyInstalled
+                  , BuildFailed
+                  , DigestError
+                  , ContentLengthError
+                  , GPGError
+                  , DownloadFailed
+                  , GHCupSetError
+                  , NoDownload
+                  , NotFoundInPATH
+                  , PatchFailed
+                  , UnknownArchive
+                  , TarDirDoesNotExist
+                  , TagNotFound
+                  , DayNotFound
+                  , NextVerNotFound
+                  , NoToolVersionSet
+                  , NotInstalled
+                  , DirNotEmpty
+                  , ArchiveResult
+                  , UninstallFailed
+                  , MergeFileTreeError
+                  ]
+  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
+
+      ghcs <-
+        liftE $ forM (compopts ^. CompileHLS.targetGHCs)
+                     (\ghc -> fmap (_tvVersion . fst) . OptParse.fromVersion (Just ghc) $ GHC)
+      targetVer <- liftE $ GHCup.compileHLS
+                      (HLS.SourceDist lVer)
+                      ghcs
+                      (compopts ^. CompileHLS.jobs)
+                      (compopts ^. CompileHLS.overwriteVer)
+                      (maybe GHCupInternal IsolateDir $ compopts ^. CompileHLS.isolateDir)
+                      (compopts ^. CompileHLS.cabalProject)
+                      (compopts ^. CompileHLS.cabalProjectLocal)
+                      (compopts ^. CompileHLS.updateCabal)
+                      (compopts ^. CompileHLS.patches)
+                      (compopts ^. CompileHLS.cabalArgs)
+      AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
+      let vi2 = getVersionInfo (mkTVer targetVer) GHC dls2
+      when
+        (compopts ^. CompileHLS.setCompile)
+        (liftE . void $ GHCup.setHLS targetVer SetHLSOnly Nothing)
+      pure (vi2, targetVer)
+      )
+  case compileResult of
+      VRight (vi, tv) -> do
+        logInfo "HLS successfully compiled and installed"
+        forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+        liftIO $ putStr (T.unpack $ prettyVer tv)
+        pure $ Right ()
+      VLeft err@(V (BuildFailed tmpdir _)) -> do
+        case keepDirs (appstate & settings) of
+          Never -> logError $ T.pack $ prettyHFError err
+          _ -> logError $ T.pack (prettyHFError err) <> "\n"
+            <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir)
+               <> " and the build directory "
+            <> T.pack tmpdir <> " for more clues." <> "\n"
+            <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards."
+        pure $ Right ()
+      VLeft e -> do
+        logError $ T.pack $ prettyHFError e
+        pure $ Right ()
+-- This is the case when the tool is not HLS... which should be impossible but,
+-- it exhaustes pattern matches
+compileHLS _ (_, ListResult{lTool = _}) = pure (Right ())
+
 
 settings' :: IORef AppState
 {-# NOINLINE settings' #-}
@@ -456,13 +702,15 @@ keyHandlers KeyBindings {..} =
  where
   createMenuforTool = do
     e <- use (appState % to sectionListSelectedElement)
+    let exitKey = KeyCombination (Vty.KChar 'c') [Vty.MCtrl]
     case e of
       Nothing     -> pure ()
       Just (_, r) -> do
         -- Create new menus
-        contextMenu .= ContextMenu.create r bQuit
-        advanceInstallMenu .= AdvanceInstall.create bQuit
-        compileGHCMenu .= CompileGHC.create bQuit
+        contextMenu .= ContextMenu.create r exitKey
+        advanceInstallMenu .= AdvanceInstall.create exitKey
+        compileGHCMenu .= CompileGHC.create exitKey
+        compileHLSMenu .= CompileHLS.create exitKey
         -- Set mode to context
         mode           .= ContextPanel
     pure ()

lib-tui/GHCup/Brick/App.hs

@@ -25,7 +25,7 @@ module GHCup.Brick.App where
 
 import qualified GHCup.Brick.Actions as Actions
 import qualified GHCup.Brick.Attributes as Attributes
-import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu)
+import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu, compileHLSMenu)
 import GHCup.Brick.Common (Mode (..), Name (..))
 import qualified GHCup.Brick.Common as Common
 import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
@@ -65,6 +65,8 @@ import Optics.Optic ((%))
 import Optics.State (use)
 import Optics.State.Operators ((.=))
 import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
+import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
+import Control.Monad (when)
 
 app :: AttrMap -> AttrMap -> App BrickState () Name
 app attrs dimAttrs =
@@ -94,13 +96,13 @@ drawUI dimAttrs st =
        ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg]
        AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg]
        CompileGHCPanel     -> [CompileGHC.draw (st ^. compileGHCMenu), navg]
-
+       CompileHLSPanel     -> [CompileHLS.draw (st ^. compileHLSMenu), navg]
 
 -- | On q, go back to navigation.
 --   On Enter, to go to tutorial
 keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState ()
 keyInfoHandler ev = case ev of
-  VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
+  VtyEvent (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) -> mode .= Navigation
   VtyEvent (Vty.EvKey Vty.KEnter _ )   -> mode .= Tutorial
   _ -> pure ()
 
@@ -108,7 +110,7 @@ keyInfoHandler ev = case ev of
 tutorialHandler :: BrickEvent Name e -> EventM Name BrickState ()
 tutorialHandler ev =
   case ev of
-    VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
+    VtyEvent (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) -> mode .= Navigation
     _ -> pure ()
 
 -- | Tab/Arrows to navigate.
@@ -116,8 +118,8 @@ navigationHandler :: BrickEvent Name e -> EventM Name BrickState ()
 navigationHandler ev = do
   AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings'
   case ev of
-    inner_event@(VtyEvent (Vty.EvKey key _)) ->
-      case find (\(key', _, _) -> key' == KeyCombination key []) (Actions.keyHandlers kb) of
+    inner_event@(VtyEvent (Vty.EvKey key mods)) ->
+      case find (\(key', _, _) -> key' == KeyCombination key mods) (Actions.keyHandlers kb) of
         Just (_, _, handler) -> handler
         Nothing -> void $ Common.zoom appState $ Navigation.handler inner_event
     inner_event -> Common.zoom appState $ Navigation.handler inner_event
@@ -126,49 +128,57 @@ contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState ()
 contextMenuHandler ev = do
   ctx <- use contextMenu
   let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
-      buttons = ctx ^. Menu.menuButtonsL
       (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
   case (ev, focusedElement) of
     (_ , Nothing) -> pure ()
-    (VtyEvent (Vty.EvKey k m), Just n) 
-      |  k == exitKey 
-          && m == mods 
-          && n `elem` [Menu.fieldName button | button <- buttons]
-      -> mode .= Navigation
+    (VtyEvent (Vty.EvKey k m), Just n) |  k == exitKey && m == mods -> mode .= Navigation
     (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel
-    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.CompilieButton) ) -> mode .= Common.CompileGHCPanel
+    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.CompileGHCButton) ) -> mode .= Common.CompileGHCPanel
+    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.CompileHLSButton) ) -> mode .= Common.CompileHLSPanel
     _ -> Common.zoom contextMenu $ ContextMenu.handler ev
 --
 advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState ()
 advanceInstallHandler ev = do
   ctx <- use advanceInstallMenu
   let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
-      buttons = ctx ^. Menu.menuButtonsL
       (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
   case (ev, focusedElement) of
     (_ , Nothing) -> pure ()
-    (VtyEvent (Vty.EvKey k m), Just n)
-      | k == exitKey
-          && m == mods
-          && n `elem` [Menu.fieldName button | button <- buttons]
-      -> mode .= ContextPanel
+    (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
     _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev
 
 compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState ()
 compileGHCHandler ev = do
   ctx <- use compileGHCMenu
   let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
-      buttons = ctx ^. Menu.menuButtonsL
       (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
   case (ev, focusedElement) of
     (_ , Nothing) -> pure ()
-    (VtyEvent (Vty.EvKey k m), Just n)
-      | k == exitKey
-          && m == mods
-          && n `elem` [Menu.fieldName button | button <- buttons]
-      -> mode .= ContextPanel
+    (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
+        when (Menu.isValidMenu ctx)
+          (Actions.withIOAction $ Actions.compileGHC iopts)
     _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev
 
+
+compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState ()
+compileHLSHandler ev = do
+  ctx <- use compileHLSMenu
+  let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
+      (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
+  case (ev, focusedElement) of
+    (_ , Nothing) -> pure ()
+    (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
+        when (Menu.isValidMenu ctx)
+          (Actions.withIOAction $ Actions.compileHLS iopts)
+    _ -> Common.zoom compileHLSMenu $ CompileHLS.handler ev
+
 eventHandler :: BrickEvent Name e -> EventM Name BrickState ()
 eventHandler ev = do
   m <- use mode
@@ -179,3 +189,4 @@ eventHandler ev = do
     ContextPanel -> contextMenuHandler ev
     AdvanceInstallPanel -> advanceInstallHandler ev
     CompileGHCPanel     -> compileGHCHandler ev
+    CompileHLSPanel     -> compileHLSHandler ev

lib-tui/GHCup/Brick/Attributes.hs

@@ -46,10 +46,8 @@ defaultAttributes no_color = Brick.attrMap
   where
     withForeColor | no_color  = const
                   | otherwise = Vty.withForeColor
-
     withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
                   | otherwise = Vty.withBackColor
-
     withStyle                 = Vty.withStyle
 
 

lib-tui/GHCup/Brick/BrickState.hs

@@ -35,6 +35,7 @@ import GHCup.Brick.Widgets.Menus.Context (ContextMenu)
 import GHCup.Brick.Widgets.Menus.AdvanceInstall (AdvanceInstallMenu)
 import GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCMenu)
 import Optics.TH                      (makeLenses)
+import GHCup.Brick.Widgets.Menus.CompileHLS (CompileHLSMenu)
 
 
 data BrickState = BrickState
@@ -44,6 +45,7 @@ data BrickState = BrickState
   , _contextMenu        :: ContextMenu
   , _advanceInstallMenu :: AdvanceInstallMenu
   , _compileGHCMenu     :: CompileGHCMenu
+  , _compileHLSMenu     :: CompileHLSMenu
   , _appKeys            :: KeyBindings
   , _mode               :: Mode
   }

lib-tui/GHCup/Brick/Common.hs

@@ -45,7 +45,8 @@ module GHCup.Brick.Common  (
     , TargetGhcEditBox, BootstrapGhcEditBox, JobsEditBox, BuildConfigEditBox
     , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox
     , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton
-    , CompilieButton
+    , CompileGHCButton, CompileHLSButton, CabalProjectEditBox
+    , CabalProjectLocalEditBox, UpdateCabalCheckBox
   ) ) where
 
 import           GHCup.List ( ListResult )
@@ -75,8 +76,10 @@ pattern OkButton :: ResourceId
 pattern OkButton = ResourceId 0
 pattern AdvanceInstallButton :: ResourceId
 pattern AdvanceInstallButton = ResourceId 100
-pattern CompilieButton :: ResourceId
-pattern CompilieButton = ResourceId 101
+pattern CompileGHCButton :: ResourceId
+pattern CompileGHCButton = ResourceId 101
+pattern CompileHLSButton :: ResourceId
+pattern CompileHLSButton = ResourceId 102
 
 pattern UrlEditBox :: ResourceId
 pattern UrlEditBox = ResourceId 1
@@ -110,6 +113,14 @@ pattern BuildFlavourEditBox = ResourceId 14
 pattern BuildSystemEditBox :: ResourceId
 pattern BuildSystemEditBox = ResourceId 15
 
+pattern CabalProjectEditBox  :: ResourceId
+pattern CabalProjectEditBox  = ResourceId 16
+pattern CabalProjectLocalEditBox  :: ResourceId
+pattern CabalProjectLocalEditBox  = ResourceId 17
+pattern UpdateCabalCheckBox  :: ResourceId
+pattern UpdateCabalCheckBox  = ResourceId 18
+
+
 -- | Name data type. Uniquely identifies each widget in the TUI.
 -- some constructors might end up unused, but still is a good practise
 -- to have all of them defined, just in case
@@ -133,6 +144,7 @@ data Mode = Navigation
           | ContextPanel
           | AdvanceInstallPanel
           | CompileGHCPanel
+          | CompileHLSPanel
           deriving (Eq, Show, Ord)
 
 installedSign :: String

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

@@ -69,4 +69,4 @@ draw KeyBindings {..} =
             ]
           ]
         ]
-      <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"]
+      <=> Brick.hBox [Brick.txt "Press c+ctrl to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"]

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

@@ -93,7 +93,7 @@ idFormatter = const id
 
 -- | An error message
 type ErrorMessage = T.Text
-data ErrorStatus = Valid | Invalid ErrorMessage
+data ErrorStatus = Valid | Invalid ErrorMessage deriving (Eq)
 
 -- | A lens which does nothing. Usefull to defined no-op fields
 emptyLens :: Lens' s ()
@@ -137,6 +137,8 @@ data MenuField s n where
       , fieldName      :: n
       } -> MenuField s n
 
+isValidField :: MenuField s n -> Bool
+isValidField = (== Valid) . fieldStatus
 
 makeLensesFor
   [ ("fieldLabel", "fieldLabelL")
@@ -150,6 +152,14 @@ fieldHelpMsgL = lens g s
   where g (MenuField {..})= fieldInput ^. inputHelpL
         s (MenuField{..}) msg = MenuField {fieldInput = fieldInput & inputHelpL .~ msg , ..}
 
+-- | How to draw a field given a formater
+drawField :: Formatter n -> Bool -> MenuField s n -> Widget n
+drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) =
+  let input = inputRender focus fieldStatus inputHelp inputState (amp focus)
+    in if focus
+        then Brick.visible input
+        else input
+
 instance Brick.Named (MenuField s n) n where
   getName :: MenuField s n -> n
   getName entry = entry & fieldName
@@ -202,7 +212,7 @@ createEditableInput name validator = FieldInput initEdit validateEditContent ""
              | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help
              | focus     -> borderBox editorRender
              | otherwise -> borderBox $ renderAsErrMsg msg
-    validateEditContent = validator . T.unlines . Edit.getEditContents
+    validateEditContent = validator . T.init . T.unlines . Edit.getEditContents
     initEdit = Edit.editorText name (Just 1) ""
 
 createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a  -> EditableField s n
@@ -218,7 +228,9 @@ type Button = MenuField
 
 createButtonInput :: FieldInput () () n
 createButtonInput = FieldInput () Right "" drawButton (const $ pure ())
-  where drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help
+  where
+    drawButton True (Invalid err) _    _ amp = amp . centerV . renderAsErrMsg $ err
+    drawButton _    _             help _ amp = amp . centerV . renderAsHelpMsg $ help
 
 createButtonField :: n -> Button s n
 createButtonField = MenuField emptyLens createButtonInput "" Valid
@@ -273,7 +285,6 @@ data Menu s n
     , menuName      :: n                 -- ^ The resource Name.
     }
 
-
 makeLensesFor
   [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL")
   , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL")
@@ -281,6 +292,9 @@ makeLensesFor
   ]
   ''Menu
 
+isValidMenu :: Menu s n -> Bool
+isValidMenu = all isValidField . menuFields
+
 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
   where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons]
@@ -299,9 +313,13 @@ handlerMenu ev =
         Nothing -> pure ()
         Just n  -> do
           updated_fields <- updateFields n (VtyEvent e) fields
+          if all isValidField updated_fields
+            then menuButtonsL %= fmap (fieldStatusL .~ Valid)
+            else menuButtonsL %= fmap (fieldStatusL .~ Invalid "Some fields are invalid")
           menuFieldsL .= updated_fields
     _ -> pure ()
  where
+  -- runs the Event with the inner handler of MenuField.
   updateFields :: n -> BrickEvent n () -> [MenuField s n] -> EventM n (Menu s n) [MenuField s n]
   updateFields n e [] = pure []
   updateFields n e (x@(MenuField {fieldInput = i@(FieldInput {..}) , ..}):xs) =
@@ -330,12 +348,6 @@ drawMenu menu =
           <+> Brick.txt " to go back"
       ]
   where
-    drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) =
-      let input = inputRender focus fieldStatus inputHelp inputState (amp focus)
-       in if focus
-            then Brick.visible input
-            else input
-    
     fieldLabels  = [field & fieldLabel | field <- menu ^. menuFieldsL]
     buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL]
     allLabels    = fieldLabels ++ buttonLabels

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

@@ -14,7 +14,18 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
-module GHCup.Brick.Widgets.Menus.AdvanceInstall (InstallOptions, AdvanceInstallMenu, create, handler, draw) where
+module GHCup.Brick.Widgets.Menus.AdvanceInstall (
+  InstallOptions (..),
+  AdvanceInstallMenu,
+  create,
+  handler,
+  draw,
+  instBindistL,
+  instSetL,
+  isolateDirL,
+  forceInstallL,
+  addConfArgsL,
+) where
 
 import GHCup.Brick.Widgets.Menu (Menu)
 import qualified GHCup.Brick.Widgets.Menu as Menu
@@ -35,6 +46,8 @@ import Data.Bifunctor (Bifunctor(..))
 import Data.Function ((&))
 import Optics ((.~))
 import Data.Char (isSpace)
+import System.FilePath (isValid, isAbsolute, normalise)
+import GHCup.Prelude (stripNewlineEnd)
 
 data InstallOptions = InstallOptions
   { instBindist  :: Maybe URI
@@ -71,9 +84,14 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields
     filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
     filepathValidator i =
       case not $ emptyEditor i of
-        True  -> Right . Just . T.unpack $ i
+        True  -> absolutePathParser (T.unpack i)
         False -> Right Nothing
 
+    absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
+    absolutePathParser f = case isValid f && isAbsolute f of
+                  True -> Right . Just . stripNewlineEnd . normalise $ f
+                  False -> Left "Please enter a valid absolute filepath."
+
     additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
     additionalValidator = Right . T.split isSpace
 

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

@@ -14,7 +14,24 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
-module GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCOptions, CompileGHCMenu, create, handler, draw) where
+module GHCup.Brick.Widgets.Menus.CompileGHC (
+  CompileGHCOptions,
+  CompileGHCMenu,
+  create,
+  handler,
+  draw,
+  bootstrapGhc,
+  jobs,
+  buildConfig,
+  patches,
+  crossTarget,
+  addConfArgs,
+  setCompile,
+  overwriteVer,
+  buildFlavour,
+  buildSystem,
+  isolateDir,
+) where
 
 import GHCup.Brick.Widgets.Menu (Menu)
 import qualified GHCup.Brick.Widgets.Menu as Menu
@@ -26,7 +43,8 @@ import Brick
 import           Prelude                 hiding ( appendFile )
 import           Optics.TH (makeLenses)
 import qualified GHCup.Brick.Common as Common
-import GHCup.Types (KeyCombination, BuildSystem (Hadrian))
+import GHCup.Types
+    ( KeyCombination, BuildSystem(..), VersionPattern )
 import URI.ByteString (URI)
 import qualified Data.Text as T
 import qualified Data.ByteString.UTF8 as UTF8
@@ -36,9 +54,11 @@ import Data.Function ((&))
 import Optics ((.~))
 import Data.Char (isSpace)
 import Data.Versions (Version, version)
-import System.FilePath (isPathSeparator)
+import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise)
 import Control.Applicative (Alternative((<|>)))
 import Text.Read (readEither)
+import GHCup.Prelude (stripNewlineEnd)
+import qualified GHCup.OptParse.Common as OptParse
 
 data CompileGHCOptions = CompileGHCOptions
   { _bootstrapGhc :: Either Version FilePath
@@ -48,7 +68,7 @@ data CompileGHCOptions = CompileGHCOptions
   , _crossTarget  :: Maybe T.Text
   , _addConfArgs  :: [T.Text]
   , _setCompile   :: Bool
-  , _ovewrwiteVer :: Maybe Version
+  , _overwriteVer :: Maybe [VersionPattern]
   , _buildFlavour :: Maybe String
   , _buildSystem  :: Maybe BuildSystem
   , _isolateDir   :: Maybe FilePath
@@ -83,18 +103,19 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
     bootstrapV i =
       case not $ emptyEditor i of
         True  ->
-          let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init
-              readPath
-                 = if isPathSeparator (T.head i) 
-                    then pure $ Right (T.unpack i)
-                    else Left "Not an absolute Path"
+          let readVersion = bimap (const "Not a valid version") Left (version i)
+              readPath = do
+                mfilepath <- filepathV i
+                case mfilepath of
+                  Nothing -> Left "Invalid Empty value"
+                  Just f  -> Right (Right f)
            in if T.any isPathSeparator i
                 then readPath
                 else readVersion
         False -> Left "Invalid Empty value"
 
-    versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version)
-    versionV = bimap (const "Not a valid version") Just . version . T.init  -- Brick adds \n at the end, hence T.init
+    versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern])
+    versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack)
 
     jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
     jobsV =
@@ -113,7 +134,15 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
           in first T.pack $ x <|> y
 
     filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
-    filepathV = whenEmpty Nothing (Right . Just . T.unpack)
+    filepathV i =
+      case not $ emptyEditor i of
+        True  -> absolutePathParser (T.unpack i)
+        False -> Right Nothing
+
+    absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
+    absolutePathParser f = case isValid f && isAbsolute f of
+                  True -> Right . Just . stripNewlineEnd . normalise $ f
+                  False -> Left "Please enter a valid absolute filepath."
 
     additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
     additionalValidator = Right . T.split isSpace
@@ -123,7 +152,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
       where
         readSys i
           | T.toLower i == "hadrian" = Right $ Just Hadrian
-          | T.toLower i == "make"    = Right $ Just Hadrian
+          | T.toLower i == "make"    = Right $ Just Make
           | otherwise = Left "Not a valid Build System"
 
     fields =
@@ -149,14 +178,14 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
       , 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 ovewrwiteVer
+      , 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.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.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.IsolateEditBox) filepathV isolateDir
           & Menu.fieldLabelL .~ "isolated"
@@ -167,6 +196,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields
        Menu.createButtonField (Common.MenuElement Common.OkButton)
            & Menu.fieldLabelL .~ "Compile"
            & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below"
+           & Menu.fieldStatusL .~ Menu.Invalid "bootstrap GHC is mandatory"
       ]
 
 handler :: BrickEvent Name e -> EventM Name CompileGHCMenu ()

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

@@ -0,0 +1,191 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+
+module GHCup.Brick.Widgets.Menus.CompileHLS (
+  CompileHLSOptions,
+  CompileHLSMenu,
+  create,
+  handler,
+  draw,
+  jobs,
+  setCompile,
+  updateCabal,
+  overwriteVer,
+  isolateDir,
+  cabalProject,
+  cabalProjectLocal,
+  patches,
+  targetGHCs,
+  cabalArgs,
+)
+where
+
+import GHCup.Brick.Widgets.Menu (Menu)
+import qualified GHCup.Brick.Widgets.Menu as Menu
+import           GHCup.Brick.Common(Name(..))
+import Brick
+    ( BrickEvent(..),
+      EventM,
+      Widget(..))
+import           Prelude                 hiding ( appendFile )
+import           Optics.TH (makeLenses)
+import qualified GHCup.Brick.Common as Common
+import GHCup.Types (KeyCombination, VersionPattern, ToolVersion)
+import URI.ByteString (URI)
+import qualified Data.Text as T
+import qualified Data.ByteString.UTF8 as UTF8
+import GHCup.Utils (parseURI)
+import Data.Bifunctor (Bifunctor(..))
+import Data.Function ((&))
+import Optics ((.~))
+import Data.Char (isSpace)
+import System.FilePath (isValid, isAbsolute, normalise)
+import Control.Applicative (Alternative((<|>)))
+import Text.Read (readEither)
+import GHCup.Prelude (stripNewlineEnd)
+import qualified GHCup.OptParse.Common as OptParse
+
+data CompileHLSOptions = CompileHLSOptions
+  { _jobs         :: Maybe Int
+  , _setCompile   :: Bool
+  , _updateCabal  :: Bool
+  , _overwriteVer :: Maybe [VersionPattern]
+  , _isolateDir   :: Maybe FilePath
+  , _cabalProject :: Maybe (Either FilePath URI)
+  , _cabalProjectLocal :: Maybe URI
+  , _patches      :: Maybe (Either FilePath [URI])
+  , _targetGHCs   :: [ToolVersion]
+  , _cabalArgs    :: [T.Text]
+  } deriving (Eq, Show)
+
+makeLenses ''CompileHLSOptions
+
+type CompileHLSMenu = Menu CompileHLSOptions Name
+
+create :: KeyCombination -> CompileHLSMenu
+create k = Menu.createMenu CompileGHCBox initialState k buttons fields
+  where
+    initialState =
+      CompileHLSOptions
+        Nothing
+        False
+        False
+        Nothing
+        Nothing
+        Nothing
+        Nothing
+        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
+    whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval
+
+    cabalProjectV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath URI))
+    cabalProjectV i =
+      case not $ emptyEditor i of
+        True  ->
+          let readPath = Right . Left . stripNewlineEnd . T.unpack $ i
+           in bimap T.pack Just $ second Right (readUri i) <|> readPath
+        False -> Right Nothing
+
+    {- There is an unwanted dependency to ghcup-opt... Alternatives are
+    - copy-paste a bunch of code
+    - define a new common library
+    -}
+    ghcVersionTagEither :: T.Text -> Either Menu.ErrorMessage [ToolVersion]
+    ghcVersionTagEither = first T.pack . traverse (OptParse.ghcVersionTagEither . T.unpack) . T.split isSpace
+
+    overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern])
+    overWriteVersionParser = bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack
+
+    jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
+    jobsV =
+      let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack
+       in whenEmpty Nothing parseInt
+
+    readUri :: T.Text -> Either String URI
+    readUri = first show . parseURI . UTF8.fromString . T.unpack
+
+    patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI]))
+    patchesV = whenEmpty Nothing readPatches
+      where
+        readPatches j =
+          let
+            x = (bimap T.unpack (fmap Left) $ filepathV j)
+            y = second (Just . Right) $ traverse readUri (T.split isSpace j)
+          in first T.pack $ x <|> y
+
+    filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
+    filepathV i =
+      case not $ emptyEditor i of
+        True  -> absolutePathParser (T.unpack i)
+        False -> Right Nothing
+
+    absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
+    absolutePathParser f = case isValid f && isAbsolute f of
+                  True -> Right . Just . stripNewlineEnd . normalise $ f
+                  False -> Left "Please enter a valid absolute filepath."
+
+    additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
+    additionalValidator = Right . T.split isSpace
+
+    fields =
+      [ Menu.createEditableField (Common.MenuElement Common.CabalProjectEditBox) cabalProjectV cabalProject
+           & Menu.fieldLabelL .~ "cabal project"
+           & Menu.fieldHelpMsgL .~ "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
+      , Menu.createEditableField (Common.MenuElement Common.CabalProjectLocalEditBox) (bimap T.pack Just . readUri) 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.createCheckBoxField (Common.MenuElement Common.UpdateCabalCheckBox) updateCabal
+          & Menu.fieldLabelL .~ "cabal update"
+          & Menu.fieldHelpMsgL .~ "Run 'cabal update' before the build"
+      , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs
+          & 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.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.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
+          & Menu.fieldLabelL .~ "set"
+          & Menu.fieldHelpMsgL .~ "Set as active version after install"
+      , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator cabalArgs
+          & Menu.fieldLabelL .~ "CONFIGURE_ARGS"
+          & Menu.fieldHelpMsgL .~ "Additional arguments to cabal install, prefix with '-- ' (longopts)"
+      , 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.OvewrwiteVerEditBox) overWriteVersionParser overwriteVer
+          & Menu.fieldLabelL .~ "overwrite version"
+          & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
+      ]
+
+    buttons = [
+       Menu.createButtonField (Common.MenuElement Common.OkButton)
+           & Menu.fieldLabelL .~ "Compile"
+           & Menu.fieldHelpMsgL .~ "Compile HLS from source with options below"
+      ]
+
+handler :: BrickEvent Name e -> EventM Name CompileHLSMenu ()
+handler = Menu.handlerMenu
+
+
+draw :: CompileHLSMenu -> Widget Name
+draw = Common.frontwardLayer "Compile HLS" . Menu.drawMenu

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

@@ -6,20 +6,25 @@ import Brick (
   Widget (..), BrickEvent, EventM,
  )
 import Data.Function ((&))
-import qualified GHCup.Brick.Common as Common
-import qualified GHCup.Brick.Widgets.Menu as Menu
 import Prelude hiding (appendFile)
 
-import qualified Data.Text as T
-
 import Data.Versions (prettyVer)
-import GHCup (ListResult (..))
+import GHCup.List ( ListResult(..) )
+import GHCup.Types (KeyCombination, Tool (..))
+
+import qualified GHCup.Brick.Common as Common
+import qualified GHCup.Brick.Widgets.Menu as Menu
 import GHCup.Brick.Common (Name (..))
 import GHCup.Brick.Widgets.Menu (Menu)
-import GHCup.Types (KeyCombination, Tool (..))
+import qualified Brick.Widgets.Core as Brick
+import qualified Brick.Widgets.Border as Border
+import qualified Brick.Focus as F
+import Brick.Widgets.Core ((<+>))
+
 import Optics (to)
 import Optics.Operators ((.~), (^.))
 import Optics.Optic ((%))
+import Data.Foldable (foldl')
 
 type ContextMenu = Menu ListResult Name
 
@@ -30,30 +35,48 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons []
     Menu.createButtonField (MenuElement Common.AdvanceInstallButton)
       & Menu.fieldLabelL .~ "Install"
       & Menu.fieldHelpMsgL .~ "Advance Installation Settings"
-  compileButton =
-    Menu.createButtonField (MenuElement Common.CompilieButton)
+  compileGhcButton =
+    Menu.createButtonField (MenuElement Common.CompileGHCButton)
       & Menu.fieldLabelL .~ "Compile"
-      & Menu.fieldHelpMsgL .~ "Compile tool from source (to be implemented)"
+      & Menu.fieldHelpMsgL .~ "Compile GHC from source"
+  compileHLSButton =
+    Menu.createButtonField (MenuElement Common.CompileHLSButton)
+      & Menu.fieldLabelL .~ "Compile"
+      & Menu.fieldHelpMsgL .~ "Compile HLS from source"
   buttons =
     case lTool lr of
-      GHC -> [advInstallButton, compileButton]
-      HLS -> [advInstallButton, compileButton]
+      GHC -> [advInstallButton, compileGhcButton]
+      HLS -> [advInstallButton, compileHLSButton]
       _ -> [advInstallButton]
 
 draw :: ContextMenu -> Widget Name
-draw ctx =
+draw menu =
   Common.frontwardLayer
-    ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ ctx ^. Menu.menuStateL))
-    (Menu.drawMenu ctx)
- where
-  tool_str :: T.Text
-  tool_str =
-    case ctx ^. Menu.menuStateL % to lTool of
-      GHC -> "GHC"
-      GHCup -> "GHCup"
-      Cabal -> "Cabal"
-      HLS -> "HLS"
-      Stack -> "Stack"
+    ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ menu ^. Menu.menuStateL))
+    $ Brick.vBox
+        [ Brick.vBox buttonWidgets
+        , Brick.txt " "
+        , Brick.padRight Brick.Max $
+            Brick.txt "Press "
+            <+> Common.keyToWidget (menu ^. Menu.menuExitKeyL)
+            <+> Brick.txt " to go back"
+        ]
+  where
+    buttonLabels = [button & Menu.fieldLabel | button <- menu ^. Menu.menuButtonsL]
+    maxWidth = foldl' max 5 (fmap Brick.textWidth buttonLabels)
+
+    buttonAmplifiers =
+      let buttonAsWidgets = fmap Menu.renderAslabel buttonLabels
+       in fmap (\f b -> ((Menu.leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets
+    drawButtons = fmap Menu.drawField buttonAmplifiers
+    buttonWidgets = zipWith (F.withFocusRing (menu ^. Menu.menuFocusRingL)) drawButtons (menu ^. Menu.menuButtonsL)
+    tool_str =
+      case menu ^. Menu.menuStateL % to lTool of
+        GHC -> "GHC"
+        GHCup -> "GHCup"
+        Cabal -> "Cabal"
+        HLS -> "HLS"
+        Stack -> "Stack"
 
 handler :: BrickEvent Name e -> EventM Name ContextMenu ()
 handler = Menu.handlerMenu

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

@@ -36,6 +36,8 @@ import Brick
       (<+>),
       (<=>))
 import qualified Brick
+import           Brick.Widgets.Core ( putCursor )
+import           Brick.Types ( Location(..) )
 import           Brick.Widgets.Border ( hBorder, borderWithLabel)
 import           Brick.Widgets.Border.Style ( unicode )
 import           Brick.Widgets.Center ( center )
@@ -100,7 +102,8 @@ draw dimAttrs section_list
           | elem Latest lTag' && not lInstalled =
               Brick.withAttr Attributes.hoorayAttr
           | otherwise = id
-    in  hooray $ dim
+        active = if b then putCursor Common.AllTools (Location (0,0)) else id
+    in  hooray $ active $ dim
           (   marks
           <+> Brick.padLeft (Pad 2)
                ( minHSize 6

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

@@ -74,4 +74,4 @@ draw =
               ]
             , Brick.txt " "
             ])
-        <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial")
+        <=> Brick.padRight Brick.Max (Brick.txt "Press c+ctrl to exit the tutorial")

lib-tui/GHCup/BrickMain.hs

@@ -17,7 +17,7 @@ module GHCup.BrickMain where
 
 import GHCup.Types
     ( Settings(noColor),
-      AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..) )
+      AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..), KeyCombination (KeyCombination) )
 import GHCup.Prelude.Logger ( logError )
 import qualified GHCup.Brick.Actions as Actions
 import qualified GHCup.Brick.Common as Common
@@ -29,6 +29,7 @@ import qualified GHCup.Brick.Widgets.SectionList as Navigation
 import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
 import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
 import qualified Brick
+import qualified Graphics.Vty as Vty
 
 import Control.Monad.Reader ( ReaderT(runReaderT) )
 import Data.Functor ( ($>) )
@@ -37,6 +38,7 @@ import           Prelude                 hiding ( appendFile )
 import System.Exit ( ExitCode(ExitFailure), exitWith )
 
 import qualified Data.Text                     as T
+import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
 
 
 
@@ -50,7 +52,7 @@ brickMain s = do
     Right ad -> do
       let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing
           current_element = Navigation.sectionListSelectedElement initial_list
-          exit_key = bQuit . keyBindings $ s 
+          exit_key = KeyCombination (Vty.KChar 'c') [Vty.MCtrl] -- bQuit . keyBindings $ s
       case current_element of
         Nothing -> do
           flip runReaderT s $ logError "Error building app state: empty ResultList"
@@ -65,8 +67,9 @@ brickMain s = do
                       Common.defaultAppSettings
                       initial_list
                       (ContextMenu.create e exit_key)
-                      (AdvanceInstall.create (bQuit . keyBindings $ s ))
+                      (AdvanceInstall.create exit_key)
                       (CompileGHC.create exit_key)
+                      (CompileHLS.create exit_key)
                       (keyBindings s)
                       Common.Navigation
           in Brick.defaultMain initapp initstate