diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs deleted file mode 100644 index fee22488..00000000 --- a/app/ghcup/BrickMain.hs +++ /dev/null @@ -1,1046 +0,0 @@ -{-# 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 ViewPatterns #-} - -module BrickMain where - -import GHCup -import GHCup.Download -import GHCup.Errors -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.Logger -import GHCup.Prelude.Process -import GHCup.Prompts - -import Brick - ( BrickEvent(VtyEvent, MouseDown), - App(..), - Padding(Max, Pad), - AttrMap, - EventM, - Size(..), - Widget(..), - ViewportType (Vertical), - (<+>), - (<=>)) -import qualified Brick -import Brick.Widgets.Border ( hBorder, borderWithLabel) -import Brick.Widgets.Border.Style ( unicode ) -import Brick.Widgets.Center ( center, centerLayer ) -import qualified Brick.Widgets.List as L -import Brick.Focus (FocusRing) -import qualified Brick.Focus as F -import Control.Applicative -import Control.Exception.Safe -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail ( MonadFail ) -#endif -import Control.Monad.Reader -import Control.Monad.Trans.Except -import Control.Monad.Trans.Resource -import Data.Bool -import Data.Functor -import Data.Function ( (&), on) -import Data.List -import Data.Maybe -import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) -import Data.Vector ( Vector - - ) -import Data.Versions hiding (Lens') -import Haskus.Utils.Variant.Excepts -import Prelude hiding ( appendFile ) -import System.Exit -import System.IO.Unsafe -import System.Process ( system ) -import Text.PrettyPrint.HughesPJClass ( prettyShow ) -import URI.ByteString - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy as L -import qualified Graphics.Vty as Vty -import qualified Data.Vector as V -import System.Environment (getExecutablePath) -#if !IS_WINDOWS -import GHCup.Prelude.File -import System.FilePath -import qualified System.Posix.Process as SPP -#endif - -import Optics.TH (makeLenses, makeLensesFor) -import Optics.State (use) -import Optics.State.Operators ( (.=), (%=), (<%=)) -import Optics.Operators ((.~), (^.), (%~)) -import Optics.Getter (view) -import Optics.Lens (Lens', lens, toLensVL) - -{- Brick's widget: -It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime) -and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across - -Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing -the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). - -- To build a SectionList use the safe constructor sectionList -- To access sections use the lens provider sectionL and the name of the section you'd like to access -- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not - modify the vector length - --} - -data GenericSectionList n t e - = GenericSectionList - { sectionListFocusRing :: FocusRing n -- ^ The FocusRing for all sections - , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A key-value vector - , sectionListName :: n -- ^ The section list name - } - -makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList - -type SectionList n e = GenericSectionList n V.Vector e - - --- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. -sectionList :: Foldable t - => n -- The name of the section list - -> [(n, t e)] -- a list of tuples (section name, collection of elements) - -> Int - -> GenericSectionList n t e -sectionList name elements height - = GenericSectionList - { sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements] - , sectionListElements = V.fromList [L.list section_name els height | (section_name, els) <- elements] - , sectionListName = name - } --- | This lens constructor, takes a name and looks if a section has such a name. --- Used to dispatch events to sections. It is a partial function only meant to --- be used with the FocusRing inside GenericSectionList -sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e) -sectionL section_name = lens g s - where is_section_name = (== section_name) . L.listName - g section_list = - let elms = section_list ^. sectionListElementsL - zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. - in fromMaybe zeroth (V.find is_section_name elms) - s gl@(GenericSectionList _ elms _) list = - case V.findIndex is_section_name elms of - Nothing -> gl - Just i -> let new_elms = V.update elms (V.fromList [(i, list)]) - in gl & sectionListElementsL .~ new_elms - -moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () -moveDown = do - ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of - Nothing -> pure () - Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event. - current_list <- use (sectionL l) - let current_idx = L.listSelected current_list - list_length = current_list & length - if current_idx == Just (list_length - 1) - then do - new_focus <- sectionListFocusRingL <%= F.focusNext - case F.focusGetCurrent new_focus of - Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick - Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToBeginning) - else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveDown - -moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () -moveUp = do - ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of - Nothing -> pure () - Just l -> do -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event. - current_list <- use (sectionL l) - let current_idx = L.listSelected current_list - if current_idx == Just 0 - then do - new_focus <- sectionListFocusRingL <%= F.focusPrev - case F.focusGetCurrent new_focus of - Nothing -> pure () - Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToEnd) - else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveUp - --- | Handle events for list cursor movement. Events handled are: --- --- * Up (up arrow key). If first element of section, then jump prev section --- * Down (down arrow key). If last element of section, then jump next section --- * Page Up (PgUp) --- * Page Down (PgDown) --- * Go to next section (Tab) --- * Go to prev section (BackTab) -handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n) - => BrickEvent n a - -> EventM n (GenericSectionList n t e) () -handleGenericListEvent (VtyEvent (Vty.EvResize _ _)) = pure () -handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext -handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev -handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _) = moveDown -handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _) = moveUp -handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown [])) = moveDown -handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp -handleGenericListEvent (VtyEvent ev) = do - ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of - Nothing -> pure () - Just l -> Brick.zoom (toLensVL $ sectionL l) $ L.handleListEvent ev -handleGenericListEvent _ = pure () - --- This re-uses Brick.Widget.List.renderList -renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e)) - => (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element - -> Bool -- ^ Whether the section list has focus - -> GenericSectionList n t e -- ^ The section list to render - -> Widget n -renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) = - Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $ - V.ifoldl' (\(!accWidget) !i list -> - let hasFocusList = sectionIsFocused list - makeVisible = if hasFocusList then Brick.visibleRegion (Brick.Location (c, r)) (1, 1) else id - appendBorder = if i == 0 then id else (hBorder <=>) - newWidget = appendBorder (makeVisible $ renderInnerList hasFocusList list) - in accWidget <=> newWidget - ) - Brick.emptyWidget - elms - where - -- A section is focused if the whole thing is focused, and the inner list has focus - sectionIsFocused :: L.GenericList n t e -> Bool - sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus) - - renderInnerList :: Bool -> L.GenericList n t e -> Widget n - renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l - - -- compute the location to focus on within the active section - (c, r) :: (Int, Int) = case sectionListSelectedElement ge of - Nothing -> (0, 0) - Just (selElIx, _) -> (0, selElIx) - - --- | Equivalent to listSelectedElement -sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) -sectionListSelectedElement generic_section_list = do - current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent - let current_section = generic_section_list ^. sectionL current_focus - L.listSelectedElement current_section - -{- Brick app data structures. - -In this section we define the state, the widgets and the core data structures which we will be using for the brick app. - --} - -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 - deriving (Eq, Ord, Show) - -data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord) - -installedSign :: String -#if IS_WINDOWS -installedSign = "I " -#else -installedSign = "✓ " -#endif - -setSign :: String -#if IS_WINDOWS -setSign = "IS" -#else -setSign = "✔✔" -#endif - -notInstalledSign :: String -#if IS_WINDOWS -notInstalledSign = "X " -#else -notInstalledSign = "✗ " -#endif - - -data BrickData = BrickData - { _lr :: [ListResult] - } - deriving Show - -makeLenses ''BrickData - -data BrickSettings = BrickSettings { _showAllVersions :: Bool} - --deriving Show - -makeLenses ''BrickSettings - -type BrickInternalState = SectionList Name ListResult - -data BrickState = BrickState - { _appData :: BrickData - , _appSettings :: BrickSettings - , _appState :: BrickInternalState - , _appKeys :: KeyBindings - , _mode :: Mode - } - --deriving Show - -makeLenses ''BrickState - -app :: AttrMap -> AttrMap -> App BrickState () Name -app attrs dimAttrs = - App { appDraw = drawUI dimAttrs - , appHandleEvent = eventHandler - , appStartEvent = return () - , appAttrMap = const attrs - , appChooseCursor = Brick.showFirstCursor - } - - -{- Drawing. - -The section for creating our widgets. - --} - -showKey :: Vty.Key -> String -showKey (Vty.KChar c) = [c] -showKey Vty.KUp = "↑" -showKey Vty.KDown = "↓" -showKey key = tail (show key) - -showMod :: Vty.Modifier -> String -showMod = tail . show - - -drawNavigation :: AttrMap -> BrickState -> Widget Name -drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} - = Brick.padBottom Max - ( Brick.withBorderStyle unicode - $ borderWithLabel (Brick.str "GHCup") - (center (header <=> hBorder <=> renderList' _appState)) - ) - <=> footer - where - footer = - Brick.withAttr helpAttr - . Brick.txtWrap - . T.pack - . foldr1 (\x y -> x <> " " <> y) - . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) - $ keyHandlers _appKeys - header = - minHSize 2 Brick.emptyWidget - <+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool") - <+> minHSize 15 (Brick.str "Version") - <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags") - <+> Brick.padLeft (Pad 5) (Brick.str "Notes") - renderList' bis = - let allElements = V.concatMap L.listElements $ sectionListElements bis - minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements - minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements - in Brick.withDefAttr L.listAttr $ renderSectionList (renderItem minTagSize minVerSize) True bis - renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = - let marks = if - | lSet -> (Brick.withAttr setAttr $ Brick.str setSign) - | lInstalled -> (Brick.withAttr installedAttr $ Brick.str installedSign) - | otherwise -> (Brick.withAttr notInstalledAttr $ Brick.str notInstalledSign) - ver = case lCross of - Nothing -> T.unpack . prettyVer $ lVer - Just c -> T.unpack (c <> "-" <> prettyVer lVer) - dim - | lNoBindist && not lInstalled - && not b -- TODO: overloading dim and active ignores active - -- so we hack around it here - = Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist") - | otherwise = id - hooray - | elem Latest lTag' && not lInstalled = - Brick.withAttr hoorayAttr - | otherwise = id - in hooray $ dim - ( marks - <+> Brick.padLeft (Pad 2) - ( minHSize 6 - (printTool lTool) - ) - <+> minHSize minVerSize (Brick.str ver) - <+> (let l = catMaybes . fmap printTag $ sort lTag' - in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l - then Brick.emptyWidget - else foldr1 (\x y -> x <+> Brick.str "," <+> y) l - ) - <+> Brick.padLeft (Pad 5) - ( let notes = printNotes listResult - in if null notes - then Brick.emptyWidget - else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes - ) - <+> Brick.vLimit 1 (Brick.fill ' ') - ) - - printTag Recommended = Just $ Brick.withAttr recommendedAttr $ Brick.str "recommended" - printTag Latest = Just $ Brick.withAttr latestAttr $ Brick.str "latest" - printTag Prerelease = Just $ Brick.withAttr prereleaseAttr $ Brick.str "prerelease" - printTag Nightly = Just $ Brick.withAttr nightlyAttr $ Brick.str "nightly" - printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) - printTag Old = Nothing - printTag LatestPrerelease = Just $ Brick.withAttr latestPrereleaseAttr $ Brick.str "latest-prerelease" - printTag LatestNightly = Just $ Brick.withAttr latestNightlyAttr $ Brick.str "latest-nightly" - printTag (UnknownTag t) = Just $ Brick.str t - - printTool Cabal = Brick.str "cabal" - printTool GHC = Brick.str "GHC" - printTool GHCup = Brick.str "GHCup" - printTool HLS = Brick.str "HLS" - printTool Stack = Brick.str "Stack" - - printNotes ListResult {..} = - (if hlsPowered then [Brick.withAttr hlsPoweredAttr $ Brick.str "hls-powered"] else mempty - ) - ++ (if lStray then [Brick.withAttr strayAttr $ Brick.str "stray"] else mempty) - ++ (case lReleaseDay of - Nothing -> mempty - Just d -> [Brick.withAttr dayAttr $ Brick.str (show d)]) - - minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') - -drawTutorial :: Widget Name -drawTutorial = - let - mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - txt_separator = hBorder <+> Brick.str " o " <+> hBorder - in centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Tutorial") - $ Brick.vBox - (fmap center - [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] - , txt_separator - , mkTextBox [ - Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr installedAttr (Brick.str installedSign) - , Brick.txtWrap " means that the tool is installed but not in used" - ] - , Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr setAttr (Brick.str setSign) - , Brick.txtWrap " means that the tool is installed and in used" - ] - , Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr notInstalledAttr (Brick.str notInstalledSign) - , Brick.txt " means that the tool isn't installed" - ] - ] - , txt_separator - , mkTextBox [ - Brick.hBox [ - Brick.withAttr recommendedAttr $ Brick.str "recommended" - , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental" - ] - , Brick.hBox [ - Brick.withAttr latestAttr $ Brick.str "latest" - , Brick.txtWrap " tag is for the latest distributed version of the tool" - ] - , Brick.hBox [ - Brick.withAttr latestAttr $ Brick.str "hls-powered" - , Brick.txt " denotes the compiler version supported by the currently set (" - , Brick.withAttr setAttr (Brick.str setSign) - , Brick.txt ") hls" - ] - , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" - ] - , Brick.txt " " - ]) - <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial") - -drawKeyInfo :: KeyBindings -> Widget Name -drawKeyInfo KeyBindings {..} = - let - mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods)) - in centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Key Actions") - $ Brick.vBox [ - center $ - mkTextBox [ - Brick.hBox [ - Brick.txt "Press " - , keyToWidget bUp, Brick.txt " and ", keyToWidget bDown - , Brick.txtWrap " to navigate the list of tools" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bInstall - , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bSet - , Brick.txtWrap " to set a tool as the one for use" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bUninstall - , Brick.txtWrap " to uninstall a tool" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bChangelog - , Brick.txtWrap " to open the tool's changelog. It will open a web browser" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bShowAllVersions - , Brick.txtWrap " to show older version of each tool" - ] - ] - ] - <=> 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"] - -drawUI :: AttrMap -> BrickState -> [Widget Name] -drawUI dimAttrs st = - let navg = drawNavigation dimAttrs st - in case st ^. mode of - Navigation -> [navg] - Tutorial -> [drawTutorial, navg] - KeyInfo -> [drawKeyInfo (st ^. appKeys), navg] - -{- Attributes - --} - - -defaultAttributes :: Bool -> AttrMap -defaultAttributes no_color = Brick.attrMap - Vty.defAttr - [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) - , (L.listSelectedAttr , Vty.defAttr) - , (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red) - , (setAttr , Vty.defAttr `withForeColor` Vty.green) - , (installedAttr , Vty.defAttr `withForeColor` Vty.green) - , (recommendedAttr , Vty.defAttr `withForeColor` Vty.green) - , (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green) - , (latestAttr , Vty.defAttr `withForeColor` Vty.yellow) - , (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red) - , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) - , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) - , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) - , (compiledAttr , Vty.defAttr `withForeColor` Vty.blue) - , (strayAttr , Vty.defAttr `withForeColor` Vty.blue) - , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) - , (helpAttr , Vty.defAttr `withStyle` Vty.italic) - , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) - ] - where - withForeColor | no_color = const - | otherwise = Vty.withForeColor - - withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo - | otherwise = Vty.withBackColor - - withStyle = Vty.withStyle - - -notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName -latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName -compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName - -notInstalledAttr = Brick.attrName "not-installed" -setAttr = Brick.attrName "set" -installedAttr = Brick.attrName "installed" -recommendedAttr = Brick.attrName "recommended" -hlsPoweredAttr = Brick.attrName "hls-powered" -latestAttr = Brick.attrName "latest" -latestPrereleaseAttr = Brick.attrName "latest-prerelease" -latestNightlyAttr = Brick.attrName "latest-nightly" -prereleaseAttr = Brick.attrName "prerelease" -nightlyAttr = Brick.attrName "nightly" -compiledAttr = Brick.attrName "compiled" -strayAttr = Brick.attrName "stray" -dayAttr = Brick.attrName "day" -helpAttr = Brick.attrName "help" -hoorayAttr = Brick.attrName "hooray" - -dimAttributes :: Bool -> AttrMap -dimAttributes no_color = Brick.attrMap - (Vty.defAttr `Vty.withStyle` Vty.dim) - [ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? - , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) - ] - where - withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo - | otherwise = Vty.withBackColor - -{- Handlers - --} - -keyHandlers :: KeyBindings - -> [ ( KeyCombination - , BrickSettings -> String - , EventM Name BrickState () - ) - ] -keyHandlers KeyBindings {..} = - [ (bQuit, const "Quit" , Brick.halt) - , (bInstall, const "Install" , withIOAction install') - , (bUninstall, const "Uninstall", withIOAction del') - , (bSet, const "Set" , withIOAction set') - , (bChangelog, const "ChangeLog", withIOAction changelog') - , ( bShowAllVersions - , \BrickSettings {..} -> - if _showAllVersions then "Don't show all versions" else "Show all versions" - , hideShowHandler' (not . _showAllVersions) - ) - , (bUp, const "Up", Brick.zoom (toLensVL appState) moveUp) - , (bDown, const "Down", Brick.zoom (toLensVL appState) moveDown) - , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) - ] - where - --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () - hideShowHandler' f = do - app_settings <- use appSettings - let - vers = f app_settings - newAppSettings = app_settings & showAllVersions .~ vers - ad <- use appData - current_app_state <- use appState - appSettings .= newAppSettings - appState .= constructList ad newAppSettings (Just current_app_state) - - -tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () -tutorialHandler ev = - case ev of - VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation - _ -> pure () - -keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () -keyInfoHandler ev = do - case ev of - VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation - VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial - _ -> pure () - -navigationHandler :: BrickEvent Name e -> EventM Name BrickState () -navigationHandler ev = do - AppState { keyBindings = kb } <- liftIO $ readIORef settings' - case ev of - inner_event@(VtyEvent (Vty.EvKey key _)) -> - case find (\(key', _, _) -> key' == KeyCombination key []) (keyHandlers kb) of - Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event - Just (_, _, handler) -> handler - inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event - -eventHandler :: BrickEvent Name e -> EventM Name BrickState () -eventHandler ev = do - m <- use mode - case m of - KeyInfo -> keyInfoHandler ev - Tutorial -> tutorialHandler ev - Navigation -> navigationHandler ev - - -{- Core Logic. - -This section defines the IO actions we can execute within the Brick App: - - Install - - Set - - UnInstall - - Launch the Changelog - --} - --- | Suspend the current UI and run an IO action in terminal. If the --- IO action returns a Left value, then it's thrown as userError. -withIOAction :: (Ord n, Eq n) - => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) - -> EventM n BrickState () -withIOAction action = do - as <- Brick.get - case sectionListSelectedElement (view appState as) of - Nothing -> pure () - Just (curr_ix, e) -> do - Brick.suspendAndResume $ do - settings <- readIORef settings' - flip runReaderT settings $ action (curr_ix, e) >>= \case - Left err -> liftIO $ putStrLn ("Error: " <> err) - Right _ -> liftIO $ putStrLn "Success" - getAppData Nothing >>= \case - Right data' -> do - putStrLn "Press enter to continue" - _ <- getLine - pure (updateList data' as) - Left err -> throwIO $ userError err - - --- | Update app data and list internal state based on new evidence. --- This synchronises @BrickInternalState@ with @BrickData@ --- and @BrickSettings@. -updateList :: BrickData -> BrickState -> BrickState -updateList appD BrickState{..} = - let newInternalState = constructList appD _appSettings (Just _appState) - in BrickState { _appState = newInternalState - , _appData = appD - , _appSettings = _appSettings - , _appKeys = _appKeys - , _mode = Navigation - } - -constructList :: BrickData - -> BrickSettings - -> Maybe BrickInternalState - -> BrickInternalState -constructList appD settings = - replaceLR (filterVisible (_showAllVersions settings)) - (_lr appD) - --- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 -selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState -selectBy tool predicate internal_state = - let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) - tool_lens = sectionL (Singular tool) - in internal_state - & sectionListFocusRingL .~ new_focus - & tool_lens %~ L.listMoveTo 0 -- We move to 0 first - & tool_lens %~ L.listFindBy predicate -- The lookup by the predicate. - --- | Select the latests GHC tool -selectLatest :: BrickInternalState -> BrickInternalState -selectLatest = selectBy GHC (elem Latest . lTag) - - --- | Replace the @appState@ or construct it based on a filter function --- and a new @[ListResult]@ evidence. --- When passed an existing @appState@, tries to keep the selected element. -replaceLR :: (ListResult -> Bool) - -> [ListResult] - -> Maybe BrickInternalState - -> BrickInternalState -replaceLR filterF list_result s = - let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) - newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] - newSectionList = sectionList AllTools newVec 1 - in case oldElem of - Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList - Nothing -> selectLatest newSectionList - where - toolEqual e1 e2 = - lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 - - -filterVisible :: Bool -> ListResult -> Bool -filterVisible v e | lInstalled e = True - | v - , Nightly `notElem` lTag e = True - | not v - , Old `notElem` lTag e - , Nightly `notElem` lTag e = True - | otherwise = (Old `notElem` lTag e) && - (Nightly `notElem` lTag e) - - -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => (Int, ListResult) - -> m (Either String ()) -install' (_, ListResult {..}) = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - - let run = - runResourceT - . runE - @'[ AlreadyInstalled - , ArchiveResult - , UnknownArchive - , FileDoesNotExistError - , CopyError - , NoDownload - , NotInstalled - , BuildFailed - , TagNotFound - , DigestError - , ContentLengthError - , GPGError - , DownloadFailed - , DirNotEmpty - , NoUpdate - , TarDirDoesNotExist - , FileAlreadyExistsError - , ProcessError - , ToolShadowed - , UninstallFailed - , MergeFileTreeError - , NoCompatiblePlatform - , GHCup.Errors.ParseError - , UnsupportedSetupCombo - , DistroNotFound - , NoCompatibleArch - ] - - run (do - ce <- liftIO $ fmap (either (const Nothing) Just) $ - try @_ @SomeException $ getExecutablePath >>= canonicalizePath - 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) - Cabal -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls - liftE $ installCabalBin lVer GHCupInternal False $> (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) - Stack -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls - liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) - ) - >>= \case - VRight (vi, Dirs{..}, Just ce) -> do - forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg - case lTool of - GHCup -> do -#if !IS_WINDOWS - up <- liftIO $ fmap (either (const Nothing) Just) - $ try @_ @SomeException $ canonicalizePath (binDir "ghcup" <.> exeExt) - when ((normalise <$> up) == Just (normalise ce)) $ - -- TODO: track cli arguments of previous invocation - liftIO $ SPP.executeFile ce False ["tui"] Nothing -#else - logInfo "Please restart 'ghcup' for the changes to take effect" -#endif - _ -> pure () - pure $ Right () - VRight (vi, _, _) -> do - forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg - logInfo "Please restart 'ghcup' for the changes to take effect" - pure $ Right () - VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () - VLeft (V NoUpdate) -> pure $ Right () - VLeft e -> pure $ Left $ prettyHFError e <> "\n" - <> "Also check the logs in ~/.ghcup/logs" - - -set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => (Int, ListResult) - -> m (Either String ()) -set' input@(_, ListResult {..}) = do - settings <- liftIO $ readIORef settings' - - let run = - flip runReaderT settings - . runResourceT - . runE - @'[ AlreadyInstalled - , ArchiveResult - , UnknownArchive - , FileDoesNotExistError - , CopyError - , NoDownload - , NotInstalled - , BuildFailed - , TagNotFound - , DigestError - , ContentLengthError - , GPGError - , DownloadFailed - , DirNotEmpty - , NoUpdate - , TarDirDoesNotExist - , FileAlreadyExistsError - , ProcessError - , ToolShadowed - , UninstallFailed - , MergeFileTreeError - , NoCompatiblePlatform - , GHCup.Errors.ParseError - , UnsupportedSetupCombo - , DistroNotFound - , NoCompatibleArch - ] - - run (do - case lTool of - GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> () - Cabal -> liftE $ setCabal lVer $> () - HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> () - Stack -> liftE $ setStack lVer $> () - GHCup -> do - promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: " - case promptAnswer of - PromptYes -> do - void $ liftE $ upgradeGHCup Nothing False False - PromptNo -> pure () - ) - >>= \case - VRight _ -> pure $ Right () - VLeft e -> case e of - (V (NotInstalled tool _)) -> do - promptAnswer <- getUserPromptResponse userPrompt - case promptAnswer of - PromptYes -> do - res <- install' input - case res of - (Left err) -> pure $ Left err - (Right _) -> do - logInfo "Setting now..." - set' input - - PromptNo -> pure $ Left (prettyHFError e) - where - userPrompt = L.toStrict . B.toLazyText . B.fromString $ - "This Version of " - <> show tool - <> " you are trying to set is not installed.\n" - <> "Would you like to install it first? [Y/N]: " - - _ -> pure $ Left (prettyHFError e) - - - -del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) - => (Int, ListResult) - -> m (Either String ()) -del' (_, ListResult {..}) = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - - let run = runE @'[NotInstalled, UninstallFailed] - - run (do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls - case lTool of - GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi - Cabal -> liftE $ rmCabalVer lVer $> vi - HLS -> liftE $ rmHLSVer lVer $> vi - Stack -> liftE $ rmStackVer lVer $> vi - GHCup -> pure Nothing - ) - >>= \case - VRight vi -> do - when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) - forM_ (_viPostRemove =<< vi) $ \msg -> - logInfo msg - pure $ Right () - VLeft e -> pure $ Left (prettyHFError e) - - -changelog' :: (MonadReader AppState m, MonadIO m) - => (Int, ListResult) - -> m (Either String ()) -changelog' (_, ListResult {..}) = do - AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - case getChangeLog dls lTool (ToolVersion lVer) of - Nothing -> pure $ Left $ - "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer) - Just uri -> do - case _rPlatform pfreq of - Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing - Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing - FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing - Windows -> do - let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri) - c <- liftIO $ system $ args - case c of - (ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args] - ExitSuccess -> pure $ Right () - - >>= \case - Right _ -> pure $ Right () - Left e -> pure $ Left $ prettyHFError e - - -settings' :: IORef AppState -{-# NOINLINE settings' #-} -settings' = unsafePerformIO $ do - dirs <- getAllDirs - let loggerConfig = LoggerConfig { lcPrintDebug = False - , consoleOutter = \_ -> pure () - , fileOutter = \_ -> pure () - , fancyColors = True - } - newIORef $ AppState defaultSettings - dirs - defaultKeyBindings - (GHCupInfo mempty mempty Nothing) - (PlatformRequest A_64 Darwin Nothing) - loggerConfig - - -brickMain :: AppState - -> IO () -brickMain s = do - writeIORef settings' s - - eAppData <- getAppData (Just $ ghcupInfo s) - case eAppData of - Right ad -> - Brick.defaultMain - (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s))) - (BrickState ad - defaultAppSettings - (constructList ad defaultAppSettings Nothing) - (keyBindings (s :: AppState)) - Navigation - - ) - $> () - Left e -> do - flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) - exitWith $ ExitFailure 2 - - -defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings { _showAllVersions = False} - - -getGHCupInfo :: IO (Either String GHCupInfo) -getGHCupInfo = do - settings <- readIORef settings' - - r <- - flip runReaderT settings - . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError] - $ do - pfreq <- lift getPlatformReq - liftE $ getDownloadsF pfreq - - case r of - VRight a -> pure $ Right a - VLeft e -> pure $ Left (prettyHFError e) - - -getAppData :: Maybe GHCupInfo - -> IO (Either String BrickData) -getAppData mgi = runExceptT $ do - r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi - liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) - settings <- liftIO $ readIORef settings' - - flip runReaderT settings $ do - lV <- listVersions Nothing [] False True (Nothing, Nothing) - pure $ BrickData (reverse lV) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index fd5fa06f..d56e212e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -11,7 +11,7 @@ module Main where #if defined(BRICK) -import BrickMain ( brickMain ) +import GHCup.BrickMain (brickMain) #endif import qualified GHCup.GHC as GHC @@ -24,6 +24,7 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion) import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/ghcup.cabal b/ghcup.cabal index 3873442e..960c74bf 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -80,6 +80,7 @@ common app-common-depends , haskus-utils-variant ^>=3.3 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 + , optics ^>=0.4 , optparse-applicative >=0.15.1.0 && <0.18 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 @@ -92,6 +93,7 @@ common app-common-depends , temporary ^>=1.3 , text ^>=2.0 , time >=1.9.3 && <1.12 + , transformers ^>=0.5 , unordered-containers ^>=0.2 , uri-bytestring ^>=0.3.2.2 , utf8-string ^>=1.0 @@ -109,6 +111,7 @@ common app-common-depends build-depends: libarchive ^>=3.0.3.0 library + import: app-common-depends exposed-modules: GHCup GHCup.Cabal @@ -143,6 +146,7 @@ library GHCup.Utils.Tar GHCup.Utils.Tar.Types GHCup.Utils.URI + GHCup.Utils.Parsers GHCup.Version hs-source-dirs: lib @@ -193,7 +197,6 @@ library , lzma-static ^>=5.2.5.3 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 - , optics ^>=0.4 , os-release ^>=1.0.0 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 @@ -208,10 +211,10 @@ library , temporary ^>=1.3 , text ^>=2.0 , time >=1.9.3 && <1.12 - , transformers ^>=0.5 , unliftio-core ^>=0.2.0.1 , unordered-containers ^>=0.2.10.0 , uri-bytestring ^>=0.3.2.2 + , utf8-string ^>=1.0 , vector >=0.12 && <0.14 , versions >=6.0.5 && <6.1 , word8 ^>=0.1.3 @@ -322,6 +325,55 @@ library ghcup-optparse else build-depends: unix ^>=2.7 || ^>=2.8 +library ghcup-tui + import: app-common-depends + exposed-modules: + GHCup.BrickMain + GHCup.Brick.Widgets.Navigation + GHCup.Brick.Widgets.Tutorial + GHCup.Brick.Widgets.KeyInfo + GHCup.Brick.Widgets.SectionList + GHCup.Brick.Widgets.Menu + 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 + GHCup.Brick.Attributes + GHCup.Brick.Common + + hs-source-dirs: lib-tui + default-language: Haskell2010 + default-extensions: + LambdaCase + MultiWayIf + NamedFieldPuns + PackageImports + RecordWildCards + ScopedTypeVariables + StrictData + TupleSections + + ghc-options: + -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates + + build-depends: + , ghcup + , brick ^>=2.1 + , vty ^>=6.0 || ^>=6.1 || ^>=6.2 + + if !flag(tui) + buildable: False + + if os(windows) + cpp-options: -DIS_WINDOWS + + else + build-depends: unix ^>=2.7 || ^>=2.8 + executable ghcup import: app-common-depends main-is: Main.hs @@ -351,12 +403,8 @@ executable ghcup if flag(tui) cpp-options: -DBRICK - other-modules: BrickMain build-depends: - , brick ^>=2.1 - , transformers ^>=0.5 - , vty ^>=6.0 || ^>=6.1 || ^>=6.2 - , optics ^>=0.4 + , ghcup-tui if os(windows) cpp-options: -DIS_WINDOWS diff --git a/hie.yaml b/hie.yaml index 2c739206..ec8d0caf 100644 --- a/hie.yaml +++ b/hie.yaml @@ -2,6 +2,10 @@ cradle: cabal: - component: "ghcup:lib:ghcup" path: ./lib + - component: "ghcup:lib:ghcup-optparse" + path: ./lib-opt + - component: "ghcup:lib:ghcup-tui" + path: ./lib-tui - component: "ghcup:exe:ghcup" path: ./app/ghcup - component: "ghcup:lib:ghcup-optparse" diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index aa8cfa03..3bda4035 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -52,7 +52,7 @@ import GHCup.OptParse.ToolRequirements import GHCup.OptParse.Nuke import GHCup.Types - +import GHCup.Utils.Parsers (gpgParser, downloaderParser, keepOnParser, platformParser, parseUrlSource) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 7853398a..14433875 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -12,15 +12,14 @@ module GHCup.OptParse.Common where import GHCup import GHCup.Download -import GHCup.Errors import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils +import qualified GHCup.Utils.Parsers as Parsers import GHCup.Prelude import GHCup.Prelude.Process import GHCup.Prelude.Logger -import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent @@ -43,65 +42,26 @@ import Data.Bifunctor import Data.Char import Data.Either import Data.Functor -import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix ) +import Data.List ( nub, isPrefixOf, stripPrefix ) import Data.Maybe -import Data.Text ( Text ) -import Data.Time.Calendar ( Day ) -import Data.Time.Format ( parseTimeM, defaultTimeLocale ) import Data.Versions -import Data.Void import qualified Data.Vector as V import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) -import Safe +import Safe (lastMay) import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag ) -import URI.ByteString hiding (parseURI) -import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Map.Strict as M import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as LE -import qualified Data.Text.Lazy as LT -import qualified Text.Megaparsec as MP import qualified System.FilePath.Posix as FP import GHCup.Version import Control.Exception (evaluate) import qualified Cabal.Config as CC - - ------------- - --[ Types ]-- - ------------- - --- a superset of ToolVersion -data SetToolVersion = SetGHCVersion GHCTargetVersion - | SetToolVersion Version - | SetToolTag Tag - | SetToolDay Day - | SetRecommended - | SetNext - deriving (Eq, Show) - -prettyToolVer :: ToolVersion -> String -prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' -prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' -prettyToolVer (ToolTag t) = show t -prettyToolVer (ToolDay day) = show day - -toSetToolVer :: Maybe ToolVersion -> SetToolVersion -toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' -toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' -toSetToolVer (Just (ToolTag t')) = SetToolTag t' -toSetToolVer (Just (ToolDay d')) = SetToolDay d' -toSetToolVer Nothing = SetRecommended - - - - -------------- --[ Parser ]-- -------------- @@ -118,9 +78,9 @@ toolVersionTagArgument criteria tool = mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE" mv _ = "VERSION|TAG|RELEASE_DATE" - parser (Just GHC) = ghcVersionTagEither - parser Nothing = ghcVersionTagEither - parser _ = toolVersionTagEither + parser (Just GHC) = Parsers.ghcVersionTagEither + parser Nothing = Parsers.ghcVersionTagEither + parser _ = Parsers.toolVersionTagEither versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version @@ -129,7 +89,7 @@ versionParser' criteria tool = argument (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion -ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither) +ghcVersionArgument criteria tool = argument (eitherReader Parsers.ghcVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) @@ -171,173 +131,6 @@ invertableSwitch' longopt shortopt defv enmod dismod = optional - --------------------- - --[ Either Parser ]-- - --------------------- - - -platformParser :: String -> Either String PlatformRequest -platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of - Right r -> pure r - Left e -> Left $ errorBundlePretty e - where - archP :: MP.Parsec Void Text Architecture - archP = choice' ((\x -> MP.chunk (T.pack $ archToString x) $> x) <$> ([minBound..maxBound] :: [Architecture])) - platformP :: MP.Parsec Void Text PlatformRequest - platformP = choice' - [ (`PlatformRequest` FreeBSD) - <$> (archP <* MP.chunk "-") - <*> ( MP.chunk "portbld" - *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) - <|> pure Nothing - ) - <* MP.chunk "-freebsd" - ) - , (`PlatformRequest` Darwin) - <$> (archP <* MP.chunk "-") - <*> ( MP.chunk "apple" - *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) - <|> pure Nothing - ) - <* MP.chunk "-darwin" - ) - , (\a d mv -> PlatformRequest a (Linux d) mv) - <$> (archP <* MP.chunk "-") - <*> distroP - <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing - ) - <* MP.chunk "-linux" - ) - , (\a -> PlatformRequest a Windows Nothing) - <$> ((archP <* MP.chunk "-") - <* (MP.chunk "unknown-mingw32" <|> MP.chunk "unknown-windows" <|> MP.chunk "windows")) - ] - distroP :: MP.Parsec Void Text LinuxDistro - distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) - - -uriParser :: String -> Either String URI -uriParser = first show . parseURI . UTF8.fromString - - -absolutePathParser :: FilePath -> Either String FilePath -absolutePathParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid absolute filepath." - -isolateParser :: FilePath -> Either String FilePath -isolateParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid filepath for isolate dir." - --- this accepts cross prefix -ghcVersionTagEither :: String -> Either String ToolVersion -ghcVersionTagEither s' = - second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') - --- this ignores cross prefix -toolVersionTagEither :: String -> Either String ToolVersion -toolVersionTagEither s' = - second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') - -tagEither :: String -> Either String Tag -tagEither s' = case fmap toLower s' of - "recommended" -> Right Recommended - "latest" -> Right Latest - "latest-prerelease" -> Right LatestPrerelease - "latest-nightly" -> Right LatestNightly - ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of - Right x -> Right (Base x) - Left _ -> Left $ "Invalid PVP version for base " <> ver' - other -> Left $ "Unknown tag " <> other - - -ghcVersionEither :: String -> Either String GHCTargetVersion -ghcVersionEither = - first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack - -toolVersionEither :: String -> Either String Version -toolVersionEither = - first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack - - -toolParser :: String -> Either String Tool -toolParser s' | t == T.pack "ghc" = Right GHC - | t == T.pack "cabal" = Right Cabal - | t == T.pack "hls" = Right HLS - | t == T.pack "stack" = Right Stack - | otherwise = Left ("Unknown tool: " <> s') - where t = T.toLower (T.pack s') - -dayParser :: String -> Either String Day -dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right - $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s - - -criteriaParser :: String -> Either String ListCriteria -criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True - | t == T.pack "set" = Right $ ListSet True - | t == T.pack "available" = Right $ ListAvailable True - | t == T.pack "+installed" = Right $ ListInstalled True - | t == T.pack "+set" = Right $ ListSet True - | t == T.pack "+available" = Right $ ListAvailable True - | t == T.pack "-installed" = Right $ ListInstalled False - | t == T.pack "-set" = Right $ ListSet False - | t == T.pack "-available" = Right $ ListAvailable False - | otherwise = Left ("Unknown criteria: " <> s') - where t = T.toLower (T.pack s') - - - -keepOnParser :: String -> Either String KeepDirs -keepOnParser s' | t == T.pack "always" = Right Always - | t == T.pack "errors" = Right Errors - | t == T.pack "never" = Right Never - | otherwise = Left ("Unknown keep value: " <> s') - where t = T.toLower (T.pack s') - - -downloaderParser :: String -> Either String Downloader -downloaderParser s' | t == T.pack "curl" = Right Curl - | t == T.pack "wget" = Right Wget -#if defined(INTERNAL_DOWNLOADER) - | t == T.pack "internal" = Right Internal -#endif - | otherwise = Left ("Unknown downloader value: " <> s') - where t = T.toLower (T.pack s') - -gpgParser :: String -> Either String GPGSetting -gpgParser s' | t == T.pack "strict" = Right GPGStrict - | t == T.pack "lax" = Right GPGLax - | t == T.pack "none" = Right GPGNone - | otherwise = Left ("Unknown gpg setting value: " <> s') - where t = T.toLower (T.pack s') - - - -overWriteVersionParser :: String -> Either String [VersionPattern] -overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack - where - versionPattern :: MP.Parsec Void Text VersionPattern - versionPattern = do - str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%') - if str' /= mempty - then pure (S str') - else fmap (const CabalVer) v_cabal - <|> fmap (const GitBranchName) b_name - <|> fmap (const GitHashShort) s_hash - <|> fmap (const GitHashLong) l_hash - <|> fmap (const GitDescribe) g_desc - <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k" - where - v_cabal = MP.chunk "%v" - b_name = MP.chunk "%b" - s_hash = MP.chunk "%h" - l_hash = MP.chunk "%H" - g_desc = MP.chunk "%g" - - - ------------------ --[ Completers ]-- ------------------ @@ -674,149 +467,6 @@ toolDlCompleter tool = mkCompleter $ \case #endif - - - - - ----------------- - --[ Utilities ]-- - ----------------- - - -fromVersion :: ( HasLog env - , MonadFail m - , MonadReader env m - , HasGHCupInfo env - , HasDirs env - , MonadThrow m - , MonadIO m - , MonadCatch m - ) - => Maybe ToolVersion - -> Tool - -> Excepts - '[ TagNotFound - , DayNotFound - , NextVerNotFound - , NoToolVersionSet - ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion tv = fromVersion' (toSetToolVer tv) - -fromVersion' :: ( HasLog env - , MonadFail m - , MonadReader env m - , HasGHCupInfo env - , HasDirs env - , MonadThrow m - , MonadIO m - , MonadCatch m - ) - => SetToolVersion - -> Tool - -> Excepts - '[ TagNotFound - , DayNotFound - , NextVerNotFound - , NoToolVersionSet - ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion' SetRecommended tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - second Just <$> getRecommended dls tool - ?? TagNotFound Recommended tool -fromVersion' (SetGHCVersion v) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo v tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case - Just (pvp_, vi', mt) -> do - v' <- lift $ pvpToVersion pvp_ "" - when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mt v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolVersion (mkTVer -> v)) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo v tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case - Just (pvp_, vi', mt) -> do - v' <- lift $ pvpToVersion pvp_ "" - when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mt v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolTag Latest) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool -fromVersion' (SetToolDay day) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> case getByReleaseDay dls tool day of - Left ad -> throwE $ DayNotFound day tool ad - Right v -> pure v -fromVersion' (SetToolTag LatestPrerelease) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool -fromVersion' (SetToolTag LatestNightly) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool -fromVersion' (SetToolTag Recommended) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool -fromVersion' (SetToolTag (Base pvp'')) GHC = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC -fromVersion' SetNext tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - next <- case tool of - GHC -> do - set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool - ghcs <- rights <$> lift getInstalledGHCs - (headMay - . tail - . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set) - . cycle - . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y)) - . filter (\GHCTargetVersion {..} -> isNothing _tvTarget) - $ ghcs) ?? NoToolVersionSet tool - Cabal -> do - set <- cabalSet !? NoToolVersionSet tool - cabals <- rights <$> lift getInstalledCabals - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ cabals) ?? NoToolVersionSet tool - HLS -> do - set <- hlsSet !? NoToolVersionSet tool - hlses <- rights <$> lift getInstalledHLSs - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ hlses) ?? NoToolVersionSet tool - Stack -> do - set <- stackSet !? NoToolVersionSet tool - stacks <- rights <$> lift getInstalledStacks - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ stacks) ?? NoToolVersionSet tool - GHCup -> fail "GHCup cannot be set" - let vi = getVersionInfo next tool dls - pure (next, vi) -fromVersion' (SetToolTag t') tool = - throwE $ TagNotFound t' tool - - checkForUpdates :: ( MonadReader env m , HasGHCupInfo env , HasDirs env @@ -847,23 +497,9 @@ checkForUpdates = do where forMM a f = fmap join $ forM a f - logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () logGHCPostRm ghcVer = do cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") (runIdentity . CC.cfgStoreDir <$> CC.readConfig) let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir - -parseUrlSource :: String -> Either String URLSource -parseUrlSource "GHCupURL" = pure GHCupURL -parseUrlSource "StackSetupURL" = pure StackSetupURL -parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') - <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') - -parseNewUrlSource :: String -> Either String NewURLSource -parseNewUrlSource "GHCupURL" = pure NewGHCupURL -parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL -parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') - <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') - diff --git a/lib-opt/GHCup/OptParse/Compile.hs b/lib-opt/GHCup/OptParse/Compile.hs index a9d65c96..032a87da 100644 --- a/lib-opt/GHCup/OptParse/Compile.hs +++ b/lib-opt/GHCup/OptParse/Compile.hs @@ -18,6 +18,7 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion, uriParser, ghcVersionTagEither, isolateParser, overWriteVersionParser) import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ import GHCup.OptParse.Common diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index e8b815f6..79a8d182 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.Config where import GHCup.Errors import GHCup.Types import GHCup.Utils +import GHCup.Utils.Parsers (parseNewUrlSource) import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 4ec5af52..1228eefb 100644 --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -20,6 +20,7 @@ import GHCup import GHCup.Errors import GHCup.Types import GHCup.Utils.Dirs +import GHCup.Utils.Parsers (fromVersion, isolateParser, uriParser) import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/List.hs b/lib-opt/GHCup/OptParse/List.hs index fe56c884..f99c6f7a 100644 --- a/lib-opt/GHCup/OptParse/List.hs +++ b/lib-opt/GHCup/OptParse/List.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.List where import GHCup import GHCup.Prelude import GHCup.Types +import GHCup.Utils.Parsers (dayParser, toolParser, criteriaParser) import GHCup.OptParse.Common import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Prefetch.hs b/lib-opt/GHCup/OptParse/Prefetch.hs index 3550ab7f..17e5bd31 100644 --- a/lib-opt/GHCup/OptParse/Prefetch.hs +++ b/lib-opt/GHCup/OptParse/Prefetch.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where import GHCup import GHCup.Errors import GHCup.Types +import GHCup.Utils.Parsers (fromVersion) import GHCup.Types.Optics import GHCup.Prelude.File import GHCup.Prelude.Logger diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs index 72caeab5..74e5f857 100644 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -11,6 +11,7 @@ module GHCup.OptParse.Run where import GHCup import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion, ghcVersionTagEither, isolateParser, toolVersionTagEither) import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types diff --git a/lib-opt/GHCup/OptParse/Set.hs b/lib-opt/GHCup/OptParse/Set.hs index c4941b9a..94ff3611 100644 --- a/lib-opt/GHCup/OptParse/Set.hs +++ b/lib-opt/GHCup/OptParse/Set.hs @@ -17,6 +17,7 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types +import GHCup.Utils.Parsers (SetToolVersion(..), tagEither, ghcVersionEither, toolVersionEither, fromVersion') import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Test.hs b/lib-opt/GHCup/OptParse/Test.hs index 8ccdef1c..a124c345 100644 --- a/lib-opt/GHCup/OptParse/Test.hs +++ b/lib-opt/GHCup/OptParse/Test.hs @@ -20,6 +20,7 @@ import GHCup import GHCup.Errors import GHCup.Types import GHCup.Utils.Dirs +import GHCup.Utils.Parsers (fromVersion, uriParser) import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Whereis.hs b/lib-opt/GHCup/OptParse/Whereis.hs index d6b269fb..90d8d708 100644 --- a/lib-opt/GHCup/OptParse/Whereis.hs +++ b/lib-opt/GHCup/OptParse/Whereis.hs @@ -18,6 +18,7 @@ import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion) import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs new file mode 100644 index 00000000..d97d615d --- /dev/null +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -0,0 +1,728 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHCup.Brick.Actions where + +import GHCup +import GHCup.Download +import GHCup.Errors +import GHCup.Types.Optics ( getDirs, getPlatformReq, HasLog ) +import GHCup.Types hiding ( LeanAppState(..) ) +import GHCup.Utils +import GHCup.Prelude ( decUTF8Safe, runBothE' ) +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prompts +import GHCup.Brick.Common (BrickData(..), BrickSettings(..), Name(..), Mode(..)) +import qualified GHCup.Brick.Common as Common +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 +import qualified Brick.Focus as F +import Control.Applicative +import Control.Exception.Safe +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Control.Monad.Trans.Resource +import Data.Bool +import Data.Functor +import Data.Function ( (&), on) +import Data.Functor.Identity +import Data.List +import Data.Maybe +import Data.IORef (IORef, readIORef, newIORef, modifyIORef) +import Data.Versions hiding (Lens') +import Haskus.Utils.Variant.Excepts +import Prelude hiding ( appendFile ) +import System.Exit +import System.IO.Unsafe +import System.Process ( system ) +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString + +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy as L +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V +import System.Environment (getExecutablePath) +#if !IS_WINDOWS +import GHCup.Prelude.File +import qualified System.Posix.Process as SPP +#endif + +import System.FilePath + +import Optics.State (use) +import Optics.State.Operators ( (.=)) +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.Utils.Parsers as Utils +import qualified GHCup.HLS as HLS +import qualified Cabal.Config as CC + + + +{- Core Logic. + +This module defines the IO actions we can execute within the Brick App: + - Install + - Set + - UnInstall + - Launch the Changelog + +-} + +-- | Update app data and list internal state based on new evidence. +-- This synchronises @BrickInternalState@ with @BrickData@ +-- and @BrickSettings@. +updateList :: BrickData -> BrickState -> BrickState +updateList appD bst = + let newInternalState = constructList appD (bst ^. appSettings) (Just (bst ^. appState)) + in bst + & appState .~ newInternalState + & appData .~ appD + & mode .~ Navigation + +constructList :: BrickData + -> BrickSettings + -> Maybe BrickInternalState + -> BrickInternalState +constructList appD settings = + replaceLR (filterVisible (_showAllVersions settings)) + (_lr appD) + +-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 +selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState +selectBy tool predicate internal_state = + let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) + tool_lens = sectionL (Singular tool) + in internal_state + & sectionListFocusRingL .~ new_focus + & tool_lens %~ L.listMoveTo 0 -- We move to 0 first + & tool_lens %~ L.listFindBy predicate -- The lookup by the predicate. + +-- | Select the latests GHC tool +selectLatest :: BrickInternalState -> BrickInternalState +selectLatest = selectBy GHC (elem Latest . lTag) + + +-- | Replace the @appState@ or construct it based on a filter function +-- and a new @[ListResult]@ evidence. +-- When passed an existing @appState@, tries to keep the selected element. +replaceLR :: (ListResult -> Bool) + -> [ListResult] + -> Maybe BrickInternalState + -> BrickInternalState +replaceLR filterF list_result s = + let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) + newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList AllTools newVec 1 + in case oldElem of + Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList + Nothing -> selectLatest newSectionList + where + toolEqual e1 e2 = + lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 + + +filterVisible :: Bool -> ListResult -> Bool +filterVisible v e | lInstalled e = True + | v + , Nightly `notElem` lTag e = True + | not v + , Old `notElem` lTag e + , Nightly `notElem` lTag e = True + | otherwise = (Old `notElem` lTag e) && + (Nightly `notElem` lTag e) + +-- | Suspend the current UI and run an IO action in terminal. If the +-- IO action returns a Left value, then it's thrown as userError. +withIOAction :: (Ord n, Eq n) + => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) + -> Brick.EventM n BrickState () +withIOAction action = do + as <- Brick.get + case sectionListSelectedElement (view appState as) of + Nothing -> pure () + Just (curr_ix, e) -> do + Brick.suspendAndResume $ do + settings <- readIORef settings' + flip runReaderT settings $ action (curr_ix, e) >>= \case + Left err -> liftIO $ putStrLn ("Error: " <> err) + Right _ -> liftIO $ putStrLn "Success" + getAppData Nothing >>= \case + Right data' -> do + putStrLn "Press enter to continue" + _ <- getLine + pure (updateList data' as) + Left err -> throwIO $ userError err + +installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => AdvanceInstall.InstallOptions + -> (Int, ListResult) + -> m (Either String ()) +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 + @'[ AlreadyInstalled + , ArchiveResult + , UnknownArchive + , FileDoesNotExistError + , CopyError + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , DirNotEmpty + , NoUpdate + , TarDirDoesNotExist + , FileAlreadyExistsError + , ProcessError + , ToolShadowed + , UninstallFailed + , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch + , InstallSetError + ] + + run (do + ce <- liftIO $ fmap (either (const Nothing) Just) $ + try @_ @SomeException $ getExecutablePath >>= canonicalizePath + dirs <- lift getDirs + case lTool of + GHC -> do + 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 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 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 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 + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + case lTool of + GHCup -> do +#if !IS_WINDOWS + up <- liftIO $ fmap (either (const Nothing) Just) + $ try @_ @SomeException $ canonicalizePath (binDir "ghcup" <.> exeExt) + when ((normalise <$> up) == Just (normalise ce)) $ + -- TODO: track cli arguments of previous invocation + liftIO $ SPP.executeFile ce False ["tui"] Nothing +#else + logInfo "Please restart 'ghcup' for the changes to take effect" +#endif + _ -> pure () + pure $ Right () + VRight (vi, _, _) -> do + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + logInfo "Please restart 'ghcup' for the changes to take effect" + pure $ Right () + VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () + VLeft (V NoUpdate) -> pure $ Right () + 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) + -> m (Either String ()) +set' input@(_, ListResult {..}) = do + settings <- liftIO $ readIORef settings' + + let run = + flip runReaderT settings + . runResourceT + . runE + @'[ AlreadyInstalled + , ArchiveResult + , UnknownArchive + , FileDoesNotExistError + , CopyError + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , DirNotEmpty + , NoUpdate + , TarDirDoesNotExist + , FileAlreadyExistsError + , ProcessError + , ToolShadowed + , UninstallFailed + , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch + ] + + run (do + case lTool of + GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> () + Cabal -> liftE $ setCabal lVer $> () + HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> () + Stack -> liftE $ setStack lVer $> () + GHCup -> do + promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: " + case promptAnswer of + PromptYes -> do + void $ liftE $ upgradeGHCup Nothing False False + PromptNo -> pure () + ) + >>= \case + VRight _ -> pure $ Right () + VLeft e -> case e of + (V (NotInstalled tool _)) -> do + promptAnswer <- getUserPromptResponse userPrompt + case promptAnswer of + PromptYes -> do + res <- install' input + case res of + (Left err) -> pure $ Left err + (Right _) -> do + logInfo "Setting now..." + set' input + + PromptNo -> pure $ Left (prettyHFError e) + where + userPrompt = L.toStrict . B.toLazyText . B.fromString $ + "This Version of " + <> show tool + <> " you are trying to set is not installed.\n" + <> "Would you like to install it first? [Y/N]: " + + _ -> pure $ Left (prettyHFError e) + +logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () +logGHCPostRm ghcVer = do + cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") + (runIdentity . CC.cfgStoreDir <$> CC.readConfig) + let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) + logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir + + +del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) + => (Int, ListResult) + -> m (Either String ()) +del' (_, ListResult {..}) = do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + + let run = runE @'[NotInstalled, UninstallFailed] + + run (do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls + case lTool of + GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi + Cabal -> liftE $ rmCabalVer lVer $> vi + HLS -> liftE $ rmHLSVer lVer $> vi + Stack -> liftE $ rmStackVer lVer $> vi + GHCup -> pure Nothing + ) + >>= \case + VRight vi -> do + when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) + forM_ (_viPostRemove =<< vi) $ \msg -> + logInfo msg + pure $ Right () + VLeft e -> pure $ Left (prettyHFError e) + + +changelog' :: (MonadReader AppState m, MonadIO m) + => (Int, ListResult) + -> m (Either String ()) +changelog' (_, ListResult {..}) = do + AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + case getChangeLog dls lTool (ToolVersion lVer) of + Nothing -> pure $ Left $ + "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer) + Just uri -> do + case _rPlatform pfreq of + Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + Windows -> do + let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri) + c <- liftIO $ system $ args + case c of + (ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args] + ExitSuccess -> pure $ Right () + + >>= \case + 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 + pure $ Left $ + "GHC ver " <> T.unpack (prettyVer v) <> " already installed, remove it first to reinstall" + VLeft (V (DirNotEmpty fp)) -> do + pure $ Left $ + "Install directory " <> fp <> " is not empty." + VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ + case keepDirs (appstate & settings) of + Never -> prettyHFError err + _ -> prettyHFError err <> "\n" + <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) + <> " and the build directory " + <> tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> tmpdir <> " afterwards." + VLeft e -> do + pure $ Left $ prettyHFError e +-- 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) . Utils.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 _)) -> pure $ Left $ + case keepDirs (appstate & settings) of + Never -> prettyHFError err + _ -> prettyHFError err <> "\n" + <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) + <> " and the build directory " + <> tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> tmpdir <> " afterwards." + VLeft e -> do + pure $ Left $ prettyHFError e +-- 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' #-} +settings' = unsafePerformIO $ do + dirs <- getAllDirs + let loggerConfig = LoggerConfig { lcPrintDebug = False + , consoleOutter = \_ -> pure () + , fileOutter = \_ -> pure () + , fancyColors = True + } + newIORef $ AppState defaultSettings + dirs + defaultKeyBindings + (GHCupInfo mempty mempty Nothing) + (PlatformRequest A_64 Darwin Nothing) + loggerConfig + + +getGHCupInfo :: IO (Either String GHCupInfo) +getGHCupInfo = do + settings <- readIORef settings' + + r <- + flip runReaderT settings + . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError] + $ do + pfreq <- lift getPlatformReq + liftE $ getDownloadsF pfreq + + case r of + VRight a -> pure $ Right a + VLeft e -> pure $ Left (prettyHFError e) + + +getAppData :: Maybe GHCupInfo + -> IO (Either String BrickData) +getAppData mgi = runExceptT $ do + r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi + liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) + settings <- liftIO $ readIORef settings' + + flip runReaderT settings $ do + lV <- listVersions Nothing [] False True (Nothing, Nothing) + pure $ BrickData (reverse lV) + +-- + +keyHandlers :: KeyBindings + -> [ ( KeyCombination + , BrickSettings -> String + , Brick.EventM Name BrickState () + ) + ] +keyHandlers KeyBindings {..} = + [ (bQuit, const "Quit" , Brick.halt) + , (bInstall, const "Install" , withIOAction install') + , (bUninstall, const "Uninstall", withIOAction del') + , (bSet, const "Set" , withIOAction set') + , (bChangelog, const "ChangeLog", withIOAction changelog') + , ( bShowAllVersions + , \BrickSettings {..} -> + if _showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . _showAllVersions) + ) + , (bUp, const "Up", Common.zoom appState moveUp) + , (bDown, const "Down", Common.zoom appState moveDown) + , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) + , (KeyCombination Vty.KEnter [], const "advance options", createMenuforTool ) + ] + 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 ContextMenu, but maintain the state of Install/Compile + -- menus. This is especially useful in case the user made a typo and + -- would like to retry the action. + contextMenu .= ContextMenu.create r exitKey + -- Set mode to context + mode .= ContextPanel + pure () + + --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () + hideShowHandler' f = do + app_settings <- use appSettings + let + vers = f app_settings + newAppSettings = app_settings & Common.showAllVersions .~ vers + ad <- use appData + current_app_state <- use appState + appSettings .= newAppSettings + appState .= constructList ad newAppSettings (Just current_app_state) \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs new file mode 100644 index 00000000..b3645b8e --- /dev/null +++ b/lib-tui/GHCup/Brick/App.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module defines the brick App. The pattern is very simple: + +- Pattern match on the Mode +- Dispatch drawing/events to the corresponding widget/s + +In general each widget should know how to draw itself and how to handle its own events, so this +module should only contain: + +- how to draw non-widget information. For example the footer +- how to change between modes (widgets aren't aware of the whole application state) + +-} + +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, compileHLSMenu) +import GHCup.Brick.Common (Mode (..), Name (..)) +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo +import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu +import qualified GHCup.Brick.Widgets.Navigation as Navigation +import qualified GHCup.Brick.Widgets.Tutorial as Tutorial +import qualified GHCup.Brick.Widgets.Menu as Menu +import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall + +import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination)) + +import qualified Brick.Focus as F +import Brick ( + App (..), + AttrMap, + BrickEvent (VtyEvent), + EventM, + Widget (..), + (<=>), + ) +import qualified Brick +import Control.Monad.Reader ( + MonadIO (liftIO), + void, + ) +import Data.IORef (readIORef) +import Data.List (find, intercalate) +import Prelude hiding (appendFile) + +import qualified Graphics.Vty as Vty + +import qualified Data.Text as T + +import Optics.Getter (to) +import Optics.Operators ((^.)) +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 = + App { appDraw = drawUI dimAttrs + , appHandleEvent = eventHandler + , appStartEvent = return () + , appAttrMap = const attrs + , appChooseCursor = Brick.showFirstCursor + } + +drawUI :: AttrMap -> BrickState -> [Widget Name] +drawUI dimAttrs st = + let + footer = Brick.withAttr Attributes.helpAttr + . Brick.txtWrap + . T.pack + . foldr1 (\x y -> x <> " " <> y) + . fmap (\(KeyCombination key mods, pretty_setting, _) + -> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings) + ) + $ Actions.keyHandlers (st ^. appKeys) + navg = Navigation.draw dimAttrs (st ^. appState) <=> footer + in case st ^. mode of + Navigation -> [navg] + Tutorial -> [Tutorial.draw, navg] + KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] + 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 'c') [Vty.MCtrl]) -> mode .= Navigation + VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial + _ -> pure () + +-- | On q, go back to navigation. Else, do nothing +tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () +tutorialHandler ev = + case ev of + VtyEvent (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) -> mode .= Navigation + _ -> pure () + +-- | Tab/Arrows to navigate. +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 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 + +contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState () +contextMenuHandler ev = do + ctx <- use contextMenu + 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 .= Navigation + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel + (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 + (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 + 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 + (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.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 + case m of + KeyInfo -> keyInfoHandler ev + Tutorial -> tutorialHandler ev + Navigation -> navigationHandler ev + ContextPanel -> contextMenuHandler ev + AdvanceInstallPanel -> advanceInstallHandler ev + CompileGHCPanel -> compileGHCHandler ev + CompileHLSPanel -> compileHLSHandler ev diff --git a/lib-tui/GHCup/Brick/Attributes.hs b/lib-tui/GHCup/Brick/Attributes.hs new file mode 100644 index 00000000..8226f46a --- /dev/null +++ b/lib-tui/GHCup/Brick/Attributes.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module defined the attributes. Despite of brick's capability to have a hierarchy of attributes, here +we go for the most-simple-approach: a plain hierarchy +-} + +module GHCup.Brick.Attributes where + +import Brick ( AttrMap) +import qualified Brick +import qualified Brick.Widgets.List as L +import qualified Graphics.Vty as Vty + +defaultAttributes :: Bool -> AttrMap +defaultAttributes no_color = Brick.attrMap + Vty.defAttr + [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) + , (L.listSelectedAttr , Vty.defAttr) + , (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red) + , (setAttr , Vty.defAttr `withForeColor` Vty.green) + , (installedAttr , Vty.defAttr `withForeColor` Vty.green) + , (recommendedAttr , Vty.defAttr `withForeColor` Vty.green) + , (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green) + , (latestAttr , Vty.defAttr `withForeColor` Vty.yellow) + , (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (compiledAttr , Vty.defAttr `withForeColor` Vty.brightCyan) + , (strayAttr , Vty.defAttr `withForeColor` Vty.brightCyan) + , (dayAttr , Vty.defAttr `withForeColor` Vty.brightCyan) + , (helpAttr , Vty.defAttr `withStyle` Vty.italic) + , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) + , (helpMsgAttr , Vty.defAttr `withForeColor` Vty.brightBlack) + , (errMsgAttr , Vty.defAttr `withForeColor` Vty.red) + ] + where + withForeColor | no_color = const + | otherwise = Vty.withForeColor + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor + withStyle = Vty.withStyle + + +notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr :: Brick.AttrName +latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr :: Brick.AttrName +compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr, helpMsgAttr, errMsgAttr :: Brick.AttrName + +notInstalledAttr = Brick.attrName "not-installed" +setAttr = Brick.attrName "set" +installedAttr = Brick.attrName "installed" +recommendedAttr = Brick.attrName "recommended" +hlsPoweredAttr = Brick.attrName "hls-powered" +latestAttr = Brick.attrName "latest" +latestPrereleaseAttr = Brick.attrName "latest-prerelease" +latestNightlyAttr = Brick.attrName "latest-nightly" +prereleaseAttr = Brick.attrName "prerelease" +nightlyAttr = Brick.attrName "nightly" +compiledAttr = Brick.attrName "compiled" +strayAttr = Brick.attrName "stray" +dayAttr = Brick.attrName "day" +helpAttr = Brick.attrName "help" +hoorayAttr = Brick.attrName "hooray" +helpMsgAttr = Brick.attrName "helpMsg" +errMsgAttr = Brick.attrName "errMsg" + +dimAttributes :: Bool -> AttrMap +dimAttributes no_color = Brick.attrMap + (Vty.defAttr `Vty.withStyle` Vty.dim) + [ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? + , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) + ] + where + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs new file mode 100644 index 00000000..ab59b74f --- /dev/null +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -0,0 +1,54 @@ +{-# 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 #-} + +{- +This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common, +but it is better to make a separated module in order to avoid cyclic dependencies. + +This happens because the BrickState is sort of a container for all widgets, +but widgets depends on common functionality, hence: + + BrickState `depends on` Widgets.XYZ `depends on` Common + +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 GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCMenu) +import Optics.TH (makeLenses) +import GHCup.Brick.Widgets.Menus.CompileHLS (CompileHLSMenu) + + +data BrickState = BrickState + { _appData :: BrickData + , _appSettings :: BrickSettings + , _appState :: BrickInternalState + , _contextMenu :: ContextMenu + , _advanceInstallMenu :: AdvanceInstallMenu + , _compileGHCMenu :: CompileGHCMenu + , _compileHLSMenu :: CompileHLSMenu + , _appKeys :: KeyBindings + , _mode :: Mode + } + --deriving Show + +makeLenses ''BrickState diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs new file mode 100644 index 00000000..d9de93a4 --- /dev/null +++ b/lib-tui/GHCup/Brick/Common.hs @@ -0,0 +1,221 @@ +{-# 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 #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternSynonyms #-} + +{- +This module contains common values used across the library. Crucially it contains two important types for the brick app: + +- Name: List all resources (widgets) used by the app. see https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst#resource-names +- Mode: Use to dispatch events and drawings. see: https://github.com/jtdaugherty/brick/issues/476#issuecomment-1629151920 + +-} + +module GHCup.Brick.Common ( + installedSign, + setSign, + notInstalledSign, + showKey, + showMod, + keyToWidget, + separator, + frontwardLayer, + enableScreenReader, + 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 + , CompileGHCButton, CompileHLSButton, CabalProjectEditBox + , CabalProjectLocalEditBox, UpdateCabalCheckBox + ) ) where + +import GHCup.List ( ListResult ) +import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) +import Data.List (intercalate) +import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics.TH (makeLenses) +import Optics.Lens (toLensVL) +import qualified Brick +import qualified Brick.Widgets.Border as Border +import Brick ((<+>)) +import qualified Data.Text as T +import qualified Brick.Widgets.Center as Brick +import qualified Brick.Widgets.Border.Style as Border + +-- We could use regular ADTs but different menus share the same options. +-- example: all of ghcup compile ghc, ghcup compile hls, ghcup install cabal, etc... +-- all have a --set, --force, etc... common arguments. If we went for the ADT we'd end up +-- with SetCompileHLSOption, SetCompileGHCOption, SetInstallCabalOption, etc... +-- which isn't terrible, but verbose enough to reject it. + +-- | 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 CompileGHCButton :: ResourceId +pattern CompileGHCButton = ResourceId 101 +pattern CompileHLSButton :: ResourceId +pattern CompileHLSButton = ResourceId 102 + +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 + +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 +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 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. + + deriving (Eq, Ord, Show) + +-- | Mode type. It helps to dispatch events to different handlers. +data Mode = Navigation + | KeyInfo + | Tutorial + | ContextPanel + | AdvanceInstallPanel + | CompileGHCPanel + | CompileHLSPanel + deriving (Eq, Show, Ord) + +installedSign :: String +#if IS_WINDOWS +installedSign = "I " +#else +installedSign = "✓ " +#endif + +setSign :: String +#if IS_WINDOWS +setSign = "IS" +#else +setSign = "✔✔" +#endif + +notInstalledSign :: String +#if IS_WINDOWS +notInstalledSign = "X " +#else +notInstalledSign = "✗ " +#endif + + +showKey :: Vty.Key -> String +showKey (Vty.KChar c) = [c] +showKey Vty.KUp = "↑" +showKey Vty.KDown = "↓" +showKey key = tail (show key) + +showMod :: Vty.Modifier -> String +showMod = tail . show + +-- | Given a KeyComb, produces a string widget with and user friendly text +keyToWidget :: KeyCombination -> Brick.Widget n +keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods)) + +-- | A section separator with max width. Looks like this: -------- o -------- +separator :: Brick.Widget n +separator = Border.hBorder <+> Brick.str " o " <+> Border.hBorder + +-- | Used to create a layer on top of the main navigation widget (tutorial, info, menus...) +frontwardLayer :: T.Text -> Brick.Widget n -> Brick.Widget n +frontwardLayer layer_name = + Brick.centerLayer + . Brick.hLimitPercent 75 + . Brick.vLimitPercent 50 + . Brick.withBorderStyle Border.unicode + . Border.borderWithLabel (Brick.txt layer_name) + +-- | puts a cursor at the line beginning so It can be read by screen readers +enableScreenReader :: n -> Brick.Widget n -> Brick.Widget n +enableScreenReader n = Brick.putCursor n (Brick.Location (0,0)) +-- |- tip: when debugging, use Brick.showCursor instead + +-- I refuse to give this a type signature. +-- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics. +zoom l = Brick.zoom (toLensVL l) + +data BrickData = BrickData + { _lr :: [ListResult] + } + deriving Show + +makeLenses ''BrickData + +data BrickSettings = BrickSettings { _showAllVersions :: Bool} + --deriving Show + +makeLenses ''BrickSettings + +defaultAppSettings :: BrickSettings +defaultAppSettings = BrickSettings False diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs new file mode 100644 index 00000000..dfa4dd4e --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +A very simple information-only widget with no handler. +-} + +module GHCup.Brick.Widgets.KeyInfo where + +import GHCup.Types ( KeyBindings(..) ) +import qualified GHCup.Brick.Common as Common + + +import Brick + ( Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Center ( center ) +import Prelude hiding ( appendFile ) + + + +draw :: KeyBindings -> Widget Common.Name +draw KeyBindings {..} = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + in Common.frontwardLayer "Key Actions" + $ Brick.vBox [ + center $ + mkTextBox [ + Brick.hBox [ + Brick.txt "Press " + , Common.keyToWidget bUp, Brick.txt " and ", Common.keyToWidget bDown + , Brick.txtWrap " to navigate the list of tools" + ] + , Brick.hBox [ + Brick.txt "Press " + , Common.keyToWidget bInstall + , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" + ] + , Brick.hBox [ + Brick.txt "Press " + , Common.keyToWidget bSet + , Brick.txtWrap " to set a tool as the one for use" + ] + , Brick.hBox [ + Brick.txt "Press " + , Common.keyToWidget bUninstall + , Brick.txtWrap " to uninstall a tool" + ] + , Brick.hBox [ + Brick.txt "Press " + , Common.keyToWidget bChangelog + , Brick.txtWrap " to open the tool's changelog. It will open a web browser" + ] + , Brick.hBox [ + Brick.txt "Press " + , Common.keyToWidget bShowAllVersions + , Brick.txtWrap " to show older version of each tool" + ] + ] + ] + <=> 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"] diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs new file mode 100644 index 00000000..9a3cb63c --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -0,0 +1,369 @@ +{-# 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 #-} +{-# LANGUAGE GADTs #-} + + +{- ************** + +A general system inspired by Brick.Form. It uses optics instead of microlenses and it is less generic than +Brick.Form, but generic enough to serve our purpose. + +A Menu consists in + a) A state value + b) A list of fields. Each field is capable of modifying a part of the state + c) some metadata + +A field (type MenuField) consists in + a) a Lens to a part of the Menu state, so the Menu can call that lens to modify its own state + b) an input widget + +An input (type FieldInput) consist in + a) some state + b) a validator function + c) a handler and a renderer + +We have to use existential types to achive a composable API since every FieldInput has a different +internal type, and every MenuField has a different Lens. For example: + - The menu state is a record (MyRecord {uri: URI, flag : Bool}) + - Then, there are two MenuField: + - One MenuField has (Lens' MyRecord URI) and the other has (Lens' MyRecord Bool) + - The MenuFields has FieldInputs with internal state Text and Bool, respectively + - Obviously, the MenuField has to be polimorphic in the Lens' and in the Input internal state, + But we must hide that polimorphisim (existential), in order to store all MenuField in a List + +************** -} + +module GHCup.Brick.Widgets.Menu where + +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Common as Common + +import Brick + ( BrickEvent(..), + EventM, + Widget(..), + (<+>)) +import qualified Brick +import qualified Brick.Widgets.Border as Border +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.Edit as Edit +import Brick.Focus (FocusRing) +import qualified Brick.Focus as F +import Data.Function ( (&)) +import Prelude hiding ( appendFile ) + +import qualified Data.Text as T + + +import Optics.TH (makeLensesFor) +import qualified Graphics.Vty as Vty +import Optics.State.Operators ((%=), (.=)) +import Optics.Optic ((%)) +import Optics.State (use) +import GHCup.Types (KeyCombination) +import Optics (Lens', to, lens) +import Optics.Operators ( (^.), (.~) ) +import Data.Foldable (foldl') + + +-- | Just some type synonym to make things explicit +type Formatter n = Bool -> Widget n -> Widget n +-- | A label +type Label = T.Text +-- | A help message of an entry +type HelpMessage = T.Text +-- | A button name +type ButtonName n = n + +idFormatter :: Formatter n +idFormatter = const id + + +-- | An error message +type ErrorMessage = T.Text +data ErrorStatus = Valid | Invalid ErrorMessage deriving (Eq) + +-- | A lens which does nothing. Usefull to defined no-op fields +emptyLens :: Lens' s () +emptyLens = lens (const ()) (\s _ -> s) + +-- | A FieldInput is a pair label-content +-- a - is the type of the field it manipulates +-- b - is its internal state (modified in the gui) +-- n - your application's resource name type +data FieldInput a b n = + FieldInput + { inputState :: b -- ^ The state of the input field (what's rendered in the screen) + , inputValidator :: b -> Either ErrorMessage a -- ^ A validator function + , inputHelp :: HelpMessage -- ^ The input helpMessage + , inputRender :: Bool + -> ErrorStatus + -> HelpMessage + -> b + -> (Widget n -> Widget n) + -> Widget n -- ^ How to draw the input, with focus a help message and input. + -- A extension function can be applied too + , inputHandler :: BrickEvent n () -> EventM n b () -- ^ The handler + } + +makeLensesFor + [ ("inputState", "inputStateL") + , ("inputValidator", "inputValidatorL") + , ("inputName", "inputNameL") + , ("inputHelp", "inputHelpL") + ] + ''FieldInput + +-- | The MenuField is an existential type which stores a Lens' to a part of the Menu state. +-- In also contains a Field input which internal state is hidden +data MenuField s n where + MenuField :: + { fieldAccesor :: Lens' s a -- ^ A Lens pointing to some part of the state + , fieldInput :: FieldInput a b n -- ^ The input which modifies the state + , fieldLabel :: Label -- ^ The label + , fieldStatus :: ErrorStatus -- ^ Whether the current is valid or not. + , fieldName :: n + } -> MenuField s n + +isValidField :: MenuField s n -> Bool +isValidField = (== Valid) . fieldStatus + +makeLensesFor + [ ("fieldLabel", "fieldLabelL") + , ("fieldStatus", "fieldStatusL") + ] + ''MenuField + +-- | A fancy lens to the help message +fieldHelpMsgL :: Lens' (MenuField s n) HelpMessage +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 Common.enableScreenReader fieldName $ Brick.visible input + else input + +instance Brick.Named (MenuField s n) n where + getName :: MenuField s n -> n + getName entry = entry & fieldName + + +{- ***************** + CheckBox widget +***************** -} + +type CheckBoxField = MenuField + +createCheckBoxInput :: FieldInput Bool Bool n +createCheckBoxInput = FieldInput False Right "" checkBoxRender checkBoxHandler + where + border = Border.border . Brick.padRight (Brick.Pad 1) . Brick.padLeft (Brick.Pad 2) + drawBool b = + if b + then border . Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign + else border . Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign + checkBoxRender focus _ help check f = + let core = f $ drawBool check + in if focus + then core + else core <+> (Brick.padLeft (Brick.Pad 1) . centerV . renderAsHelpMsg $ help) + checkBoxHandler = \case + VtyEvent (Vty.EvKey Vty.KEnter []) -> Brick.modify not + _ -> pure () + +createCheckBoxField :: n -> Lens' s Bool -> CheckBoxField s n +createCheckBoxField name access = MenuField access createCheckBoxInput "" Valid name + +{- ***************** + Editable widget +***************** -} + +type EditableField = MenuField + +createEditableInput :: (Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> FieldInput a (Edit.Editor T.Text n) n +createEditableInput name validator = FieldInput initEdit validateEditContent "" drawEdit Edit.handleEditorEvent + where + drawEdit focus errMsg help edi amp = + 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 | isEditorEmpty -> borderBox $ renderAsHelpMsg help + | otherwise -> borderBox editorRender + Invalid msg + | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help + | focus -> borderBox editorRender + | otherwise -> borderBox $ renderAsErrMsg msg + 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 +createEditableField name validator access = MenuField access input "" Valid name + where + input = createEditableInput name validator + +{- ***************** + Button widget +***************** -} + +type Button = MenuField + +createButtonInput :: FieldInput () () n +createButtonInput = FieldInput () Right "" drawButton (const $ pure ()) + 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 + +{- ***************** + Utilities +***************** -} + +-- | highlights a widget (using List.listSelectedFocusedAttr) +highlighted :: Widget n -> Widget n +highlighted = Brick.withAttr L.listSelectedFocusedAttr + +-- | Given a text, crates a highlighted label on focus. An amplifier can be passed +renderAslabel :: T.Text -> Bool -> Widget n +renderAslabel t focus = + if focus + then highlighted $ Brick.txt t + else Brick.txt t + +-- | Creates a left align column. +-- Example: |- col2 is align dispite the length of col1 +-- row1_col1 row1_col2 +-- row2_col1_large row2_col2 +leftify :: Int -> Brick.Widget n -> Brick.Widget n +leftify i = Brick.hLimit i . Brick.padRight Brick.Max + +-- | center a line in three rows. +centerV :: Widget n -> Widget n +centerV = Brick.padTopBottom 1 + +-- | render some Text using helpMsgAttr +renderAsHelpMsg :: T.Text -> Widget n +renderAsHelpMsg = Brick.withAttr Attributes.helpMsgAttr . Brick.txt + +-- | render some Text using errMsgAttr +renderAsErrMsg :: T.Text -> Widget n +renderAsErrMsg = Brick.withAttr Attributes.errMsgAttr . Brick.txt + +{- ***************** + Menu widget +***************** -} + +-- | A menu is a list of Fields and a state. Informally we can think about s in terms of the record type returned by +-- a form. +data Menu s n + = Menu + { menuFields :: [MenuField s n] -- ^ The datatype representing the list of entries. Precisely, any array-like data type is highly unconvinient. + , menuState :: s + , menuButtons :: [Button s n] -- ^ The buttons. Commonly, the handlers for buttons are defined outside the menu handler. + , menuFocusRing :: FocusRing n -- ^ The focus ring with the resource name for each entry and each button, in the order you want to loop them. + , menuExitKey :: KeyCombination -- ^ The key to exit the Menu + , menuName :: n -- ^ The resource Name. + } + +makeLensesFor + [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL") + , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL") + , ("menuExitKey", "menuExitKeyL"), ("menuName", "menuNameL") + ] + ''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] + +handlerMenu :: forall n e s. Eq n => BrickEvent n e -> EventM n (Menu s n) () +handlerMenu ev = + case ev of + VtyEvent (Vty.EvKey (Vty.KChar '\t') []) -> menuFocusRingL %= F.focusNext + VtyEvent (Vty.EvKey Vty.KBackTab []) -> menuFocusRingL %= F.focusPrev + VtyEvent (Vty.EvKey Vty.KDown []) -> menuFocusRingL %= F.focusNext + VtyEvent (Vty.EvKey Vty.KUp []) -> menuFocusRingL %= F.focusPrev + VtyEvent e -> do + focused <- use $ menuFocusRingL % to F.focusGetCurrent + fields <- use menuFieldsL + case focused of + 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 = traverse $ \x@(MenuField {fieldInput = FieldInput {..}, ..}) -> + if Brick.getName x == n + then do + newb <- Brick.nestEventM' inputState (inputHandler e) + let newField = MenuField {fieldInput = (FieldInput {inputState=newb, ..}) , ..} + case inputValidator newb of + Left errmsg -> pure $ newField & fieldStatusL .~ Invalid errmsg + Right a -> menuStateL % fieldAccesor .= a >> pure (newField & fieldStatusL .~ Valid) + else pure x + + +drawMenu :: (Eq n, Ord n, Show n, Brick.Named (MenuField s n) n) => Menu s n -> Widget n +drawMenu menu = + Brick.vBox + [ Brick.vBox buttonWidgets + , Common.separator + , Brick.withVScrollBars Brick.OnRight + $ Brick.viewport (menu ^. menuNameL) Brick.Vertical + $ Brick.vBox fieldWidgets + , Brick.txt " " + , Brick.padRight Brick.Max $ + Brick.txt "Press " + <+> Common.keyToWidget (menu ^. menuExitKeyL) + <+> Brick.txt " to go back" + ] + where + fieldLabels = [field & fieldLabel | field <- menu ^. menuFieldsL] + buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL] + allLabels = fieldLabels ++ buttonLabels + + maxWidth = foldl' max 5 (fmap Brick.textWidth allLabels) + + -- A list of functions which draw a highlighted label with right padding at the left of a widget. + amplifiers = + let labelsWidgets = fmap renderAslabel fieldLabels + in fmap (\f b -> ((centerV . leftify (maxWidth + 10) $ f b) <+>) ) labelsWidgets + drawFields = fmap drawField amplifiers + fieldWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawFields (menu ^. menuFieldsL) + + buttonAmplifiers = + let buttonAsWidgets = fmap renderAslabel buttonLabels + in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets + drawButtons = fmap drawField buttonAmplifiers + buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL) + + diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs new file mode 100644 index 00000000..3e1a6f3a --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -0,0 +1,115 @@ +{-# 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.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 +import GHCup.Brick.Common(Name(..)) +import Brick + ( BrickEvent(..), + EventM, + Widget(..)) +import Prelude hiding ( appendFile ) +import Optics.TH (makeLensesFor) +import qualified GHCup.Brick.Common as Common +import GHCup.Types (KeyCombination) +import URI.ByteString (URI) +import qualified Data.Text as T +import Data.Bifunctor (Bifunctor(..)) +import Data.Function ((&)) +import Optics ((.~)) +import Data.Char (isSpace) +import qualified GHCup.Utils.Parsers as Utils + +data InstallOptions = InstallOptions + { instBindist :: Maybe URI + , instSet :: Bool + , isolateDir :: Maybe FilePath + , forceInstall :: Bool + , addConfArgs :: [T.Text] + } deriving (Eq, Show) + +makeLensesFor [ + ("instBindist", "instBindistL") + , ("instSet", "instSetL") + , ("isolateDir", "isolateDirL") + , ("forceInstall", "forceInstallL") + , ("addConfArgs", "addConfArgsL") + ] + ''InstallOptions + +type AdvanceInstallMenu = Menu InstallOptions Name + +create :: KeyCombination -> AdvanceInstallMenu +create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields + where + initialState = InstallOptions Nothing False Nothing False [] + -- 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 + + uriValidator :: T.Text -> Either Menu.ErrorMessage (Maybe URI) + uriValidator = whenEmpty Nothing (second Just . readUri) + where readUri = first T.pack . Utils.uriParser . T.unpack + + filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) + filepathValidator = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) + + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] + additionalValidator = Right . T.split isSpace + + fields = + [ Menu.createEditableField (Common.MenuElement Common.UrlEditBox) uriValidator instBindistL + & Menu.fieldLabelL .~ "url" + & Menu.fieldHelpMsgL .~ "Install the specified version from this bindist" + , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) instSetL + & Menu.fieldLabelL .~ "set" + & Menu.fieldHelpMsgL .~ "Set as active version after install" + , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathValidator isolateDirL + & Menu.fieldLabelL .~ "isolated" + & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" + , Menu.createCheckBoxField (Common.MenuElement Common.ForceCheckBox) forceInstallL + & Menu.fieldLabelL .~ "force" + & Menu.fieldHelpMsgL .~ "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)" + , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgsL + & Menu.fieldLabelL .~ "CONFIGURE_ARGS" + & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure" + ] + + ok = Menu.createButtonField (Common.MenuElement Common.OkButton) + & Menu.fieldLabelL .~ "Advance Install" + & Menu.fieldHelpMsgL .~ "Install with options below" + +handler :: BrickEvent Name e -> EventM Name AdvanceInstallMenu () +handler = Menu.handlerMenu + + +draw :: AdvanceInstallMenu -> Widget Name +draw = Common.frontwardLayer "Advance Install" . Menu.drawMenu 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 00000000..067266d6 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -0,0 +1,194 @@ +{-# 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, + 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 +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(..), VersionPattern ) +import URI.ByteString (URI) +import qualified Data.Text as T +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) +import qualified GHCup.Utils.Parsers as Utils + +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 + , _overwriteVer :: Maybe [VersionPattern] + , _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 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 [VersionPattern]) + versionV = whenEmpty Nothing (bimap T.pack Just . Utils.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 + + patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) + patchesV = whenEmpty Nothing readPatches + where + readPatches j = + let + x = second (Just . Left) $ Utils.absolutePathParser (T.unpack j) + y = second (Just . Right) $ traverse (Utils.uriParser . T.unpack) (T.split isSpace j) + in first T.pack $ x <|> y + + filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) + filepathV = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . 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 Make + | 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 compile configure" + , 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 overwriteVer + & Menu.fieldLabelL .~ "overwrite-version" + & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one" + , 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" + & 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" + & Menu.fieldStatusL .~ Menu.Invalid "bootstrap GHC is mandatory" + ] + +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/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs new file mode 100644 index 00000000..7caa9202 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -0,0 +1,178 @@ +{-# 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 Data.Bifunctor (Bifunctor(..)) +import Data.Function ((&)) +import Optics ((.~)) +import Data.Char (isSpace) +import Control.Applicative (Alternative((<|>))) +import Text.Read (readEither) +import qualified GHCup.Utils.Parsers as Utils + +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 + + readUri :: T.Text -> Either Menu.ErrorMessage URI + readUri = first T.pack . Utils.uriParser . T.unpack + + cabalProjectV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath URI)) + cabalProjectV = whenEmpty Nothing parseFileOrUri + where + parseFileOrUri i = + let x = bimap T.unpack Right (readUri i) + y = Right . Left . T.unpack $ i + in bimap T.pack Just $ x <|> y + + cabalProjectLocalV :: T.Text -> Either Menu.ErrorMessage (Maybe URI) + cabalProjectLocalV = whenEmpty Nothing (second Just . readUri) + + ghcVersionTagEither :: T.Text -> Either Menu.ErrorMessage [ToolVersion] + ghcVersionTagEither = whenEmpty [] $ first T.pack . traverse (Utils.ghcVersionTagEither . T.unpack) . T.split isSpace + + overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) + overWriteVersionParser = whenEmpty Nothing $ bimap T.pack Just . Utils.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 + + patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) + patchesV = whenEmpty Nothing readPatches + where + readPatches j = + let + x = second (Just . Left) $ Utils.absolutePathParser (T.unpack j) + y = second (Just . Right) $ traverse (Utils.uriParser . T.unpack) (T.split isSpace j) + in first T.pack $ x <|> y + + filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) + filepathV = whenEmpty Nothing (bimap T.pack Just . Utils.isolateParser . T.unpack) + + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] + additionalValidator = Right . T.split isSpace + + fields = + [ 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.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 .~ "CABAL_ARGS" + & Menu.fieldHelpMsgL .~ "Additional arguments to cabal install" + , 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" + , 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.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) cabalProjectLocalV 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." + ] + + 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 new file mode 100644 index 00000000..f9e11d37 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHCup.Brick.Widgets.Menus.Context (ContextMenu, create, draw, handler) where + +import Brick ( + Widget (..), BrickEvent, EventM, + ) +import Data.Function ((&)) +import Prelude hiding (appendFile) + +import Data.Versions (prettyVer) +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 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 + +create :: ListResult -> KeyCombination -> ContextMenu +create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] + where + advInstallButton = + Menu.createButtonField (MenuElement Common.AdvanceInstallButton) + & Menu.fieldLabelL .~ "Install" + & Menu.fieldHelpMsgL .~ "Advance Installation Settings" + compileGhcButton = + Menu.createButtonField (MenuElement Common.CompileGHCButton) + & Menu.fieldLabelL .~ "Compile" + & 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, compileGhcButton] + HLS -> [advInstallButton, compileHLSButton] + _ -> [advInstallButton] + +draw :: ContextMenu -> Widget Name +draw menu = + Common.frontwardLayer + ("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 \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs new file mode 100644 index 00000000..89cb0884 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- Brick's navigation widget: +It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime) +and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across + +-} + + +module GHCup.Brick.Widgets.Navigation (BrickInternalState, create, handler, draw) where + +import GHCup.List ( ListResult(..) ) +import GHCup.Types + ( GHCTargetVersion(GHCTargetVersion), + Tool(..), + Tag(..), + tVerToText, + tagToString ) +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Widgets.SectionList as SectionList +import Brick + ( BrickEvent(..), + Padding(Max, Pad), + AttrMap, + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder, borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center ) +import qualified Brick.Widgets.List as L +import Data.List ( intercalate, sort ) +import Data.Maybe ( mapMaybe ) +import Data.Vector ( Vector) +import Data.Versions ( prettyPVP, prettyVer ) +import Prelude hiding ( appendFile ) +import qualified Data.Text as T +import qualified Data.Vector as V + + +type BrickInternalState = SectionList.SectionList Common.Name ListResult + +-- | How to create a navigation widget +create :: Common.Name -- The name of the section list + -> [(Common.Name, Vector ListResult)] -- a list of tuples (section name, collection of elements) + -> Int -- The height of each item in a list. Commonly 1 + -> BrickInternalState +create = SectionList.sectionList + +-- | How the navigation handler handle events +handler :: BrickEvent Common.Name e -> EventM Common.Name BrickInternalState () +handler = SectionList.handleGenericListEvent + +-- | How to draw the navigation widget +draw :: AttrMap -> BrickInternalState -> Widget Common.Name +draw dimAttrs section_list + = Brick.padBottom Max + ( Brick.withBorderStyle unicode + $ borderWithLabel (Brick.str "GHCup") + (center (header <=> hBorder <=> renderList' section_list)) + ) + where + header = + minHSize 2 Brick.emptyWidget + <+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool") + <+> minHSize 15 (Brick.str "Version") + <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags") + <+> Brick.padLeft (Pad 5) (Brick.str "Notes") + renderList' bis = + let allElements = V.concatMap L.listElements $ SectionList.sectionListElements bis + minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements + minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements + in Brick.withDefAttr L.listAttr $ SectionList.renderSectionList (renderItem minTagSize minVerSize) True bis + renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = + let marks = if + | lSet -> (Brick.withAttr Attributes.setAttr $ Brick.str Common.setSign) + | lInstalled -> (Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign) + | otherwise -> (Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign) + ver = case lCross of + Nothing -> T.unpack . prettyVer $ lVer + Just c -> T.unpack (c <> "-" <> prettyVer lVer) + dim + | lNoBindist && not lInstalled + && not b -- TODO: overloading dim and active ignores active + -- so we hack around it here + = Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist") + | otherwise = id + hooray + | elem Latest lTag' && not lInstalled = + Brick.withAttr Attributes.hoorayAttr + | otherwise = id + active = if b then Common.enableScreenReader Common.AllTools else id + in hooray $ active $ dim + ( marks + <+> Brick.padLeft (Pad 2) + ( minHSize 6 + (printTool lTool) + ) + <+> minHSize minVerSize (Brick.str ver) + <+> (let l = mapMaybe printTag $ sort lTag' + in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) l + ) + <+> Brick.padLeft (Pad 5) + ( let notes = printNotes listResult + in if null notes + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes + ) + <+> Brick.vLimit 1 (Brick.fill ' ') + ) + + printTag Recommended = Just $ Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" + printTag Latest = Just $ Brick.withAttr Attributes.latestAttr $ Brick.str "latest" + printTag Prerelease = Just $ Brick.withAttr Attributes.prereleaseAttr $ Brick.str "prerelease" + printTag Nightly = Just $ Brick.withAttr Attributes.nightlyAttr $ Brick.str "nightly" + printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) + printTag Old = Nothing + printTag LatestPrerelease = Just $ Brick.withAttr Attributes.latestPrereleaseAttr $ Brick.str "latest-prerelease" + printTag LatestNightly = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "latest-nightly" + printTag (UnknownTag t) = Just $ Brick.str t + + printTool Cabal = Brick.str "cabal" + printTool GHC = Brick.str "GHC" + printTool GHCup = Brick.str "GHCup" + printTool HLS = Brick.str "HLS" + printTool Stack = Brick.str "Stack" + + printNotes ListResult {..} = + (if hlsPowered then [Brick.withAttr Attributes.hlsPoweredAttr $ Brick.str "hls-powered"] else mempty + ) + ++ (if lStray then [Brick.withAttr Attributes.strayAttr $ Brick.str "stray"] else mempty) + ++ (case lReleaseDay of + Nothing -> mempty + Just d -> [Brick.withAttr Attributes.dayAttr $ Brick.str (show d)]) + + minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs new file mode 100644 index 00000000..ade14f28 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/SectionList.hs @@ -0,0 +1,193 @@ +{-# 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 #-} + +{- A general system for lists with sections + +Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing +the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). + +- To build a SectionList use the safe constructor sectionList +- To access sections use the lens provider sectionL and the name of the section you'd like to access +- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not + modify the vector length + +-} + + +module GHCup.Brick.Widgets.SectionList where + + +import Brick + ( BrickEvent(VtyEvent, MouseDown), + EventM, + Size(..), + Widget(..), + ViewportType (Vertical), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder) +import qualified Brick.Widgets.List as L +import Brick.Focus (FocusRing) +import qualified Brick.Focus as F +import Data.Function ( (&)) +import Data.Maybe ( fromMaybe ) +import Data.Vector ( Vector ) +import qualified GHCup.Brick.Common as Common +import Prelude hiding ( appendFile ) + +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V + +import Optics.TH (makeLensesFor) +import Optics.State (use) +import Optics.State.Operators ( (%=), (<%=)) +import Optics.Operators ((.~), (^.)) +import Optics.Lens (Lens', lens) + +data GenericSectionList n t e + = GenericSectionList + { sectionListFocusRing :: FocusRing n -- ^ The FocusRing for all sections + , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A vector of brick's built-in list + , sectionListName :: n -- ^ The section list name + } + +makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList + +type SectionList n e = GenericSectionList n V.Vector e + + +-- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. +sectionList :: Foldable t + => n -- The name of the section list + -> [(n, t e)] -- a list of tuples (section name, collection of elements) + -> Int + -> GenericSectionList n t e +sectionList name elements height + = GenericSectionList + { sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements] + , sectionListElements = V.fromList [L.list section_name els height | (section_name, els) <- elements] + , sectionListName = name + } +-- | This lens constructor, takes a name and looks if a section has such a name. +-- Used to dispatch events to sections. It is a partial function only meant to +-- be used with the FocusRing inside GenericSectionList +sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e) +sectionL section_name = lens g s + where is_section_name = (== section_name) . L.listName + g section_list = + let elms = section_list ^. sectionListElementsL + zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. + in fromMaybe zeroth (V.find is_section_name elms) + s gl@(GenericSectionList _ elms _) list = + case V.findIndex is_section_name elms of + Nothing -> gl + Just i -> let new_elms = V.update elms (V.fromList [(i, list)]) + in gl & sectionListElementsL .~ new_elms + +moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () +moveDown = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event. + current_list <- use (sectionL l) + let current_idx = L.listSelected current_list + list_length = current_list & length + if current_idx == Just (list_length - 1) + then do + new_focus <- sectionListFocusRingL <%= F.focusNext + case F.focusGetCurrent new_focus of + Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick + Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToBeginning) + else Common.zoom (sectionL l) $ Brick.modify L.listMoveDown + +moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () +moveUp = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> do -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event. + current_list <- use (sectionL l) + let current_idx = L.listSelected current_list + if current_idx == Just 0 + then do + new_focus <- sectionListFocusRingL <%= F.focusPrev + case F.focusGetCurrent new_focus of + Nothing -> pure () + Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToEnd) + else Common.zoom (sectionL l) $ Brick.modify L.listMoveUp + +-- | Handle events for list cursor movement. Events handled are: +-- +-- * Up (up arrow key). If first element of section, then jump prev section +-- * Down (down arrow key). If last element of section, then jump next section +-- * Page Up (PgUp) +-- * Page Down (PgDown) +-- * Go to next section (Tab) +-- * Go to prev section (BackTab) +handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n) + => BrickEvent n a + -> EventM n (GenericSectionList n t e) () +handleGenericListEvent (VtyEvent (Vty.EvResize _ _)) = pure () +handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev +handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _) = moveDown +handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _) = moveUp +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown [])) = moveDown +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp +handleGenericListEvent (VtyEvent ev) = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> Common.zoom (sectionL l) $ L.handleListEvent ev +handleGenericListEvent _ = pure () + +-- This re-uses Brick.Widget.List.renderList +renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e)) + => (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element + -> Bool -- ^ Whether the section list has focus + -> GenericSectionList n t e -- ^ The section list to render + -> Widget n +renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) = + Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $ + V.ifoldl' (\(!accWidget) !i list -> + let hasFocusList = sectionIsFocused list + makeVisible = if hasFocusList then Brick.visibleRegion (Brick.Location (c, r)) (1, 1) else id + appendBorder = if i == 0 then id else (hBorder <=>) + newWidget = appendBorder (makeVisible $ renderInnerList hasFocusList list) + in accWidget <=> newWidget + ) + Brick.emptyWidget + elms + where + -- A section is focused if the whole thing is focused, and the inner list has focus + sectionIsFocused :: L.GenericList n t e -> Bool + sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus) + + renderInnerList :: Bool -> L.GenericList n t e -> Widget n + renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l + + -- compute the location to focus on within the active section + (c, r) :: (Int, Int) = case sectionListSelectedElement ge of + Nothing -> (0, 0) + Just (selElIx, _) -> (0, selElIx) + + +-- | Equivalent to listSelectedElement +sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) +sectionListSelectedElement generic_section_list = do + current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent + let current_section = generic_section_list ^. sectionL current_focus + L.listSelectedElement current_section diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs new file mode 100644 index 00000000..cc1ac680 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +A very simple information-only widget with no handler. +-} + +module GHCup.Brick.Widgets.Tutorial (draw) where + +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Attributes as Attributes + +import Brick + ( Padding(Max), + Widget(..), + (<=>)) +import qualified Brick +import Brick.Widgets.Center ( center ) +import Prelude hiding ( appendFile ) + + + +draw :: Widget Common.Name +draw = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + + in Common.frontwardLayer "Tutorial" + $ Brick.vBox + (fmap center + [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] + , Common.separator + , mkTextBox [ + Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.installedAttr (Brick.str Common.installedSign) + , Brick.txtWrap " means that the tool is installed but not in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign) + , Brick.txtWrap " means that the tool is installed and in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.notInstalledAttr (Brick.str Common.notInstalledSign) + , Brick.txt " means that the tool isn't installed" + ] + ] + , Common.separator + , mkTextBox [ + Brick.hBox [ + Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" + , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental" + ] + , Brick.hBox [ + Brick.withAttr Attributes.latestAttr $ Brick.str "latest" + , Brick.txtWrap " tag is for the latest distributed version of the tool" + ] + , Brick.hBox [ + Brick.withAttr Attributes.latestAttr $ Brick.str "hls-powered" + , Brick.txt " denotes the compiler version supported by the currently set (" + , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign) + , Brick.txt ") hls" + ] + , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" + ] + , Brick.txt " " + ]) + <=> Brick.padRight Brick.Max (Brick.txt "Press c+ctrl to exit the tutorial") diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs new file mode 100644 index 00000000..c0f91c74 --- /dev/null +++ b/lib-tui/GHCup/BrickMain.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module contains the entrypoint for the brick application and nothing else. + +-} + +module GHCup.BrickMain where + +import GHCup.Types + ( Settings(noColor), + AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyCombination (KeyCombination) ) +import GHCup.Prelude.Logger ( logError ) +import qualified GHCup.Brick.Actions as Actions +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.App as BrickApp +import qualified GHCup.Brick.Attributes as Attributes +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 qualified Graphics.Vty as Vty + +import Control.Monad.Reader ( ReaderT(runReaderT) ) +import Data.Functor ( ($>) ) +import Data.IORef (writeIORef) +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 + + + +brickMain :: AppState + -> IO () +brickMain s = do + writeIORef Actions.settings' s + + eAppData <- Actions.getAppData (Just $ ghcupInfo s) + case eAppData of + Right ad -> do + let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing + current_element = Navigation.sectionListSelectedElement initial_list + 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" + exitWith $ ExitFailure 2 + Just (_, e) -> + let initapp = + BrickApp.app + (Attributes.defaultAttributes $ noColor $ settings s) + (Attributes.dimAttributes $ noColor $ settings s) + initstate = + AppState.BrickState ad + Common.defaultAppSettings + initial_list + (ContextMenu.create e exit_key) + (AdvanceInstall.create exit_key) + (CompileGHC.create exit_key) + (CompileHLS.create exit_key) + (keyBindings s) + Common.Navigation + in Brick.defaultMain initapp initstate + $> () + Left e -> do + flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) + exitWith $ ExitFailure 2 diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs new file mode 100644 index 00000000..748a27f6 --- /dev/null +++ b/lib/GHCup/Utils/Parsers.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ViewPatterns #-} + +module GHCup.Utils.Parsers where + + +import GHCup.Errors +import GHCup.Types +import GHCup.Types.Optics +import GHCup.List +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.MegaParsec + +import Control.Applicative ((<|>)) +import Control.Exception.Safe +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Aeson +#if MIN_VERSION_aeson(2,0,0) +#else +import qualified Data.HashMap.Strict as KM +#endif +import Data.Bifunctor +import Data.Char +import Data.Either +import Data.Functor +import Data.List ( sort, sortBy ) +import Data.Maybe +import Data.Text ( Text ) +import Data.Time.Calendar ( Day ) +import Data.Time.Format ( parseTimeM, defaultTimeLocale ) +import Data.Versions +import Data.Void +import Haskus.Utils.Variant.Excepts +import Prelude hiding ( appendFile ) +import Safe +import System.FilePath +import URI.ByteString hiding (parseURI) + +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.Text as T +import qualified Data.Text.Lazy.Encoding as LE +import qualified Data.Text.Lazy as LT +import qualified Text.Megaparsec as MP +import GHCup.Version + + + ------------- + --[ Types ]-- + ------------- + +-- a superset of ToolVersion +data SetToolVersion = SetGHCVersion GHCTargetVersion + | SetToolVersion Version + | SetToolTag Tag + | SetToolDay Day + | SetRecommended + | SetNext + deriving (Eq, Show) + +prettyToolVer :: ToolVersion -> String +prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' +prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' +prettyToolVer (ToolTag t) = show t +prettyToolVer (ToolDay day) = show day + +toSetToolVer :: Maybe ToolVersion -> SetToolVersion +toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' +toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' +toSetToolVer (Just (ToolTag t')) = SetToolTag t' +toSetToolVer (Just (ToolDay d')) = SetToolDay d' +toSetToolVer Nothing = SetRecommended + + +platformParser :: String -> Either String PlatformRequest +platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of + Right r -> pure r + Left e -> Left $ errorBundlePretty e + where + archP :: MP.Parsec Void Text Architecture + archP = choice' ((\x -> MP.chunk (T.pack $ archToString x) $> x) <$> ([minBound..maxBound] :: [Architecture])) + platformP :: MP.Parsec Void Text PlatformRequest + platformP = choice' + [ (`PlatformRequest` FreeBSD) + <$> (archP <* MP.chunk "-") + <*> ( MP.chunk "portbld" + *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) + <|> pure Nothing + ) + <* MP.chunk "-freebsd" + ) + , (`PlatformRequest` Darwin) + <$> (archP <* MP.chunk "-") + <*> ( MP.chunk "apple" + *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) + <|> pure Nothing + ) + <* MP.chunk "-darwin" + ) + , (\a d mv -> PlatformRequest a (Linux d) mv) + <$> (archP <* MP.chunk "-") + <*> distroP + <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing + ) + <* MP.chunk "-linux" + ) + , (\a -> PlatformRequest a Windows Nothing) + <$> ((archP <* MP.chunk "-") + <* (MP.chunk "unknown-mingw32" <|> MP.chunk "unknown-windows" <|> MP.chunk "windows")) + ] + distroP :: MP.Parsec Void Text LinuxDistro + distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) + + +uriParser :: String -> Either String URI +uriParser = first show . parseURI . UTF8.fromString + + +absolutePathParser :: FilePath -> Either String FilePath +absolutePathParser f = case isValid f && isAbsolute f of + True -> Right $ normalise f + False -> Left "Please enter a valid absolute filepath." + +isolateParser :: FilePath -> Either String FilePath +isolateParser f = case isValid f && isAbsolute f of + True -> Right $ normalise f + False -> Left "Please enter a valid filepath for isolate dir." + +-- this accepts cross prefix +ghcVersionTagEither :: String -> Either String ToolVersion +ghcVersionTagEither s' = + second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') + +-- this ignores cross prefix +toolVersionTagEither :: String -> Either String ToolVersion +toolVersionTagEither s' = + second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') + +tagEither :: String -> Either String Tag +tagEither s' = case fmap toLower s' of + "recommended" -> Right Recommended + "latest" -> Right Latest + "latest-prerelease" -> Right LatestPrerelease + "latest-nightly" -> Right LatestNightly + ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of + Right x -> Right (Base x) + Left _ -> Left $ "Invalid PVP version for base " <> ver' + other -> Left $ "Unknown tag " <> other + + +ghcVersionEither :: String -> Either String GHCTargetVersion +ghcVersionEither = + first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack + +toolVersionEither :: String -> Either String Version +toolVersionEither = + first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack + + +toolParser :: String -> Either String Tool +toolParser s' | t == T.pack "ghc" = Right GHC + | t == T.pack "cabal" = Right Cabal + | t == T.pack "hls" = Right HLS + | t == T.pack "stack" = Right Stack + | otherwise = Left ("Unknown tool: " <> s') + where t = T.toLower (T.pack s') + +dayParser :: String -> Either String Day +dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right + $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s + + +criteriaParser :: String -> Either String ListCriteria +criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True + | t == T.pack "set" = Right $ ListSet True + | t == T.pack "available" = Right $ ListAvailable True + | t == T.pack "+installed" = Right $ ListInstalled True + | t == T.pack "+set" = Right $ ListSet True + | t == T.pack "+available" = Right $ ListAvailable True + | t == T.pack "-installed" = Right $ ListInstalled False + | t == T.pack "-set" = Right $ ListSet False + | t == T.pack "-available" = Right $ ListAvailable False + | otherwise = Left ("Unknown criteria: " <> s') + where t = T.toLower (T.pack s') + + + +keepOnParser :: String -> Either String KeepDirs +keepOnParser s' | t == T.pack "always" = Right Always + | t == T.pack "errors" = Right Errors + | t == T.pack "never" = Right Never + | otherwise = Left ("Unknown keep value: " <> s') + where t = T.toLower (T.pack s') + + +downloaderParser :: String -> Either String Downloader +downloaderParser s' | t == T.pack "curl" = Right Curl + | t == T.pack "wget" = Right Wget +#if defined(INTERNAL_DOWNLOADER) + | t == T.pack "internal" = Right Internal +#endif + | otherwise = Left ("Unknown downloader value: " <> s') + where t = T.toLower (T.pack s') + +gpgParser :: String -> Either String GPGSetting +gpgParser s' | t == T.pack "strict" = Right GPGStrict + | t == T.pack "lax" = Right GPGLax + | t == T.pack "none" = Right GPGNone + | otherwise = Left ("Unknown gpg setting value: " <> s') + where t = T.toLower (T.pack s') + + + +overWriteVersionParser :: String -> Either String [VersionPattern] +overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack + where + versionPattern :: MP.Parsec Void Text VersionPattern + versionPattern = do + str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%') + if str' /= mempty + then pure (S str') + else fmap (const CabalVer) v_cabal + <|> fmap (const GitBranchName) b_name + <|> fmap (const GitHashShort) s_hash + <|> fmap (const GitHashLong) l_hash + <|> fmap (const GitDescribe) g_desc + <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k" + where + v_cabal = MP.chunk "%v" + b_name = MP.chunk "%b" + s_hash = MP.chunk "%h" + l_hash = MP.chunk "%H" + g_desc = MP.chunk "%g" + + ----------------- + --[ Utilities ]-- + ----------------- + + +fromVersion :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Maybe ToolVersion + -> Tool + -> Excepts + '[ TagNotFound + , DayNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) +fromVersion tv = fromVersion' (toSetToolVer tv) + +fromVersion' :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => SetToolVersion + -> Tool + -> Excepts + '[ TagNotFound + , DayNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) +fromVersion' SetRecommended tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getRecommended dls tool + ?? TagNotFound Recommended tool +fromVersion' (SetGHCVersion v) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo v tool dls + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) + Right pvpIn -> + lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case + Just (pvp_, vi', mt) -> do + v' <- lift $ pvpToVersion pvp_ "" + when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion mt v', Just vi') + Nothing -> pure (v, vi) +fromVersion' (SetToolVersion (mkTVer -> v)) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo v tool dls + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) + Right pvpIn -> + lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case + Just (pvp_, vi', mt) -> do + v' <- lift $ pvpToVersion pvp_ "" + when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion mt v', Just vi') + Nothing -> pure (v, vi) +fromVersion' (SetToolTag Latest) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getLatest dls tool ?? TagNotFound Latest tool +fromVersion' (SetToolDay day) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> case getByReleaseDay dls tool day of + Left ad -> throwE $ DayNotFound day tool ad + Right v -> pure v +fromVersion' (SetToolTag LatestPrerelease) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool +fromVersion' (SetToolTag LatestNightly) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool +fromVersion' (SetToolTag Recommended) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getRecommended dls tool ?? TagNotFound Recommended tool +fromVersion' (SetToolTag (Base pvp'')) GHC = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC +fromVersion' SetNext tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + next <- case tool of + GHC -> do + set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool + ghcs <- rights <$> lift getInstalledGHCs + (headMay + . tail + . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set) + . cycle + . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y)) + . filter (\GHCTargetVersion {..} -> isNothing _tvTarget) + $ ghcs) ?? NoToolVersionSet tool + Cabal -> do + set <- cabalSet !? NoToolVersionSet tool + cabals <- rights <$> lift getInstalledCabals + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ cabals) ?? NoToolVersionSet tool + HLS -> do + set <- hlsSet !? NoToolVersionSet tool + hlses <- rights <$> lift getInstalledHLSs + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ hlses) ?? NoToolVersionSet tool + Stack -> do + set <- stackSet !? NoToolVersionSet tool + stacks <- rights <$> lift getInstalledStacks + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ stacks) ?? NoToolVersionSet tool + GHCup -> fail "GHCup cannot be set" + let vi = getVersionInfo next tool dls + pure (next, vi) +fromVersion' (SetToolTag t') tool = + throwE $ TagNotFound t' tool + + +parseUrlSource :: String -> Either String URLSource +parseUrlSource "GHCupURL" = pure GHCupURL +parseUrlSource "StackSetupURL" = pure StackSetupURL +parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') + <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') + +parseNewUrlSource :: String -> Either String NewURLSource +parseNewUrlSource "GHCupURL" = pure NewGHCupURL +parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL +parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') + <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') diff --git a/test/optparse-test/SetTest.hs b/test/optparse-test/SetTest.hs index 2e2f370c..ccecd30f 100644 --- a/test/optparse-test/SetTest.hs +++ b/test/optparse-test/SetTest.hs @@ -4,6 +4,7 @@ module SetTest where import GHCup.OptParse +import GHCup.Utils.Parsers (SetToolVersion(..)) import Test.Tasty import GHCup.Types import Data.Versions