diff --git a/ghcup.cabal b/ghcup.cabal index 0247ee9..def79af 100644 --- a/ghcup.cabal +++ b/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 diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index ab5c3ed..f1db3c0 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/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 () diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 4552eab..5dcc904 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/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 diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index 7ac36f3..a88d61c 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/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 } diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index e209c3a..5d6b5af 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs new file mode 100644 index 0000000..e7085fc --- /dev/null +++ b/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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs index 434183a..1302231 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ b/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 = - Menu.createButtonField (MenuElement Common.CompilieButton) + compileGhcButton = + 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] - HLS -> [advInstallButton, compileButton] + GHC -> [advInstallButton, compileGhcButton] + HLS -> [advInstallButton, compileHLSButton] _ -> [advInstallButton] draw :: ContextMenu -> Widget Name diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index e3d6c01..8875d5e 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/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