Visuals for compiling HLS

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

@@ -75,6 +75,7 @@ import           Optics.Operators ((.~),(%~))
 import           Optics.Getter (view)
 import Optics.Optic ((%))
 import Optics ((^.), to)
+import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
 
 
 
@@ -535,6 +536,7 @@ keyHandlers KeyBindings {..} =
         contextMenu .= ContextMenu.create r bQuit
         advanceInstallMenu .= AdvanceInstall.create bQuit
         compileGHCMenu .= CompileGHC.create bQuit
+        compileHLSMenu .= CompileHLS.create bQuit
         -- 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,7 @@ 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
 
 app :: AttrMap -> AttrMap -> App BrickState () Name
 app attrs dimAttrs =
@@ -94,7 +95,7 @@ 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
@@ -136,7 +137,8 @@ contextMenuHandler ev = do
           && n `elem` [Menu.fieldName button | button <- buttons]
       -> 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 ()
@@ -172,6 +174,22 @@ compileGHCHandler ev = do
       -> mode .= ContextPanel
     _ -> 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
+      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
+    _ -> Common.zoom compileHLSMenu $ CompileHLS.handler ev
+
 eventHandler :: BrickEvent Name e -> EventM Name BrickState ()
 eventHandler ev = do
   m <- use mode
@@ -182,3 +200,4 @@ eventHandler ev = do
     ContextPanel -> contextMenuHandler ev
     AdvanceInstallPanel -> advanceInstallHandler ev
     CompileGHCPanel     -> compileGHCHandler ev
+    CompileHLSPanel     -> compileHLSHandler ev

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 CompileGHCButton :: ResourceId
-pattern CompilieButton = ResourceId 101
+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/Menus/CompileHLS.hs

@@ -0,0 +1,174 @@
+{-# 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) 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

@@ -35,14 +35,18 @@ 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 =
+  compileGhcButton =
-    Menu.createButtonField (MenuElement Common.CompilieButton)
+    Menu.createButtonField (MenuElement Common.CompileGHCButton)
       & Menu.fieldLabelL .~ "Compile"
-      & Menu.fieldHelpMsgL .~ "Compile tool from source"
+      & 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]
+      GHC -> [advInstallButton, compileGhcButton]
-      HLS -> [advInstallButton, compileButton]
+      HLS -> [advInstallButton, compileHLSButton]
       _ -> [advInstallButton]
 
 draw :: ContextMenu -> Widget Name

lib-tui/GHCup/BrickMain.hs

@@ -37,6 +37,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
 
 
 
@@ -67,6 +68,7 @@ brickMain s = do
                       (ContextMenu.create e exit_key)
                       (AdvanceInstall.create (bQuit . keyBindings $ s ))
                       (CompileGHC.create exit_key)
+                      (CompileHLS.create exit_key)
                       (keyBindings s)
                       Common.Navigation
           in Brick.defaultMain initapp initstate