packages feed

ghcup 0.1.22.0 → 0.1.30.0

raw patch · 49 files changed

+3838/−1758 lines, 49 filesdep +Cabal-syntaxdep +conduitdep +parsecdep −cabal-install-parsersdep −cabal-plandep −streamlydep ~asyncdep ~deepseqdep ~unordered-containers

Dependencies added: Cabal-syntax, conduit, parsec, yaml

Dependencies removed: cabal-install-parsers, cabal-plan, streamly, yaml-streamly

Dependency ranges changed: async, deepseq, unordered-containers

Files

CHANGELOG.md view
@@ -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
README.md view
@@ -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) <a href="https://opencollective.com/ghcup#category-CONTRIBUTE"><img src="https://opencollective.com/webpack/donate/button@2x.png?color=blue" alt="Donate" width="150"></a>
− app/ghcup/BrickMain.hs 
@@ -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)
app/ghcup/Main.hs view
@@ -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))
data/config.yaml view
@@ -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"+
ghcup.cabal view
@@ -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
lib-opt/GHCup/OptParse.hs view
@@ -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
lib-opt/GHCup/OptParse/Common.hs view
@@ -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')-
lib-opt/GHCup/OptParse/Compile.hs view
@@ -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
lib-opt/GHCup/OptParse/Config.hs view
@@ -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
lib-opt/GHCup/OptParse/Install.hs view
@@ -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
lib-opt/GHCup/OptParse/List.hs view
@@ -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
lib-opt/GHCup/OptParse/Prefetch.hs view
@@ -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
lib-opt/GHCup/OptParse/Run.hs view
@@ -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
lib-opt/GHCup/OptParse/Set.hs view
@@ -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
lib-opt/GHCup/OptParse/Test.hs view
@@ -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
lib-opt/GHCup/OptParse/Whereis.hs view
@@ -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
+ lib-tui/GHCup/Brick/Actions.hs view
@@ -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)
+ lib-tui/GHCup/Brick/App.hs view
@@ -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
+ lib-tui/GHCup/Brick/Attributes.hs view
@@ -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
+ lib-tui/GHCup/Brick/BrickState.hs view
@@ -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
+ lib-tui/GHCup/Brick/Common.hs view
@@ -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
+ lib-tui/GHCup/Brick/Widgets/KeyInfo.hs view
@@ -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"]
+ lib-tui/GHCup/Brick/Widgets/Menu.hs view
@@ -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)
+ lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs view
@@ -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
+ lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs view
@@ -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
+ lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs view
@@ -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
+ lib-tui/GHCup/Brick/Widgets/Menus/Context.hs view
@@ -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
+ lib-tui/GHCup/Brick/Widgets/Navigation.hs view
@@ -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 ' ')
+ lib-tui/GHCup/Brick/Widgets/SectionList.hs view
@@ -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
+ lib-tui/GHCup/Brick/Widgets/Tutorial.hs view
@@ -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")
+ lib-tui/GHCup/BrickMain.hs view
@@ -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
lib/GHCup.hs view
@@ -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
+ lib/GHCup/CabalConfig.hs view
@@ -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")+
lib/GHCup/Download/IOStreams.hs view
@@ -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
lib/GHCup/GHC.hs view
@@ -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
+ lib/GHCup/PlanJson.hs view
@@ -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+
lib/GHCup/Prelude/File.hs view
@@ -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
lib/GHCup/Prelude/File/Posix.hs view
@@ -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)
lib/GHCup/Prelude/File/Search.hs view
@@ -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.
lib/GHCup/Prelude/File/Windows.hs view
@@ -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)+
lib/GHCup/Prelude/Process/Windows.hs view
@@ -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
lib/GHCup/Types.hs view
@@ -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
lib/GHCup/Utils.hs view
@@ -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 ()
lib/GHCup/Utils/Dirs.hs view
@@ -143,6 +143,7 @@                                          , removeDirectoryRecursive                                          , removePathForcibly                                          , findFiles+                                         , makeAbsolute                                          ) import qualified System.Directory              as SD
+ lib/GHCup/Utils/Parsers.hs view
@@ -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')
test/ghcup-test/GHCup/Utils/FileSpec.hs view
@@ -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
test/optparse-test/CompileTest.hs view
@@ -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"})
test/optparse-test/SetTest.hs view
@@ -4,6 +4,7 @@ module SetTest where  import GHCup.OptParse+import GHCup.Utils.Parsers (SetToolVersion(..)) import Test.Tasty import GHCup.Types import Data.Versions