hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Visuals for compiling HLS

This commit is contained in:
Luis Morillo 2024-03-04 17:32:22 +01:00
parent cd8d13ff2b
commit 0b6e9289fc
8 changed files with 227 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ghcup.cabal
View File

@ -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

2
lib-tui/GHCup/Brick/Actions.hs
View File

@ -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 ()

25
lib-tui/GHCup/Brick/App.hs
View File

@ -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

2
lib-tui/GHCup/Brick/BrickState.hs
View File

@ -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
}

18
lib-tui/GHCup/Brick/Common.hs
View File

@ -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

174
lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs Normal file
View File

@ -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

14
lib-tui/GHCup/Brick/Widgets/Menus/Context.hs
View File

@ -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

2
lib-tui/GHCup/BrickMain.hs
View File

@ -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