diff --git a/ghcup.cabal b/ghcup.cabal index ec55996..0247ee9 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -333,6 +333,7 @@ library ghcup-tui GHCup.Brick.Widgets.Menu GHCup.Brick.Widgets.Menus.Context GHCup.Brick.Widgets.Menus.AdvanceInstall + GHCup.Brick.Widgets.Menus.CompileGHC 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 ae16aed..0619b35 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -28,6 +28,8 @@ import GHCup.Brick.BrickState import GHCup.Brick.Widgets.SectionList import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu import GHCup.Brick.Widgets.Navigation (BrickInternalState) +import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall +import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC import qualified Brick import qualified Brick.Widgets.List as L @@ -73,7 +75,7 @@ import Optics.Operators ((.~),(%~)) import Optics.Getter (view) import Optics.Optic ((%)) import Optics ((^.), to) -import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall + {- Core Logic. @@ -458,8 +460,9 @@ keyHandlers KeyBindings {..} = Nothing -> pure () Just (_, r) -> do -- Create new menus - contextMenu .= ContextMenu.create r bQuit + contextMenu .= ContextMenu.create r bQuit advanceInstallMenu .= AdvanceInstall.create bQuit + compileGHCMenu .= CompileGHC.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 9132d40..4a64117 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) +import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu) import GHCup.Brick.Common (Mode (..), Name (..)) import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo @@ -64,6 +64,7 @@ import Optics.Operators ((^.)) import Optics.Optic ((%)) import Optics.State (use) import Optics.State.Operators ((.=)) +import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -91,7 +92,8 @@ drawUI dimAttrs st = Tutorial -> [Tutorial.draw, navg] KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg] - AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg] + AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg] + CompileGHCPanel -> [CompileGHC.draw (st ^. compileGHCMenu), navg] -- | On q, go back to navigation. @@ -134,7 +136,7 @@ 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) ) -> pure () + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> mode .= Common.CompileGHCPanel _ -> Common.zoom contextMenu $ ContextMenu.handler ev -- advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState () @@ -152,6 +154,21 @@ advanceInstallHandler ev = do -> mode .= ContextPanel _ -> 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 + _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev + eventHandler :: BrickEvent Name e -> EventM Name BrickState () eventHandler ev = do m <- use mode @@ -161,3 +178,4 @@ eventHandler ev = do Navigation -> navigationHandler ev ContextPanel -> contextMenuHandler ev AdvanceInstallPanel -> advanceInstallHandler ev + CompileGHCPanel -> compileGHCHandler ev diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index 84583f4..7ac36f3 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -28,12 +28,13 @@ The linear relation above breaks if BrickState is defined in Common. module GHCup.Brick.BrickState where -import GHCup.Types ( KeyBindings ) -import GHCup.Brick.Common ( BrickData(..), BrickSettings(..), Mode(..)) -import GHCup.Brick.Widgets.Navigation ( BrickInternalState) -import GHCup.Brick.Widgets.Menus.Context (ContextMenu) -import GHCup.Brick.Widgets.Menus.AdvanceInstall (AdvanceInstallMenu) -import Optics.TH (makeLenses) +import GHCup.Types ( KeyBindings ) +import GHCup.Brick.Common ( BrickData(..), BrickSettings(..), Mode(..)) +import GHCup.Brick.Widgets.Navigation ( BrickInternalState) +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) data BrickState = BrickState @@ -42,6 +43,7 @@ data BrickState = BrickState , _appState :: BrickInternalState , _contextMenu :: ContextMenu , _advanceInstallMenu :: AdvanceInstallMenu + , _compileGHCMenu :: CompileGHCMenu , _appKeys :: KeyBindings , _mode :: Mode } diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 7f08f57..e209c3a 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -23,7 +23,30 @@ This module contains common values used across the library. Crucially it contain -} -module GHCup.Brick.Common where +module GHCup.Brick.Common ( + installedSign, + setSign, + notInstalledSign, + showKey, + showMod, + keyToWidget, + separator, + frontwardLayer, + zoom, + defaultAppSettings, + lr, + showAllVersions, + Name(..), + Mode(..), + BrickData(..), + BrickSettings(..), + ResourceId ( + UrlEditBox, SetCheckBox, IsolateEditBox, ForceCheckBox, AdditionalEditBox + , TargetGhcEditBox, BootstrapGhcEditBox, JobsEditBox, BuildConfigEditBox + , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox + , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton + , CompilieButton + ) ) where import GHCup.List ( ListResult ) import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) @@ -48,16 +71,45 @@ import qualified Brick.Widgets.Border.Style as Border -- | A newtype for labeling resources in menus. It is bundled along with pattern synonyms newtype ResourceId = ResourceId Int deriving (Eq, Ord, Show) +pattern OkButton :: ResourceId pattern OkButton = ResourceId 0 +pattern AdvanceInstallButton :: ResourceId pattern AdvanceInstallButton = ResourceId 100 +pattern CompilieButton :: ResourceId pattern CompilieButton = ResourceId 101 +pattern UrlEditBox :: ResourceId pattern UrlEditBox = ResourceId 1 +pattern SetCheckBox :: ResourceId pattern SetCheckBox = ResourceId 2 +pattern IsolateEditBox :: ResourceId pattern IsolateEditBox = ResourceId 3 +pattern ForceCheckBox :: ResourceId pattern ForceCheckBox = ResourceId 4 +pattern AdditionalEditBox :: ResourceId pattern AdditionalEditBox = ResourceId 5 +pattern TargetGhcEditBox :: ResourceId +pattern TargetGhcEditBox = ResourceId 6 +pattern BootstrapGhcEditBox :: ResourceId +pattern BootstrapGhcEditBox = ResourceId 7 +pattern JobsEditBox :: ResourceId +pattern JobsEditBox = ResourceId 8 +pattern BuildConfigEditBox :: ResourceId +pattern BuildConfigEditBox = ResourceId 9 +pattern PatchesEditBox :: ResourceId +pattern PatchesEditBox = ResourceId 10 +pattern CrossTargetEditBox :: ResourceId +pattern CrossTargetEditBox = ResourceId 11 +pattern AddConfArgsEditBox :: ResourceId +pattern AddConfArgsEditBox = ResourceId 12 +pattern OvewrwiteVerEditBox :: ResourceId +pattern OvewrwiteVerEditBox = ResourceId 13 +pattern BuildFlavourEditBox :: ResourceId +pattern BuildFlavourEditBox = ResourceId 14 +pattern BuildSystemEditBox :: ResourceId +pattern BuildSystemEditBox = ResourceId 15 + -- | 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 @@ -65,8 +117,9 @@ data Name = AllTools -- ^ The main list widget | Singular Tool -- ^ The particular list for each tool | KeyInfoBox -- ^ The text box widget with action informacion | TutorialBox -- ^ The tutorial widget - | ContextBox -- ^ The Context Menu for a Tool - | AdvanceInstallBox -- ^ The Menu for AdvanceInstall + | ContextBox -- ^ The resource for Context Menu + | CompileGHCBox -- ^ The resource for CompileGHC Menu + | AdvanceInstallBox -- ^ The resource for AdvanceInstall Menu | MenuElement ResourceId -- ^ Each element in a Menu. Resources must not be share for visible -- Menus, but MenuA and MenuB can share resources if they both are -- invisible, or just one of them is visible. @@ -79,6 +132,7 @@ data Mode = Navigation | Tutorial | ContextPanel | AdvanceInstallPanel + | CompileGHCPanel deriving (Eq, Show, Ord) installedSign :: String diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 6eef715..6ee02a9 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -194,15 +194,14 @@ createEditableInput name validator = FieldInput initEdit validateEditContent "" let borderBox = amp . Border.border . Brick.padRight Brick.Max editorRender = Edit.renderEditor (Brick.txt . T.unlines) focus edi + isEditorEmpty = Edit.getEditContents edi == [mempty] in case errMsg of - Valid -> - if Edit.getEditContents edi == [mempty] - then borderBox $ renderAsHelpMsg help - else borderBox editorRender - Invalid msg -> - if focus - then borderBox editorRender - else borderBox $ renderAsErrMsg msg + Valid | isEditorEmpty -> borderBox $ renderAsHelpMsg help + | otherwise -> borderBox editorRender + Invalid msg + | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help + | focus -> borderBox editorRender + | otherwise -> borderBox $ renderAsErrMsg msg validateEditContent = validator . T.unlines . Edit.getEditContents initEdit = Edit.editorText name (Just 1) "" diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs new file mode 100644 index 0000000..bd21287 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -0,0 +1,177 @@ +{-# 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.CompileGHC (CompileGHCOptions, CompileGHCMenu, 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, BuildSystem (Hadrian)) +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 Data.Versions (Version, version) +import System.FilePath (isPathSeparator) +import Control.Applicative (Alternative((<|>))) +import Text.Read (readEither) + +data CompileGHCOptions = CompileGHCOptions + { _bootstrapGhc :: Either Version FilePath + , _jobs :: Maybe Int + , _buildConfig :: Maybe FilePath + , _patches :: Maybe (Either FilePath [URI]) + , _crossTarget :: Maybe T.Text + , _addConfArgs :: [T.Text] + , _setCompile :: Bool + , _ovewrwiteVer :: Maybe Version + , _buildFlavour :: Maybe String + , _buildSystem :: Maybe BuildSystem + , _isolateDir :: Maybe FilePath + } deriving (Eq, Show) + +makeLenses ''CompileGHCOptions + +type CompileGHCMenu = Menu CompileGHCOptions Name + +create :: KeyCombination -> CompileGHCMenu +create k = Menu.createMenu CompileGHCBox initialState k buttons fields + where + initialState = + CompileGHCOptions + (Right "") + Nothing + Nothing + Nothing + Nothing + [] + False + 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 + + bootstrapV :: T.Text -> Either Menu.ErrorMessage (Either Version FilePath) + 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" + 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 + + 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 + + patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) + patchesV = whenEmpty Nothing readPatches + where + readUri :: T.Text -> Either String URI + readUri = first show . parseURI . UTF8.fromString . T.unpack + 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 = whenEmpty Nothing (Right . Just . T.unpack) + + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] + additionalValidator = Right . T.split isSpace + + systemV :: T.Text -> Either Menu.ErrorMessage (Maybe BuildSystem) + systemV = whenEmpty Nothing readSys + where + readSys i + | T.toLower i == "hadrian" = Right $ Just Hadrian + | T.toLower i == "make" = Right $ Just Hadrian + | otherwise = Left "Not a valid Build System" + + fields = + [ Menu.createEditableField (Common.MenuElement Common.BootstrapGhcEditBox) bootstrapV bootstrapGhc + & Menu.fieldLabelL .~ "bootstrap-ghc" + & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)" + & Menu.fieldStatusL .~ Menu.Invalid "Invalid Empty value" + , 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.BuildConfigEditBox) filepathV buildConfig + & Menu.fieldLabelL .~ "build config" + & Menu.fieldHelpMsgL .~ "Absolute path to build config file" + , 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 bindist configure, prefix with '-- ' (longopts)" + , 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.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 .~ "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" + & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" + ] + + buttons = [ + Menu.createButtonField (Common.MenuElement Common.OkButton) + & Menu.fieldLabelL .~ "Compile" + & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below" + ] + +handler :: BrickEvent Name e -> EventM Name CompileGHCMenu () +handler = Menu.handlerMenu + + +draw :: CompileGHCMenu -> Widget Name +draw = Common.frontwardLayer "Compile GHC" . Menu.drawMenu diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index fe481c3..e3d6c01 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -27,6 +27,7 @@ import qualified GHCup.Brick.BrickState as AppState import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu 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 Control.Monad.Reader ( ReaderT(runReaderT) ) @@ -65,6 +66,7 @@ brickMain s = do initial_list (ContextMenu.create e exit_key) (AdvanceInstall.create (bQuit . keyBindings $ s )) + (CompileGHC.create exit_key) (keyBindings s) Common.Navigation in Brick.defaultMain initapp initstate