diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ # Revision history for ghcup +## 0.1.30.0 -- 2024-07-07 + +### New features + +* TUI: new context menus for advanced installation and compilation by @lsmor [#949](https://github.com/haskell/ghcup-hs/pull/949) +* Add `def-ghc-conf-options` config option + +### Improvements and bug fixes + +* Fix TUI for screenreaders +* Fix windows process creation [#1036](https://github.com/haskell/ghcup-hs/issues/1036) +* Migrate from streamly to conduit to unbreak hackage releases, wrt [#1051](https://github.com/haskell/ghcup-hs/issues/1051) +* Improve parsing of --platform values, fixes [#1057](https://github.com/haskell/ghcup-hs/issues/1057) +* Avoid option clash on `-s` +* Don't allow to specify --hadrian and --config wrt [#1082](https://github.com/haskell/ghcup-hs/issues/1082) +* Point to correct store dir when XDG is used [#1089](https://github.com/haskell/ghcup-hs/issues/1089) +* Fix boot GHC for `ghcup compile ghc` wrt [#1045](https://github.com/haskell/ghcup-hs/issues/1045) +* Add hadrian-ghc flag wrt [#1044](https://github.com/haskell/ghcup-hs/issues/1044) + ## 0.1.22.0 -- 2024-03-13 ### New features diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ ## The GHCup Haskell installer [![Join the chat at Libera.chat](https://img.shields.io/badge/chat-on%20libera%20IRC-brightgreen.svg)](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup) -[![Join the chat at Matrix.org](https://img.shields.io/matrix/haskell-tooling:matrix.org?label=chat%20on%20matrix.org)](https://app.element.io/#/room/#haskell-tooling:matrix.org) -[![Join the chat at Discord](https://img.shields.io/discord/280033776820813825?label=chat%20on%20discord)](https://discord.gg/pKYf3zDQU7) +[![Join the chat at Matrix.org](https://img.shields.io/matrix/ghcup:matrix.org?label=chat%20on%20matrix.org)](https://matrix.to/#/#ghcup:matrix.org) +[![Join the chat at Discord](https://img.shields.io/discord/280033776820813825?label=chat%20on%20discord)](https://discord.gg/WDqsWsnZfR) [![Join the chat at https://gitter.im/haskell/ghcup](https://badges.gitter.im/haskell/ghcup.svg)](https://gitter.im/haskell/ghcup?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) Donate diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs deleted file mode 100644 --- 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 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -10,8 +10,10 @@ module Main where +import GHCup.PlanJson + #if defined(BRICK) -import BrickMain ( brickMain ) +import GHCup.BrickMain (brickMain) #endif import qualified GHCup.GHC as GHC @@ -24,12 +26,12 @@ 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 import GHCup.Version -import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) import Control.Concurrent import Control.Concurrent.Async import Control.Exception.Safe @@ -90,6 +92,7 @@ gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings) mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors + defGHCConfOptions = fromMaybe (Types.defGHCConfOptions defaultSettings) uDefGHCConfOptions in (Settings {..}, keyBindings) #if defined(INTERNAL_DOWNLOADER) defaultDownloader = Internal @@ -111,11 +114,10 @@ } - plan_json :: String plan_json = $( do (fp, c) <- runIO (handleIO (\_ -> pure ("", "")) $ do - fp <- findPlanJson (ProjectRelativeToDir ".") + fp <- findPlanJson "." c <- B.readFile fp (Just res) <- pure $ decodeStrict' @Value c pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res)) diff --git a/data/config.yaml b/data/config.yaml --- a/data/config.yaml +++ b/data/config.yaml @@ -128,3 +128,12 @@ authority: host: "mirror.sjtu.edu.cn" +# Arguments to pass to the configure script of the prebuilt bindist. +# +# Do not pass '--prefix' here. +# +# GHCup by default passes '--disable-ld-override', so if you want to enable +# the vanilla way, which aggressively favors 'ld.gold' linker, add the following: +def-ghc-conf-options: + - "--enable-ld-override" + diff --git a/ghcup.cabal b/ghcup.cabal --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcup -version: 0.1.22.0 +version: 0.1.30.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2024 @@ -70,8 +70,6 @@ , async ^>=2.2.3 , base >=4.12 && <5 , bytestring >=0.10 && <0.12 - , cabal-install-parsers >=0.4.5 - , cabal-plan ^>=0.7.2 , containers ^>=0.6 , deepseq ^>=1.4 , directory ^>=1.3.6.0 @@ -80,6 +78,7 @@ , 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,12 +91,13 @@ , 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 , vector >=0.12 && <0.14 , versions >=6.0.5 && <6.1 - , yaml-streamly ^>=0.12.0 + , yaml ^>=0.11.0 if flag(tar) cpp-options: -DTAR @@ -109,9 +109,11 @@ build-depends: libarchive ^>=3.0.3.0 library + import: app-common-depends exposed-modules: GHCup GHCup.Cabal + GHCup.CabalConfig GHCup.Download GHCup.Download.Utils GHCup.Errors @@ -119,6 +121,7 @@ GHCup.HLS GHCup.List GHCup.Platform + GHCup.PlanJson GHCup.Prelude GHCup.Prelude.File GHCup.Prelude.File.Search @@ -143,6 +146,7 @@ GHCup.Utils.Tar GHCup.Utils.Tar.Types GHCup.Utils.URI + GHCup.Utils.Parsers GHCup.Version hs-source-dirs: lib @@ -177,9 +181,11 @@ , bytestring >=0.10 && <0.12 , bz2 ^>=1.0.1.1 , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 + , Cabal-syntax ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 , containers ^>=0.6 + , conduit ^>=1.3 , cryptohash-sha256 ^>=0.11.101.0 , deepseq ^>=1.4.4.0 , directory ^>=1.3.6.0 @@ -192,8 +198,8 @@ , lzma-static ^>=5.2.5.3 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 - , optics ^>=0.4 , os-release ^>=1.0.0 + , parsec , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 , regex-posix ^>=0.96 @@ -202,20 +208,19 @@ , safe ^>=0.3.18 , safe-exceptions ^>=0.1 , split ^>=0.2.3.4 - , streamly ^>=0.8.2 , strict-base ^>=0.4 , template-haskell >=2.7 && <2.22 , 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 - , yaml-streamly ^>=0.12.0 + , yaml ^>=0.11.0 , zlib ^>=0.6.2.2 if flag(tar) @@ -257,7 +262,6 @@ exposed-modules: GHCup.Prelude.File.Posix.Traversals include-dirs: cbits - includes: dirutils.h install-includes: dirutils.h c-sources: cbits/dirutils.c build-depends: @@ -322,6 +326,55 @@ 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 +404,8 @@ 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 @@ -395,6 +444,7 @@ , base >=4.12 && <5 , bytestring >=0.10 && <0.12 , containers ^>=0.6 + , conduit ^>=1.3 , directory ^>=1.3.6.0 , filepath >=1.4.101.0 , generic-arbitrary >=0.1.0 && <0.2.1 || >=0.2.2 && <0.3 @@ -403,7 +453,6 @@ , hspec-golden-aeson ^>=0.9 , QuickCheck ^>=2.14.1 , quickcheck-arbitrary-adt ^>=0.3.1.0 - , streamly ^>=0.8.2 , text ^>=2.0 , time >=1.9.3 && <1.12 , uri-bytestring ^>=0.3.2.2 diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -52,7 +52,7 @@ 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 @@ -176,7 +176,7 @@ "GPG verification (default: none)" <> completer (listCompleter ["strict", "lax", "none"]) )) - <*> invertableSwitch "stack-setup" (Just 's') False (help "Use stack's setup info for discovering and installing GHC versions") + <*> invertableSwitch "stack-setup" Nothing False (help "Use stack's setup info for discovering and installing GHC versions") <*> com diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -11,22 +11,21 @@ import GHCup +import GHCup.CabalConfig 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 import Control.Concurrent.Async import Control.Exception.Safe -import Control.Monad.Identity (Identity(..)) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif @@ -43,65 +42,25 @@ 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 +77,9 @@ 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 +88,7 @@ (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,170 +130,6 @@ - --------------------- - --[ 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 = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32) - 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" - ) - ] - 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 ]-- ------------------ @@ -671,149 +466,6 @@ #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 @@ -844,23 +496,9 @@ 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) + getStoreDir 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 --- a/lib-opt/GHCup/OptParse/Compile.hs +++ b/lib-opt/GHCup/OptParse/Compile.hs @@ -18,6 +18,7 @@ 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 @@ -68,6 +69,7 @@ data GHCCompileOptions = GHCCompileOptions { targetGhc :: GHC.GHCVer , bootstrapGhc :: Either Version FilePath + , hadrianGhc :: Maybe (Either Version FilePath) , jobs :: Maybe Int , buildConfig :: Maybe FilePath , patches :: Maybe (Either FilePath [URI]) @@ -163,7 +165,7 @@ ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = - GHCCompileOptions + (\targetGhc bootstrapGhc hadrianGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir -> GHCCompileOptions {..}) <$> ((GHC.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) @@ -207,6 +209,18 @@ "The GHC version (or full path) to bootstrap with (must be installed)" <> (completer $ versionCompleter [] GHC) ) + <*> optional (option + (eitherReader + (\x -> + (bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path") + ) + ) + ( long "hadrian-ghc" + <> metavar "HADRIAN_GHC" + <> help + "The GHC version (or full path) to GHC that will be used to compile hadrian (must be installed)" + <> (completer $ versionCompleter [] GHC) + )) <*> optional (option (eitherReader (readEither @Int)) @@ -215,14 +229,6 @@ <> (completer $ listCompleter $ fmap show ([1..12] :: [Int])) ) ) - <*> optional - (option - str - (short 'c' <> long "config" <> metavar "CONFIG" <> help - "Absolute path to build config file" - <> completer (bashCompleter "file") - ) - ) <*> (optional ( (fmap Right $ many $ option @@ -274,13 +280,29 @@ ) ) <*> ( - (\b -> if b then Just Hadrian else Nothing) <$> switch + (\b -> (, Nothing) $ if b then Just Hadrian else Nothing) <$> switch (long "hadrian" <> help "Use the hadrian build system instead of make. Tries to detect by default." ) <|> - (\b -> if b then Just Make else Nothing) <$> switch + ((\b c -> case (b, c) of + -- --make specified + (True, _) -> (Just Make, c) + -- only --config specified... assume make + (False, Just _) -> (Just Make, c) + -- otherwise fall back to runtime detection of build + -- system + (False, _) -> (Nothing, c)) <$> switch (long "make" <> help "Use the make build system instead of hadrian. Tries to detect by default." ) + <*> optional + (option + str + (short 'c' <> long "config" <> metavar "CONFIG" <> help + "Absolute path to build config file (implies make)" + <> completer (bashCompleter "file") + ) + ) + ) ) <*> optional (option @@ -599,6 +621,7 @@ crossTarget overwriteVer bootstrapGhc + hadrianGhc jobs buildConfig patches diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -14,6 +14,7 @@ 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 @@ -133,7 +134,8 @@ gpgSetting' = uGPGSetting usl <|> uGPGSetting usr platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr mirrors' = uMirrors usl <|> uMirrors usr - in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' + defGHCconfOptions' = uDefGHCConfOptions usl <|> uDefGHCConfOptions usr + in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions' where updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings updateKeyBindings Nothing Nothing = Nothing diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -20,6 +20,7 @@ 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 --- a/lib-opt/GHCup/OptParse/List.hs +++ b/lib-opt/GHCup/OptParse/List.hs @@ -14,6 +14,7 @@ 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 --- a/lib-opt/GHCup/OptParse/Prefetch.hs +++ b/lib-opt/GHCup/OptParse/Prefetch.hs @@ -14,6 +14,7 @@ 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 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -11,6 +11,7 @@ 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 --- a/lib-opt/GHCup/OptParse/Set.hs +++ b/lib-opt/GHCup/OptParse/Set.hs @@ -17,6 +17,7 @@ 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 --- a/lib-opt/GHCup/OptParse/Test.hs +++ b/lib-opt/GHCup/OptParse/Test.hs @@ -20,6 +20,7 @@ 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 --- a/lib-opt/GHCup/OptParse/Whereis.hs +++ b/lib-opt/GHCup/OptParse/Whereis.hs @@ -18,6 +18,7 @@ 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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -0,0 +1,738 @@ +{-# 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.CabalConfig +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.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 + + + +{- 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") + getStoreDir + 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 + ghcVer <- case compopts ^. CompileGHC.gitRef of + Just ref -> pure (GHC.GitDist (GitBranch ref Nothing)) + Nothing -> do + -- Compile the version user is pointing to in the tui + 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 + pure (GHC.SourceDist lVer) + + targetVer <- liftE $ GHCup.compileGHC + ghcVer + (compopts ^. CompileGHC.crossTarget) + (compopts ^. CompileGHC.overwriteVer) + (compopts ^. CompileGHC.bootstrapGhc) + (compopts ^. CompileGHC.hadrianGhc) + (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 + hlsVer <- case compopts ^. CompileHLS.gitRef of + Just ref -> pure (HLS.GitDist (GitBranch ref Nothing)) + Nothing -> do + -- Compile the version user is pointing to in the tui + let vi = getVersionInfo (mkTVer lVer) HLS 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 + pure (HLS.SourceDist lVer) + + ghcs <- + liftE $ forM (compopts ^. CompileHLS.targetGHCs) + (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) $ GHC) + targetVer <- liftE $ GHCup.compileHLS + hlsVer + 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) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs new file mode 100644 --- /dev/null +++ b/lib-tui/GHCup/Brick/App.hs @@ -0,0 +1,193 @@ +{-# 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 + when (Menu.isValidMenu ctx) $ + 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 --- /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 --- /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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Common.hs @@ -0,0 +1,225 @@ +{-# 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, HadrianGhcEditBox, JobsEditBox, BuildConfigEditBox + , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox + , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton + , CompileGHCButton, CompileHLSButton, CabalProjectEditBox + , CabalProjectLocalEditBox, UpdateCabalCheckBox, GitRefEditBox + ) ) 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 HadrianGhcEditBox :: ResourceId +pattern HadrianGhcEditBox = ResourceId 17 +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 + +pattern GitRefEditBox :: ResourceId +pattern GitRefEditBox = ResourceId 19 + +-- | 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 80 + . Brick.vLimitPercent 75 + . 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 --- /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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -0,0 +1,381 @@ +{-# 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 w = Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 2) w) <+> Brick.txt "]" + 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) . 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 w = amp (Brick.vLimit 1 $ Border.vBorder <+> Brick.padRight Brick.Max w <+> Border.vBorder) + 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 + +-- | Creates a right align column. +-- Example: |- col2 is align dispite the length of col1 +-- row1_col1 row1_col2 +-- row2_col1_large row2_col2 +rightify :: Int -> Brick.Widget n -> Brick.Widget n +rightify i = Brick.hLimit i . Brick.padLeft 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 + , menuValidator :: s -> Maybe ErrorMessage -- ^ A validator function + , 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"), ("menuValidator", "menuValidatorL") + , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL") + , ("menuExitKey", "menuExitKeyL"), ("menuName", "menuNameL") + ] + ''Menu + +isValidMenu :: Menu s n -> Bool +isValidMenu m = (all isValidField $ menuFields m) + && (case (menuValidator m) (menuState m) of { Nothing -> True; _ -> False }) + +createMenu :: n -> s -> (s -> Maybe ErrorMessage) + -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n +createMenu n initial validator exitK buttons fields = Menu fields initial validator 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 + validator <- use menuValidatorL + state <- use menuStateL + if all isValidField updated_fields + then case validator state of + Nothing -> menuButtonsL %= fmap (fieldStatusL .~ Valid) + Just err -> menuButtonsL %= fmap (fieldStatusL .~ Invalid err) + 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.vLimit (length fieldLabels) $ 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 -> ((rightify (maxWidth + 1) (f b <+> Brick.txt " ")) <+>) ) 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 + 2) . 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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -0,0 +1,118 @@ +{-# 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 validator k [ok] fields + where + initialState = InstallOptions Nothing False Nothing False [] + validator InstallOptions {..} = case (instSet, isolateDir) of + (True, Just _) -> Just "Cannot set active when doing an isolated install" + _ -> 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 + + 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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -0,0 +1,219 @@ +{-# 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, + hadrianGhc, + jobs, + buildConfig, + patches, + crossTarget, + addConfArgs, + setCompile, + overwriteVer, + buildFlavour, + buildSystem, + isolateDir, + gitRef, +) 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 + , _hadrianGhc :: Maybe (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 + , _gitRef :: Maybe String + } deriving (Eq, Show) + +makeLenses ''CompileGHCOptions + +type CompileGHCMenu = Menu CompileGHCOptions Name + +create :: KeyCombination -> CompileGHCMenu +create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields + where + initialState = + CompileGHCOptions + (Right "") + Nothing + Nothing + Nothing + Nothing + Nothing + [] + False + Nothing + Nothing + Nothing + Nothing + Nothing + validator CompileGHCOptions {..} = case (_setCompile, _isolateDir) of + (True, Just _) -> Just "Cannot set active when doing an isolated install" + _ -> case (_buildConfig, _buildSystem) of + (Just _, Just Hadrian) -> Just "Build config can be specified only for make build system" + _ -> 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" + + hadrianstrapV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either Version FilePath)) + hadrianstrapV i' = + let readVersion = bimap (const "Not a valid version") (Just . Left) . version + readPath = bimap T.pack (Just . Right) . Utils.absolutePathParser . T.unpack + in if T.any isPathSeparator i' + then whenEmpty Nothing readPath i' + else whenEmpty Nothing readVersion i' + + 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.HadrianGhcEditBox) hadrianstrapV hadrianGhc + & Menu.fieldLabelL .~ "hadrian-ghc" + & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to GHC that will be used to compile hadrian (must be installed)" + , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs + & Menu.fieldLabelL .~ "jobs" + & Menu.fieldHelpMsgL .~ "How many jobs to use for make" + , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile + & Menu.fieldLabelL .~ "set" + & Menu.fieldHelpMsgL .~ "Set as active version after install" + , 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.AdditionalEditBox) additionalValidator addConfArgs + & Menu.fieldLabelL .~ "CONFIGURE_ARGS" + & Menu.fieldHelpMsgL .~ "Additional arguments to compile configure" + , Menu.createEditableField (Common.MenuElement Common.BuildConfigEditBox) filepathV buildConfig + & Menu.fieldLabelL .~ "build config" + & Menu.fieldHelpMsgL .~ "Absolute path to build config file (make build system only)" + , 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.BuildSystemEditBox) systemV buildSystem + & Menu.fieldLabelL .~ "build system" + & Menu.fieldHelpMsgL .~ "either 'make' or 'hadrian'" + , 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.IsolateEditBox) filepathV isolateDir + & Menu.fieldLabelL .~ "isolated" + & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" + , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef + & Menu.fieldLabelL .~ "git-ref" + & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from" + ] + + 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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -0,0 +1,190 @@ +{-# 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, + gitRef, +) +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] + , _gitRef :: Maybe String + } deriving (Eq, Show) + +makeLenses ''CompileHLSOptions + +type CompileHLSMenu = Menu CompileHLSOptions Name + +create :: KeyCombination -> CompileHLSMenu +create k = Menu.createMenu CompileGHCBox initialState validator k buttons fields + where + initialState = + CompileHLSOptions + Nothing + False + False + Nothing + Nothing + Nothing + Nothing + Nothing + [] + [] + Nothing + + validator CompileHLSOptions {..} = case (_setCompile, _isolateDir) of + (True, Just _) -> Just "Cannot set active when doing an isolated install" + _ -> if null _targetGHCs + then Just "Specify at least one valid target GHC" + else 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(s)" + & Menu.fieldHelpMsgL .~ "space separated list of GHC versions to compile for" + , 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." + , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef + & Menu.fieldLabelL .~ "git-ref" + & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from" + ] + + 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 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -0,0 +1,83 @@ +{-# 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 validator 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] + validator = const Nothing + +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 diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs new file mode 100644 --- /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 ' ') diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs new file mode 100644 --- /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 --- /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 --- /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.hs b/lib/GHCup.hs --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -50,6 +50,7 @@ import GHCup.Prelude.String.QQ import GHCup.Version +import Conduit (sourceToList) import Control.Applicative import Control.Exception.Safe import Control.Monad @@ -77,7 +78,6 @@ import Text.Regex.Posix import qualified Data.Text as T -import qualified Streamly.Prelude as S @@ -157,6 +157,7 @@ rmGhcupDirs :: ( MonadReader env m , HasDirs env , MonadIO m + , MonadUnliftIO m , HasLog env , MonadCatch m , MonadMask m ) @@ -220,9 +221,9 @@ when (not isXDGStyle) $ removeDirIfEmptyOrIsSymlink binDir - reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath] + reportRemainingFiles :: (MonadMask m, MonadIO m, MonadUnliftIO m) => FilePath -> m [FilePath] reportRemainingFiles dir = do - remainingFiles <- liftIO $ S.toList (getDirectoryContentsRecursiveUnsafe dir) + remainingFiles <- runResourceT $ sourceToList $ getDirectoryContentsRecursiveUnsafe dir let normalizedFilePaths = fmap normalise remainingFiles let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths let remainingFilesAbsolute = fmap (dir ) sortedByDepthRemainingFiles diff --git a/lib/GHCup/CabalConfig.hs b/lib/GHCup/CabalConfig.hs new file mode 100644 --- /dev/null +++ b/lib/GHCup/CabalConfig.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHCup.CabalConfig (getStoreDir) where + +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import System.Directory (getAppUserDataDirectory, doesDirectoryExist, getXdgDirectory, XdgDirectory(XdgConfig)) +import System.Environment (lookupEnv) +import System.FilePath (()) + +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as M +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.FieldGrammar as C +import qualified Distribution.FieldGrammar.Parsec as C +import qualified Distribution.Fields as C +import qualified Distribution.Fields.LexerMonad as C +import qualified Distribution.Parsec as C +import qualified Distribution.Utils.Generic as C +import qualified Text.Parsec as P + +import Data.Foldable (for_) +import Distribution.Parsec.Error + + + + +getStoreDir :: IO FilePath +getStoreDir = do + fp <- findConfig + bs <- BS.readFile fp + either (fail . show . fmap (showPError fp)) resolveConfig (parseConfig bs) + +------------------------------------------------------------------------------- +-- Find config +------------------------------------------------------------------------------- + +-- | Find the @~\/.cabal\/config@ file. +findConfig :: IO FilePath +findConfig = do + env <- lookupEnv "CABAL_CONFIG" + case env of + Just p -> return p + Nothing -> do + cabalDir <- findCabalDir + return (cabalDir "config") + +-- | Find the @~\/.cabal@ dir. +findCabalDir :: IO FilePath +findCabalDir = do + cabalDirVar <- lookupEnv "CABAL_DIR" + appDir <- getAppUserDataDirectory "cabal" + isXdg <- not <$> doesDirectoryExist appDir + if | Just dir <- cabalDirVar -> pure dir + | isXdg -> getXdgDirectory XdgConfig "cabal" + | otherwise -> pure appDir + + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +-- | Parse @~\/.cabal\/config@ file. +parseConfig :: ByteString -> Either (NonEmpty PError) (Maybe FilePath) +parseConfig = parseWith $ \fields0 -> do + let (fields1, _) = C.partitionFields fields0 + let fields2 = M.filterWithKey (\k _ -> k `elem` knownFields) fields1 + parse fields2 + where + knownFields = C.fieldGrammarKnownFieldList grammar + + parse :: Map C.FieldName [C.NamelessField C.Position] + -> C.ParseResult (Maybe FilePath) + parse fields = C.parseFieldGrammar C.cabalSpecLatest fields grammar + +grammar :: C.ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath) +grammar = mempty + <$> C.optionalFieldAla "store-dir" C.FilePathNT id + +parseWith + :: ([C.Field C.Position] -> C.ParseResult a) -- ^ parse + -> ByteString -- ^ contents + -> Either (NonEmpty PError) a +parseWith parser bs = case C.runParseResult result of + (_, Right x) -> Right x + (_, Left (_, es)) -> Left es + where + result = case C.readFields' bs of + Left perr -> C.parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = C.Position (P.sourceLine ppos) (P.sourceColumn ppos) + Right (fields, lexWarnings) -> do + C.parseWarnings (C.toPWarnings lexWarnings) + for_ (C.validateUTF8 bs) $ \pos -> + C.parseWarning C.zeroPos C.PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos + parser fields + +------------------------------------------------------------------------------- +-- Resolving +------------------------------------------------------------------------------- + +-- | Fill the default in @~\/.cabal\/config@ file. +resolveConfig :: Maybe FilePath -> IO FilePath +resolveConfig (Just fp) = pure fp +resolveConfig Nothing = do + c <- findCabalDir + return (c "store") + diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -123,11 +123,16 @@ downloadStream r i' = do void setup - let size = case getHeader r "Content-Length" of - Just x' -> case decimal $ decUTF8Safe x' of + -- We can only do content length checks & progress bar when the stream is not encoded + let notEncoded = case mk <$> getHeader r "Content-Encoding" of + Nothing -> True + Just "identity" -> True + Just _ -> False + size = case (notEncoded, getHeader r "Content-Length") of + (True, Just x') -> case decimal $ decUTF8Safe x' of Left _ -> Nothing Right (r', _) -> Just r' - Nothing -> Nothing + _ -> Nothing forM_ size $ \s -> forM_ eCSize $ \es -> when (es /= s) $ throwIO (ContentLengthError Nothing (Just s) es) let size' = eCSize <|> size diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -439,39 +439,22 @@ liftE $ mergeGHCFileTree path inst tver forceInstall | otherwise = do PlatformRequest {..} <- lift getPlatformReq + Settings {..} <- lift getSettings - let ldOverride - | _tvVersion tver >= [vver|8.2.2|] - , _rPlatform `elem` [Linux Alpine, Darwin] - = ["--disable-ld-override"] - | otherwise - = [] + addConfArgs' <- sanitizefGHCconfOptions (T.unpack <$> addConfArgs) + defGHCConfOptions' <- sanitizefGHCconfOptions defGHCConfOptions lift $ logInfo "Installing GHC (this may take a while)" - env <- case _rPlatform of - -- https://github.com/haskell/ghcup-hs/issues/967 - Linux Alpine - -- lets not touch LD for cross targets - | Nothing <- _tvTarget tver -> do - cEnv <- liftIO getEnvironment - spaths <- liftIO getSearchPath - has_ld_bfd <- isJust <$> liftIO (searchPath spaths "ld.bfd") - let ldSet = isJust $ lookup "LD" cEnv - -- only set LD if ld.bfd exists in PATH and LD is not set - -- already - if has_ld_bfd && not ldSet - then do - lift $ logInfo "Detected alpine linux... setting LD=ld.bfd" - pure $ Just (("LD", "ld.bfd") : cEnv) - else pure Nothing - _ -> pure Nothing lEM $ execLogged "sh" ("./configure" : ("--prefix=" <> fromInstallDir inst) - : (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) <> ldOverride <> (T.unpack <$> addConfArgs)) + : (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) + <> ldOverride (_tvVersion tver) _rPlatform + <> defGHCConfOptions' + <> addConfArgs') ) (Just $ fromGHCupPath path) "ghc-configure" - env + Nothing tmpInstallDest <- lift withGHCupTmpDir lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) @@ -479,6 +462,7 @@ pure () + mergeGHCFileTree :: ( MonadReader env m , HasPlatformReq env , HasDirs env @@ -808,7 +792,8 @@ => GHCVer -> Maybe Text -- ^ cross target -> Maybe [VersionPattern] - -> Either Version FilePath -- ^ version to bootstrap with + -> Either Version FilePath -- ^ GHC version to bootstrap with + -> Maybe (Either Version FilePath) -- ^ GHC version to compile hadrian with -> Maybe Int -- ^ jobs -> Maybe FilePath -- ^ build config -> Maybe (Either FilePath [URI]) -- ^ patches @@ -843,7 +828,7 @@ ] m GHCTargetVersion -compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buildFlavour buildSystem installDir +compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs buildFlavour buildSystem installDir = do pfreq@PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -892,7 +877,7 @@ execBlank regex ) - tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer + tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError, NotFoundInPATH] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile)) pure (bootFile, tver) @@ -949,7 +934,7 @@ liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) -- bootstrap - tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer + tver <- liftE $ catchAllE @_ @'[ProcessError, ParseError, NotFoundInPATH] @'[] (\_ -> pure Nothing) $ fmap Just $ getGHCVer tmpUnpack liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> @@ -1058,10 +1043,10 @@ , MonadThrow m ) => GHCupPath - -> Excepts '[ProcessError, ParseError] m Version + -> Excepts '[ProcessError, ParseError, NotFoundInPATH] m Version getGHCVer tmpUnpack = do lEM $ execLogged "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" Nothing - lEM $ configureWithGhcBoot Nothing [] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + liftE $ configureWithGhcBoot Nothing [] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" let versionFile = fromGHCupPath tmpUnpack "VERSION" hasVersionFile <- liftIO $ doesFileExist versionFile if hasVersionFile @@ -1112,13 +1097,21 @@ lift $ logInfo $ "Building GHC version " <> tVerToText tver <> " (this may take a while)..." hadrian_build <- liftE $ findHadrianFile workdir + hEnv <- case hghc of + Nothing -> pure Nothing + Just hghc' -> do + cEnv <- Map.fromList <$> liftIO getEnvironment + ghc <- liftE $ resolveGHC hghc' + pure . Just . Map.toList . Map.insert "GHC" ghc $ cEnv + + lEM $ execLogged hadrian_build ( maybe [] (\j -> ["-j" <> show j] ) jobs ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour ++ ["binary-dist"] ) (Just workdir) "ghc-make" - Nothing + hEnv [tar] <- liftIO $ findFiles (workdir "_build" "bindist") (makeRegexOpts compExtended @@ -1306,13 +1299,16 @@ m () configureBindist tver workdir (fromInstallDir -> ghcdir) = do + PlatformRequest { .. } <- lift getPlatformReq lift $ logInfo [s|configuring build|] - lEM $ configureWithGhcBoot (Just tver) + liftE $ configureWithGhcBoot (Just tver) (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) ++ ["--prefix=" <> ghcdir] ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + -- https://github.com/haskell/ghcup-hs/issues/1032 + ++ ldOverride (_tvVersion tver) _rPlatform ++ fmap T.unpack aargs ) (Just workdir) @@ -1329,8 +1325,9 @@ -> [String] -- ^ args for configure -> Maybe FilePath -- ^ optionally chdir into this -> FilePath -- ^ log filename (opened in append mode) - -> m (Either ProcessError ()) + -> Excepts '[ProcessError, NotFoundInPATH] m () configureWithGhcBoot mtver args dir logf = do + bghc <- liftE $ resolveGHC bstrap let execNew = execLogged "sh" ("./configure" : ("GHC=" <> bghc) : args) @@ -1344,13 +1341,17 @@ logf Nothing if | Just tver <- mtver - , _tvVersion tver >= [vver|8.8.0|] -> execNew - | Nothing <- mtver -> execNew -- need some default for git checkouts where we don't know yet - | otherwise -> execOld + , _tvVersion tver >= [vver|8.8.0|] -> lEM execNew + | Nothing <- mtver -> lEM execNew -- need some default for git checkouts where we don't know yet + | otherwise -> lEM execOld - bghc = case bstrap of - Right g -> g - Left bver -> "ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt + resolveGHC :: MonadIO m => Either Version FilePath -> Excepts '[NotFoundInPATH] m FilePath + resolveGHC = \case + Right g -> pure g + Left bver -> do + let ghc = "ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt + -- https://gitlab.haskell.org/ghc/ghc/-/issues/24682 + makeAbsolute ghc @@ -1386,4 +1387,18 @@ $ getMajorMinorV _tvVersion forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + + +ldOverride :: Version -> Platform -> [String] +ldOverride ver plat + | ver >= [vver|8.2.2|] + , plat `elem` [Linux Alpine, Darwin] + = ["--disable-ld-override"] + | otherwise + = [] + +sanitizefGHCconfOptions :: MonadFail m => [String] -> m [String] +sanitizefGHCconfOptions args + | "--prefix" `elem` fmap (takeWhile (/= '=')) args = fail "Don't explicitly set --prefix ...aborting" + | otherwise = pure args diff --git a/lib/GHCup/PlanJson.hs b/lib/GHCup/PlanJson.hs new file mode 100644 --- /dev/null +++ b/lib/GHCup/PlanJson.hs @@ -0,0 +1,79 @@ +module GHCup.PlanJson where + +import Control.Monad (unless) +import System.FilePath +import System.Directory + +findPlanJson + :: FilePath + -> IO FilePath +findPlanJson fp = do + planJsonFn <- do + mRoot <- findProjectRoot fp + case mRoot of + Nothing -> fail ("missing project root relative to: " ++ fp) + Just dir -> fromBuilddir $ dir "dist-newstyle" + + havePlanJson <- doesFileExist planJsonFn + + unless havePlanJson $ + fail "missing 'plan.json' file; do you need to run 'cabal new-build'?" + + return planJsonFn + where + fromBuilddir distFolder = do + haveDistFolder <- doesDirectoryExist distFolder + + unless haveDistFolder $ + fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?") + + return $ distFolder "cache" "plan.json" + + +-- | Find project root relative to a directory, this emulates cabal's current +-- heuristic, but is slightly more liberal. If no cabal.project is found, +-- cabal-install looks for *.cabal files in the specified directory only. This +-- function also considers *.cabal files in directories higher up in the +-- hierarchy. +findProjectRoot :: FilePath -> IO (Maybe FilePath) +findProjectRoot dir = do + normalisedPath <- canonicalizePath dir + let checkCabalProject d = do + ex <- doesFileExist fn + return $ if ex then Just d else Nothing + where + fn = d "cabal.project" + + checkCabal d = do + files <- listDirectory' d + return $ if any (isExtensionOf' ".cabal") files + then Just d + else Nothing + + result <- walkUpFolders checkCabalProject normalisedPath + case result of + Just rootDir -> pure $ Just rootDir + Nothing -> walkUpFolders checkCabal normalisedPath + where + isExtensionOf' :: String -> FilePath -> Bool + isExtensionOf' ext fp = ext == takeExtension fp + + listDirectory' :: FilePath -> IO [FilePath] + listDirectory' fp = filter isSpecialDir <$> getDirectoryContents fp + where + isSpecialDir f = f /= "." && f /= ".." + +walkUpFolders :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe a) +walkUpFolders dtest d0 = do + home <- getHomeDirectory + + let go d | d == home = pure Nothing + | isDrive d = pure Nothing + | otherwise = do + t <- dtest d + case t of + Nothing -> go $ takeDirectory d + x@Just{} -> pure x + + go d0 + diff --git a/lib/GHCup/Prelude/File.hs b/lib/GHCup/Prelude/File.hs --- a/lib/GHCup/Prelude/File.hs +++ b/lib/GHCup/Prelude/File.hs @@ -13,11 +13,7 @@ copyFileE, findFilesDeep, getDirectoryContentsRecursive, - getDirectoryContentsRecursiveBFS, - getDirectoryContentsRecursiveDFS, getDirectoryContentsRecursiveUnsafe, - getDirectoryContentsRecursiveBFSUnsafe, - getDirectoryContentsRecursiveDFSUnsafe, recordedInstallationFile, module GHCup.Prelude.File.Search, @@ -64,7 +60,8 @@ import GHCup.Types.Optics import Text.Regex.Posix -import Control.Monad.IO.Unlift ( MonadUnliftIO ) +import Conduit +import qualified Data.Conduit.Combinators as C import Control.Exception.Safe import Control.Monad.Reader import Data.ByteString ( ByteString ) @@ -73,7 +70,6 @@ import Text.PrettyPrint.HughesPJClass (prettyShow) import qualified Data.Text as T -import qualified Streamly.Prelude as S import Control.DeepSeq (force) import Control.Exception (evaluate) import GHC.IO.Exception @@ -88,11 +84,12 @@ -- If any copy operation fails, the record file is deleted, as well -- as the partially installed files. mergeFileTree :: ( MonadMask m - , S.MonadAsync m , MonadReader env m , HasDirs env , HasLog env , MonadCatch m + , MonadIO m + , MonadUnliftIO m ) => GHCupPath -- ^ source base directory from which to install findFiles -> InstallDirResolved -- ^ destination base dir @@ -127,11 +124,10 @@ -- we want the cleanup action to leak through in case of exception onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do logDebug "Starting merge" - lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do - copy f + lift $ runConduitRes $ getDirectoryContentsRecursive sourceBase .| C.mapM_ (\f -> do + lift $ copy f logDebug $ T.pack "Recording installed file: " <> T.pack f - recordInstalledFile f recFile - pure f + recordInstalledFile f recFile) where wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase)) @@ -182,38 +178,20 @@ copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- --- depth first -getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) - => GHCupPath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp - --- breadth first -getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) - => GHCupPath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp - - -getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m) +getDirectoryContentsRecursive :: (MonadResource m) => GHCupPath - -> S.SerialT m FilePath -getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS + -> ConduitT i FilePath m () +getDirectoryContentsRecursive (fromGHCupPath -> fp) = getDirectoryContentsRecursiveUnsafe fp -getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m) +getDirectoryContentsRecursiveUnsafe :: (MonadResource m) => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe + -> ConduitT i FilePath m () +getDirectoryContentsRecursiveUnsafe = sourceDirectoryDeep' + findFilesDeep :: GHCupPath -> Regex -> IO [FilePath] findFilesDeep path regex = - S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path + runResourceT $ sourceToList $ getDirectoryContentsRecursive path .| C.filter (match regex) recordedInstallationFile :: ( MonadReader env m diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs --- a/lib/GHCup/Prelude/File/Posix.hs +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -15,10 +15,8 @@ -} module GHCup.Prelude.File.Posix where -import GHCup.Prelude.File.Posix.Traversals - +import Conduit import Control.Exception.Safe -import Control.Monad.Reader import Foreign.C.String import Foreign.C.Error import Foreign.C.Types @@ -26,7 +24,6 @@ import System.IO.Error hiding ( catchIOError ) import System.FilePath import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist ) -import System.Posix.Directory import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) import System.Posix.Internals ( withFilePath ) import System.Posix.Files @@ -37,20 +34,13 @@ import qualified System.Posix.Files as PF import qualified System.Posix.IO as SPI import qualified System.Posix as Posix -import qualified Streamly.FileSystem.Handle as FH -import qualified Streamly.Internal.FileSystem.Handle - as IFH -import qualified Streamly.Prelude as S import qualified GHCup.Prelude.File.Posix.Foreign as FD -import qualified Streamly.Internal.Data.Stream.StreamD.Type - as D -import Streamly.Internal.Data.Unfold.Type -import qualified Streamly.Internal.Data.Unfold as U -import Streamly.Internal.Control.Concurrent ( withRunInIO ) -import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) +import GHCup.Prelude.File.Posix.Traversals import GHC.IO.Exception (IOException(ioe_type), IOErrorType (..)) +import qualified Data.Conduit.Combinators as C + -- | On unix, we can use symlinks, so we just get the -- symbolic link target. -- @@ -133,14 +123,12 @@ $ \(_, tH) -> do hSetBinaryMode fH True hSetBinaryMode tH True - streamlyCopy (fH, tH) + runConduitRes $ sourceHandle fH .| sinkHandle tH where openFdHandle fp omode flags fM = do fd <- openFd' fp omode flags fM handle' <- SPI.fdToHandle fd pure (fd, handle') - streamlyCopy (fH, tH) = - S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH foreign import capi unsafe "fcntl.h open" c_open :: CString -> CInt -> Posix.CMode -> IO CInt @@ -276,60 +264,33 @@ removeEmptyDirectory :: FilePath -> IO () removeEmptyDirectory = PD.removeDirectory - --- | Create an 'Unfold' of directory contents. -unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) -unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDirStreamPortable) (Unfold step return) - where - {-# INLINE [0] step #-} - step dirstream = do - (typ, e) <- liftIO $ readDirEntPortable dirstream - return $ if - | null e -> D.Stop - | "." == e -> D.Skip dirstream - | ".." == e -> D.Skip dirstream - | otherwise -> D.Yield (typ, e) dirstream - - -getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveDFSUnsafe fp = go "" - where - go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> - if | t == FD.dtDir -> go (cd f) - | otherwise -> pure (cd f) - - -getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath -getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) - where - {-# INLINE [0] step #-} - step (_, Nothing, []) = return D.Stop - - step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do - (dt, f) <- liftIO $ readDirEntPortable dirstream - if | f == "" -> do - runIOFinalizer finalizer - return $ D.Skip (topdir, Nothing, dirs) - | f == "." || f == ".." - -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) - | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) - | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) - - step (topdir, Nothing, dir:dirs) = do - (s, f) <- acquire (topdir dir) - return $ D.Skip (topdir, Just (dir, s, f), dirs) - - acquire dir = - withRunInIO $ \run -> mask_ $ run $ do - dirstream <- liftIO $ openDirStreamPortable dir - ref <- newIOFinalizer (liftIO $ closeDirStreamPortable dirstream) - return (dirstream, ref) - -getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold +sourceDirectory' :: MonadResource m => FilePath -> ConduitT i (FD.DirType, FilePath) m () +sourceDirectory' dir = + bracketP (openDirStreamPortable dir) closeDirStreamPortable go + where + go ds = + loop + where + loop = do + (typ, e) <- liftIO $ readDirEntPortable ds + if + | null e -> return () + | "." == e -> loop + | ".." == e -> loop + | otherwise -> do + yield (typ, e) + loop +sourceDirectoryDeep' :: MonadResource m + => FilePath -- ^ Root directory + -> ConduitT i FilePath m () +sourceDirectoryDeep' fp' = start "" .| C.map snd + where + start :: MonadResource m => FilePath -> ConduitT i (FD.DirType, FilePath) m () + start dir = sourceDirectory' (fp' dir) .| awaitForever go + where + go :: MonadResource m => (FD.DirType, FilePath) -> ConduitT (FD.DirType, FilePath) (FD.DirType, FilePath) m () + go (typ, fp) + | FD.dtDir == typ = start (dir fp) + | otherwise = yield (typ, dir fp) diff --git a/lib/GHCup/Prelude/File/Search.hs b/lib/GHCup/Prelude/File/Search.hs --- a/lib/GHCup/Prelude/File/Search.hs +++ b/lib/GHCup/Prelude/File/Search.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} module GHCup.Prelude.File.Search ( module GHCup.Prelude.File.Search @@ -8,6 +9,7 @@ , CapturedProcess(..) ) where +import GHCup.Prelude.Internal ((!?)) import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader @@ -19,6 +21,7 @@ , removeDirectoryRecursive , removePathForcibly , findFiles + , makeAbsolute ) import System.FilePath import Text.Regex.Posix @@ -28,7 +31,14 @@ import qualified Text.Megaparsec as MP import Control.Exception.Safe (handleIO) import System.Directory.Internal.Prelude (ioeGetErrorType) +import Haskus.Utils.Variant.Excepts (Excepts) +import GHCup.Errors (NotFoundInPATH(..)) + +makeAbsolute :: MonadIO m => FilePath -> Excepts '[NotFoundInPATH] m FilePath +makeAbsolute bin = do + spaths <- liftIO getSearchPath + liftIO (searchPath spaths bin) !? NotFoundInPATH bin -- | Search for a file in the search paths. diff --git a/lib/GHCup/Prelude/File/Windows.hs b/lib/GHCup/Prelude/File/Windows.hs --- a/lib/GHCup/Prelude/File/Windows.hs +++ b/lib/GHCup/Prelude/File/Windows.hs @@ -16,8 +16,6 @@ import GHCup.Utils.Dirs import GHCup.Prelude.Internal -import Control.Exception.Safe -import Control.Monad import Control.Monad.Reader import Data.List import qualified GHC.Unicode as U @@ -27,15 +25,10 @@ import qualified System.Win32.Info as WS import qualified System.Win32.File as WS -import qualified Streamly.Internal.Data.Stream.StreamD.Type - as D -import Streamly.Internal.Data.Unfold.Type hiding ( concatMap ) import Data.Bits ((.&.)) -import qualified Streamly.Prelude as S -import qualified Streamly.Internal.Data.Unfold as U -import Streamly.Internal.Control.Concurrent ( withRunInIO ) -import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) +import Conduit +import qualified Data.Conduit.Combinators as C -- | On unix, we can use symlinks, so we just get the @@ -101,86 +94,7 @@ removeEmptyDirectory = WS.removeDirectory -unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath) -unfoldDirContents = U.bracket alloc dealloc (Unfold step return) - where - {-# INLINE [0] step #-} - step (_, False, _, _) = return D.Stop - step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do - f <- liftIO $ WS.getFindDataFileName fd - more <- liftIO $ WS.findNextFile h fd - -- can't get file attribute from FindData yet (needs Win32 PR) - fattr <- liftIO $ WS.getFileAttributes (topdir f) - - if | f == "." || f == ".." -> return $ D.Skip (topdir, more, h, fd) - | otherwise -> return $ D.Yield (fattr, f) (topdir, more, h, fd) - - alloc topdir = do - query <- liftIO $ furnishPath (topdir "*") - (h, fd) <- liftIO $ WS.findFirstFile query - pure (topdir, True, h, fd) - - dealloc (_, _, fd, _) = liftIO $ WS.findClose fd - - -getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t) - => FilePath - -> t m FilePath -getDirectoryContentsRecursiveDFSUnsafe fp = go "" - where - isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 - - go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> - if | isDir t -> go (cd f) - | otherwise -> pure (cd f) - - -getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath -getDirectoryContentsRecursiveUnfold = Unfold step init' - where - {-# INLINE [0] step #-} - step (_, Nothing, []) = return D.Stop - - step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do - f <- liftIO $ WS.getFindDataFileName findData - - more <- liftIO $ WS.findNextFile h findData - when (not more) $ runIOFinalizer ref - let nextState = if more then state else Nothing - - -- can't get file attribute from FindData yet (needs Win32 PR) - fattr <- liftIO $ WS.getFileAttributes (topdir cdir f) - - if | f == "." || f == ".." -> return $ D.Skip (topdir, nextState, dirs) - | isDir fattr -> return $ D.Skip (topdir, nextState, (cdir f):dirs) - | otherwise -> return $ D.Yield (cdir f) (topdir, nextState, dirs) - - step (topdir, Nothing, dir:dirs) = do - (h, findData, ref) <- acquire (topdir dir) - return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs) - - init' topdir = do - (h, findData, ref) <- acquire topdir - return (topdir, Just ("", (h, findData, ref)), []) - - isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 - - acquire dir = do - query <- liftIO $ furnishPath (dir "*") - withRunInIO $ \run -> mask_ $ run $ do - (h, findData) <- liftIO $ WS.findFirstFile query - ref <- newIOFinalizer (liftIO $ WS.findClose h) - return (h, findData, ref) - - -getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold - - - -------------------------------------- --[ Inlined from directory package ]-- -------------------------------------- @@ -309,3 +223,49 @@ not ('/' `elem` path || "." `elem` splitDirectories path || ".." `elem` splitDirectories path) + + +sourceDirectory' :: MonadResource m => FilePath -> ConduitT i (WS.FileAttributeOrFlag, FilePath) m () +sourceDirectory' topdir = + bracketP alloc dealloc go + where + go (b, h, fd) = + loop b + where + loop False = return () + loop True = do + f <- liftIO $ WS.getFindDataFileName fd + more <- liftIO $ WS.findNextFile h fd + + -- can't get file attribute from FindData yet (needs Win32 PR) + fattr <- liftIO $ WS.getFileAttributes (topdir f) + + if | f == "." || f == ".." -> loop more + | otherwise -> do + yield (fattr, f) + loop more + + alloc = do + query <- liftIO $ furnishPath (topdir "*") + (h, fd) <- liftIO $ WS.findFirstFile query + pure (True, h, fd) + + dealloc (_, fd, _) = liftIO $ WS.findClose fd + +sourceDirectoryDeep' :: MonadResource m + => FilePath -- ^ Root directory + -> ConduitT i FilePath m () +sourceDirectoryDeep' fp' = start "" .| C.map snd + where + isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 + + start :: MonadResource m => FilePath -> ConduitT i (WS.FileAttributeOrFlag, FilePath) m () + start dir = sourceDirectory' (fp' dir) .| awaitForever go + where + go :: MonadResource m + => (WS.FileAttributeOrFlag, FilePath) + -> ConduitT (WS.FileAttributeOrFlag, FilePath) (WS.FileAttributeOrFlag, FilePath) m () + go (typ, fp) + | isDir typ = start (dir fp) + | otherwise = yield (typ, dir fp) + diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs --- a/lib/GHCup/Prelude/Process/Windows.hs +++ b/lib/GHCup/Prelude/Process/Windows.hs @@ -150,7 +150,7 @@ -> m CapturedProcess executeOut' path args chdir env' = do cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir, env = env' }) - (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" + (exit, out, err) <- liftIO $ withRestorePath (env cp) $ readCreateProcessWithExitCodeBS cp "" pure $ CapturedProcess exit out err @@ -166,20 +166,21 @@ -> FilePath -- ^ log filename (opened in append mode) -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) -execLogged exe args chdir lfile env = do +execLogged exe args chdir lfile env' = do Dirs {..} <- getDirs logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir - , env = env + , env = env' , std_in = CreatePipe , std_out = CreatePipe , std_err = CreatePipe }) fmap (toProcessError exe args) $ liftIO + $ withRestorePath (env cp) $ withCreateProcess cp $ \_ mout merr ph -> case (mout, merr) of @@ -213,16 +214,9 @@ -> Maybe FilePath -- ^ optionally chdir into this -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) -exec exe args chdir env = do - -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375 - forM_ (Map.fromList <$> env) $ \cEnv -> do - let paths = ["PATH", "Path"] - curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths - newPath = intercalate [searchPathSeparator] curPaths - liftIO $ setEnv "PATH" "" - liftIO $ setEnv "Path" newPath - cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) - exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p +exec exe args chdir env' = do + cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env' }) + exit_code <- liftIO $ withRestorePath (env cp) $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p pure $ toProcessError exe args exit_code -- | Like 'exec', except doesn't add msys2 stuff to PATH. @@ -233,13 +227,6 @@ -> Maybe [(String, String)] -- ^ optional environment -> m (Either ProcessError ()) execNoMinGW exe args chdir env = do - -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375 - forM_ (Map.fromList <$> env) $ \cEnv -> do - let paths = ["PATH", "Path"] - curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths - newPath = intercalate [searchPathSeparator] curPaths - liftIO $ setEnv "PATH" "" - liftIO $ setEnv "Path" newPath let cp = (proc exe args) { cwd = chdir, env = env } exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p pure $ toProcessError exe args exit_code @@ -270,7 +257,26 @@ newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths envWithNewPath = Map.insert "Path" newPath envWithoutPath - liftIO $ setEnv "Path" newPath pure $ cp { env = Just $ Map.toList envWithNewPath } + +withRestorePath :: MonadIO m => Maybe [(String, String)] -- ^ optional env we want to extract 'PATH' from + -> m a -- ^ action to perform + -> m a +withRestorePath env action = do + -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375 + oldPATH <- liftIO $ lookupEnv "PATH" + oldPath <- liftIO $ lookupEnv "Path" + + forM_ (Map.fromList <$> env) $ \cEnv -> do + let paths = ["PATH", "Path"] + curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths + newPath = intercalate [searchPathSeparator] curPaths + liftIO $ setEnv "PATH" "" + liftIO $ setEnv "Path" newPath + + r <- action + liftIO $ maybe (unsetEnv "PATH") (setEnv "PATH") oldPATH + liftIO $ maybe (unsetEnv "Path") (setEnv "Path") oldPath + pure r diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -207,7 +207,7 @@ | A_Sparc64 | A_ARM | A_ARM64 - deriving (Eq, GHC.Generic, Ord, Show) + deriving (Eq, GHC.Generic, Ord, Show, Bounded, Enum) instance NFData Architecture @@ -379,24 +379,25 @@ instance NFData MetaMode data UserSettings = UserSettings - { uCache :: Maybe Bool - , uMetaCache :: Maybe Integer - , uMetaMode :: Maybe MetaMode - , uNoVerify :: Maybe Bool - , uVerbose :: Maybe Bool - , uKeepDirs :: Maybe KeepDirs - , uDownloader :: Maybe Downloader - , uKeyBindings :: Maybe UserKeyBindings - , uUrlSource :: Maybe URLSource - , uNoNetwork :: Maybe Bool - , uGPGSetting :: Maybe GPGSetting - , uPlatformOverride :: Maybe PlatformRequest - , uMirrors :: Maybe DownloadMirrors + { uCache :: Maybe Bool + , uMetaCache :: Maybe Integer + , uMetaMode :: Maybe MetaMode + , uNoVerify :: Maybe Bool + , uVerbose :: Maybe Bool + , uKeepDirs :: Maybe KeepDirs + , uDownloader :: Maybe Downloader + , uKeyBindings :: Maybe UserKeyBindings + , uUrlSource :: Maybe URLSource + , uNoNetwork :: Maybe Bool + , uGPGSetting :: Maybe GPGSetting + , uPlatformOverride :: Maybe PlatformRequest + , uMirrors :: Maybe DownloadMirrors + , uDefGHCConfOptions :: Maybe [String] } deriving (Show, GHC.Generic, Eq) defaultUserSettings :: UserSettings -defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = @@ -414,6 +415,7 @@ , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors + , uDefGHCConfOptions = Just defGHCConfOptions } fromSettings Settings{..} (Just KeyBindings{..}) = let ukb = UserKeyBindings @@ -440,6 +442,7 @@ , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors + , uDefGHCConfOptions = Just defGHCConfOptions } data UserKeyBindings = UserKeyBindings @@ -512,19 +515,20 @@ data Settings = Settings - { cache :: Bool - , metaCache :: Integer - , metaMode :: MetaMode - , noVerify :: Bool - , keepDirs :: KeepDirs - , downloader :: Downloader - , verbose :: Bool - , urlSource :: URLSource - , noNetwork :: Bool - , gpgSetting :: GPGSetting - , noColor :: Bool -- this also exists in LoggerConfig - , platformOverride :: Maybe PlatformRequest - , mirrors :: DownloadMirrors + { cache :: Bool + , metaCache :: Integer + , metaMode :: MetaMode + , noVerify :: Bool + , keepDirs :: KeepDirs + , downloader :: Downloader + , verbose :: Bool + , urlSource :: URLSource + , noNetwork :: Bool + , gpgSetting :: GPGSetting + , noColor :: Bool -- this also exists in LoggerConfig + , platformOverride :: Maybe PlatformRequest + , mirrors :: DownloadMirrors + , defGHCConfOptions :: [String] } deriving (Show, GHC.Generic) @@ -532,7 +536,7 @@ defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings -defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) +defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) [] instance NFData Settings diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -59,6 +59,7 @@ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif +import Conduit ((.|), runConduitRes) import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) @@ -87,7 +88,7 @@ import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE -import qualified Streamly.Prelude as S +import qualified Data.Conduit.Combinators as C import Control.DeepSeq (force) import GHC.IO (evaluate) @@ -1169,12 +1170,13 @@ installDestSanityCheck :: ( MonadIO m , MonadCatch m , MonadMask m + , MonadUnliftIO m ) => InstallDirResolved -> Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do - empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir + empty' <- lift $ runConduitRes $ getDirectoryContentsRecursiveUnsafe isoDir .| C.null when (not empty') (throwE $ DirNotEmpty isoDir) installDestSanityCheck _ = pure () diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -143,6 +143,7 @@ , removeDirectoryRecursive , removePathForcibly , findFiles + , makeAbsolute ) import qualified System.Directory as SD diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs new file mode 100644 --- /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/ghcup-test/GHCup/Utils/FileSpec.hs b/test/ghcup-test/GHCup/Utils/FileSpec.hs --- a/test/ghcup-test/GHCup/Utils/FileSpec.hs +++ b/test/ghcup-test/GHCup/Utils/FileSpec.hs @@ -2,11 +2,11 @@ import GHCup.Prelude.File +import Conduit import Data.List import System.Directory import System.FilePath import System.IO.Unsafe -import qualified Streamly.Prelude as S import Test.Hspec @@ -15,14 +15,8 @@ spec :: Spec spec = do describe "GHCup.Utils.File" $ do - it "getDirectoryContentsRecursiveBFS" $ do - l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe "lib") - l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" - not (null l1) `shouldBe` True - not (null l2) `shouldBe` True - l1 `shouldBe` l2 - it "getDirectoryContentsRecursiveDFS" $ do - l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib") + it "getDirectoryContentsRecursiveUnsafe" $ do + l1 <- sort <$> runResourceT (sourceToList $ getDirectoryContentsRecursiveUnsafe "lib") l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" not (null l1) `shouldBe` True not (null l2) `shouldBe` True diff --git a/test/optparse-test/CompileTest.hs b/test/optparse-test/CompileTest.hs --- a/test/optparse-test/CompileTest.hs +++ b/test/optparse-test/CompileTest.hs @@ -31,6 +31,7 @@ boot Nothing Nothing + Nothing (Just $ Right []) Nothing [] @@ -78,8 +79,8 @@ ) , (baseCmd <> "-j20", baseOptions{GHC.jobs = Just 20}) , (baseCmd <> "--jobs 10", baseOptions{GHC.jobs = Just 10}) - , (baseCmd <> "-c build.mk", baseOptions{GHC.buildConfig = Just "build.mk"}) - , (baseCmd <> "--config build.mk", baseOptions{GHC.buildConfig = Just "build.mk"}) + , (baseCmd <> "-c build.mk", baseOptions{GHC.buildConfig = Just "build.mk", GHC.buildSystem = Just Make}) + , (baseCmd <> "--config build.mk", baseOptions{GHC.buildConfig = Just "build.mk", GHC.buildSystem = Just Make}) #ifdef IS_WINDOWS , (baseCmd <> "--patch file:c:/example.patch", baseOptions{GHC.patches = Just $ Right [[uri|file:c:/example.patch|]]}) #else @@ -96,6 +97,7 @@ , (baseCmd <> "-f make", baseOptions{GHC.buildFlavour = Just "make"}) , (baseCmd <> "--flavour make", baseOptions{GHC.buildFlavour = Just "make"}) , (baseCmd <> "--hadrian", baseOptions{GHC.buildSystem = Just Hadrian}) + , (baseCmd <> "--hadrian --hadrian-ghc 9.2.8", baseOptions{GHC.buildSystem = Just Hadrian, GHC.hadrianGhc = Just (Left $(versionQ "9.2.8"))}) , (baseCmd <> "--make", baseOptions{GHC.buildSystem = Just Make}) #ifdef IS_WINDOWS , (baseCmd <> "-i C:\\\\tmp\\out_dir", baseOptions{GHC.isolateDir = Just "C:\\tmp\\out_dir"}) diff --git a/test/optparse-test/SetTest.hs b/test/optparse-test/SetTest.hs --- 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