diff --git a/.github/scripts/cross.sh b/.github/scripts/cross.sh index e6beae35..26b4ac09 100644 --- a/.github/scripts/cross.sh +++ b/.github/scripts/cross.sh @@ -94,7 +94,7 @@ done [ -z "${GHC_VER}" ] && GHC_VER=9.6.7 [ -z "${GHC_TARGET_VERSION}" ] && GHC_TARGET_VERSION=8.10.7 [ -z "${CABAL_VER}" ] && CABAL_VER=3.14.2.0 -[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.0.9 +[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.1.0 [ -z "${WRAPPER}" ] && WRAPPER=run export GHCUP_INSTALL_BASE_PREFIX diff --git a/.github/scripts/test.sh b/.github/scripts/test.sh index 7cd11753..631cb918 100644 --- a/.github/scripts/test.sh +++ b/.github/scripts/test.sh @@ -89,7 +89,7 @@ done [ -z "${PROJECT_DIR}" ] && PROJECT_DIR=$(pwd) [ -z "${GHC_VER}" ] && GHC_VER=9.6.7 [ -z "${CABAL_VER}" ] && CABAL_VER=3.14.2.0 -[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.0.9 +[ -z "${JSON_VERSION}" ] && JSON_VERSION=0.1.0 export GHCUP_INSTALL_BASE_PREFIX diff --git a/.github/workflows/cross.yaml b/.github/workflows/cross.yaml index 0b5a0d55..0e8e8325 100644 --- a/.github/workflows/cross.yaml +++ b/.github/workflows/cross.yaml @@ -21,7 +21,7 @@ env: CABAL_CACHE_NONFATAL: yes GHCUP_INSTALL_BASE_PREFIX: ${{ github.workspace }} GITHUB_WORKSPACE: ${{ github.workspace }} - GHCUP_VER: 0.2.0.0 + GHCUP_VER: 0.2.1.0 jobs: build: @@ -29,7 +29,7 @@ jobs: runs-on: ubuntu-latest env: CABAL_VER: 3.14.2.0 - JSON_VERSION: "0.0.9" + JSON_VERSION: "0.1.0" AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} S3_HOST: ${{ secrets.S3_HOST }} @@ -74,7 +74,7 @@ jobs: CABAL_VER: 3.14.2.0 BUILD_CONF_ARGS: "--enable-unregisterised" HADRIAN_FLAVOUR: "" - JSON_VERSION: "0.0.9" + JSON_VERSION: "0.1.0" GHC_VER: 8.10.6 GHC_TARGET_VERSION: "8.10.7" steps: @@ -127,7 +127,7 @@ jobs: CABAL_VER: 3.14.2.0 BUILD_CONF_ARGS: "" HADRIAN_FLAVOUR: "default+native_bignum" - JSON_VERSION: "0.0.9" + JSON_VERSION: "0.1.0" GHC_VER: 9.6.7 GHC_TARGET_VERSION: "9.6.7" WRAPPER: "emconfigure" diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 21f649d5..d2aa4131 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -19,10 +19,10 @@ concurrency: env: CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }} CABAL_CACHE_NONFATAL: yes - JSON_VERSION: "0.0.9" + JSON_VERSION: "0.1.0" GHC_VER: 9.6.7 CABAL_VER: 3.14.2.0 - GHCUP_VER: 0.2.0.0 + GHCUP_VER: 0.2.1.0 AWS_SECRET_ACCESS_KEY: ${{ secrets.AWS_SECRET_ACCESS_KEY }} AWS_ACCESS_KEY_ID: ${{ secrets.AWS_ACCESS_KEY_ID }} S3_HOST: ${{ secrets.S3_HOST }} diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2a43d015..a0787709 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -65,6 +65,11 @@ import qualified Data.Text.Encoding as E import qualified Data.Text.IO as T import qualified GHCup.Types as Types +#if defined(DHALL) +import qualified Dhall +import qualified Dhall.Core +import qualified Data.Either.Validation as Validation +#endif @@ -85,7 +90,7 @@ toSettings noColor pagerCmd options = do metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify - verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose + verbose = maybe (fromMaybe (Types.verbose defaultSettings) uVerbose) Verbosity optVerbose keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings @@ -198,7 +203,7 @@ Report bugs at |] -- logger interpreter logfile <- runReaderT initGHCupFileLogging dirs let loggerConfig = LoggerConfig - { lcPrintDebugLvl = Just (verbose settings) + { lcPrintDebugLvl = Just ((\(Verbosity i) -> i) . verbose $ settings) , consoleOutter = T.hPutStr stderr , fileOutter = case optCommand of @@ -326,6 +331,17 @@ Report bugs at |] GC gcOpts -> gc gcOpts runAppState runLogger Run runCommand -> run runCommand settings appState leanAppstate runLogger PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess +#if defined(DHALL) + GenerateDhallSchema -> + case Dhall.expected (Dhall.auto @GHCupInfo) of + Validation.Success result -> do + T.putStrLn (Dhall.Core.pretty result) + pure ExitSuccess + Validation.Failure errors -> do + runLogger $ logError (T.pack $ show errors) + pure $ ExitFailure 42 +#endif + case res of ExitSuccess -> pure () diff --git a/data/config.yaml b/data/config.yaml index 5c620a08..a7591877 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -13,6 +13,21 @@ no-network: False # whether/how to do gpg verification gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone +# A wrapper around configure/make +# Can be used to sandbox untrusted build systems, e.g.: +# +# build-wrapper: null +# cmd: bwrap +# cmdArgs: +# [ --ro-bind, /, / +# , --bind, /home/wurst/.ghcup, /home/wurst/.ghcup +# , --bind, /home/wurst/.cabal, /home/wurst/.cabal +# , --dev, /dev +# , --proc, /proc +# , --tmpfs, /tmp +# ] +build-wrapper: null + # TUI key bindings, # see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key # for possible values. diff --git a/data/metadata b/data/metadata index f1206a11..9cab4ab1 160000 --- a/data/metadata +++ b/data/metadata @@ -1 +1 @@ -Subproject commit f1206a11c68eee81517ebdc5ae7bb7172c7d3811 +Subproject commit 9cab4ab101ea4d168264e704ff1d1437dc153618 diff --git a/ghcup.cabal b/ghcup.cabal index 5ea57750..ffa52428 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcup -version: 0.2.0.0 +version: 0.2.1.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2024 @@ -95,6 +95,12 @@ common common-ghc-options common app-common-depends import: common-ghc-options + if flag(dhall) + cpp-options: -DDHALL + build-depends: + dhall ^>=1.42 + , either ^>=5.0.3 + build-depends: , aeson >=1.4 , aeson-pretty ^>=0.8.8 @@ -106,6 +112,7 @@ common app-common-depends , deepseq ^>=1.4 || ^>=1.5 || ^>=1.6 , directory ^>=1.3.6.0 , filepath >=1.4.101.0 + , indexed-traversable ^>=0.1.4 , variant ^>=1.0 , megaparsec >=8.0.0 && <9.8 , mtl ^>=2.2 || ^>=2.3 @@ -194,6 +201,7 @@ library GHCup.Prelude.Version.QQ GHCup.Query GHCup.Query.DB + GHCup.Query.DB.HLS GHCup.Query.GHCupDirs GHCup.Query.Metadata GHCup.Query.Symlink @@ -211,6 +219,7 @@ library GHCup.Types.Stack GHCup.Types.Tar GHCup.Unpack + GHCup.Warnings hs-source-dirs: lib other-modules: Paths_ghcup @@ -269,6 +278,7 @@ library , retry >=0.8.1.2 && <0.10 , safe ^>=0.3.18 , safe-exceptions ^>=0.1 + , scientific , split ^>=0.2.3.4 , strict-base ^>=0.4 , template-haskell >=2.7 && <2.24 @@ -286,12 +296,6 @@ library , word8 ^>=0.1.3 , zlib ^>=0.6.2.2 || ^>=0.7 - if flag(dhall) - cpp-options: -DDHALL - build-depends: - dhall ^>=1.42 - - if flag(yaml-streamly) build-depends: yaml-streamly ^>=0.12.5 @@ -409,7 +413,7 @@ library ghcup-tui GHCup.Brick.Widgets.Navigation GHCup.Brick.Widgets.Tutorial GHCup.Brick.Widgets.KeyInfo - GHCup.Brick.Widgets.SectionList + GHCup.Brick.Widgets.ToolInfo GHCup.Brick.Widgets.Menu GHCup.Brick.Widgets.Menus.Context GHCup.Brick.Widgets.Menus.AdvancedInstall diff --git a/installer-dsl.md b/installer-dsl.md index 883247fd..6d3ecdde 100644 --- a/installer-dsl.md +++ b/installer-dsl.md @@ -1,12 +1,3 @@ -## documentation - -- configure script must support `--prefix` -- make must support `DESTDIR` -- write about the rewrite in the dev section -- first tool in exe list matters -- invariants (`make` must not compile the binaries that are to be installed) -- limitations (packaging `cabal-cache`) - ## breaking changes - `cabal install ` is gone, use `cabal install ghc ` @@ -15,8 +6,6 @@ ## refactoring and some day -- get rid of Utils/Common... and improve module structure -- rename GHCTargetVersion - better logging ## investigate @@ -30,9 +19,7 @@ ## code TODO -- emit dhall types -- TUI - +- test: make sure we can generate dhall and convert it back to yaml ## ideas diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index f1652b46..9b81391a 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -115,6 +115,9 @@ data Command | GC GCOptions | Run RunOptions | PrintAppErrors +#if defined(DHALL) + | GenerateDhallSchema +#endif toVerbosity :: Maybe Bool -> Maybe Int @@ -360,6 +363,15 @@ com = (progDesc "")) <> internal ) +#if defined(DHALL) + <|> subparser + (command + "generate-dhall-schema" + (info (pure GenerateDhallSchema <**> helper) + (progDesc "")) + <> internal + ) +#endif -- | Handle 'ParserResult'. handleParseResult' :: Maybe FilePath -> Bool -> ParserResult a -> IO a diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index de61b33c..7d6203a3 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -326,7 +326,7 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do runEnv = flip runReaderT appState . runE (VRight installedVersions) <- runEnv $ listVersions (Just [tool]) criteria False False (Nothing, Nothing) - return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions + return $ fmap (T.unpack . prettyVer) . filter filter' . maybe [] (fmap lVer . snd) $ M.lookup tool installedVersions toolDlCompleter :: Tool -> Completer @@ -481,8 +481,11 @@ checkForUpdates :: ( MonadReader env m => m [(Tool, TargetVersion)] checkForUpdates = do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - (VRight lInstalled) <- runE $ listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) - let latestInstalled tool = (fmap (\lr -> TargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled + (VRight lInstalled') <- runE $ listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) + let latestInstalled tool = do + (_, xs) <- M.lookup tool lInstalled' + ListResult{..} <- lastMay xs + pure $ TargetVersion lCross lVer ghcup' <- forMM (getLatest dls ghcup) $ \(TargetVersion _ l, _) -> do (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 3f20e166..4040c1c2 100644 --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -391,6 +391,7 @@ install installCommand settings getAppState' runLogger = case installCommand of liftIO $ threadDelay 5000000 -- give the user a sec to intervene liftE $ runBothE' (installBindist instTool + Nothing (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) regexDir "" Nothing Nothing Nothing (toInstallationInputSpec <$> defaultToolInstallSpec instTool pfreq v)) v (maybe GHCupInternal IsolateDir isolateDir) diff --git a/lib-opt/GHCup/OptParse/List.hs b/lib-opt/GHCup/OptParse/List.hs index b2bcf41b..5fccb005 100644 --- a/lib-opt/GHCup/OptParse/List.hs +++ b/lib-opt/GHCup/OptParse/List.hs @@ -45,6 +45,7 @@ import qualified Data.Text.IO as T import qualified System.Console.Pretty as Pretty import Control.Exception.Safe (MonadMask) import GHCup.Types.Optics +import qualified Data.Map.Strict as M @@ -147,7 +148,7 @@ Examples: printListResult :: (HasLog env , MonadReader env m, MonadIO m) - => Bool -> PagerConfig -> Bool -> [ListResult] -> m () + => Bool -> PagerConfig -> Bool -> ToolListResult -> m () printListResult no_color (PagerConfig pList pCmd) raw lr = do let @@ -172,12 +173,12 @@ printListResult no_color (PagerConfig pList pCmd) raw lr = do then x else [color Green "", "Tool", "Version", "Tags", "Notes"] : x ) - . fmap - (\ListResult {..} -> + . mconcat . fmap + (\(lTool, (_, ls)) -> ls <&> \ListResult{..} -> let marks = if - | lSet -> (color Green (if isWindows then "IS" else "✔✔")) - | lInstalled -> (color Green (if isWindows then "I " else "✓ ")) - | otherwise -> (color Red (if isWindows then "X " else "✗ ")) + | lSet -> (color Green (if isWindows then "IS" else "✔✔")) + | lInstalled -> (color Green (if isWindows then "I " else "✓ ")) + | otherwise -> (color Red (if isWindows then "X " else "✗ ")) in (if raw then [] else [marks]) ++ [ fmap toLower . prettyShow $ lTool @@ -200,7 +201,7 @@ printListResult no_color (PagerConfig pList pCmd) raw lr = do ) ] ) - $ lr + $ M.toList lr let cols = foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows lengths = fmap (maximum . fmap strWidth) cols diff --git a/lib-opt/GHCup/OptParse/Nuke.hs b/lib-opt/GHCup/OptParse/Nuke.hs index ac0e465b..08da41b2 100644 --- a/lib-opt/GHCup/OptParse/Nuke.hs +++ b/lib-opt/GHCup/OptParse/Nuke.hs @@ -24,6 +24,7 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad (forM_, void) import Control.Monad.Reader import Control.Monad.Trans.Resource +import Data.Foldable.WithIndex import Data.Maybe import Data.Variant.Excepts import Options.Applicative hiding ( style, ParseError ) @@ -82,7 +83,7 @@ nuke appState runLogger = do lInstalled' <- liftE $ listVersions Nothing [ListInstalled True] False True (Nothing, Nothing) - forM_ lInstalled' (\ListResult{..} -> liftE $ rmToolVersion lTool (TargetVersion lCross lVer)) + iforM_ lInstalled' $ \tool (_, ls) -> forM_ ls $ \ListResult{..} -> liftE $ rmToolVersion tool (TargetVersion lCross lVer) lift rmGhcupDirs diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs index 649c6cf8..aee62407 100644 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -306,7 +306,6 @@ run RunOptions{..} settings runAppState leanAppstate runLogger = do guessMode = if guessVersion settings then GLaxWithInstalled else GStrict - -- TODO: doesn't work for cross resolveToolchainFull :: ( MonadIOish m ) => Excepts '[ TagNotFound diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index cdf6b7b5..bcc1d637 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -8,6 +8,7 @@ {-# OPTIONS_GHC -Wno-unused-matches #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} module GHCup.Brick.Actions where @@ -37,7 +38,6 @@ import GHCup.Brick.Common ( BrickData (..), BrickSettings (..), Mode (..), Name (..) ) import GHCup.Brick.Widgets.Menu ( MenuKeyBindings (..) ) import GHCup.Brick.Widgets.Navigation ( BrickInternalState ) -import GHCup.Brick.Widgets.SectionList import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.Widgets.Menus.AdvancedInstall as AdvancedInstall @@ -46,7 +46,6 @@ import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu import qualified Brick -import qualified Brick.Focus as F import qualified Brick.Widgets.List as L import Control.Applicative import Control.Exception.Safe @@ -58,8 +57,9 @@ import Control.Monad.Reader import Control.Monad.Trans.Except import Control.Monad.Trans.Resource import Data.Bool -import Data.Function ( on, (&) ) +import Data.Function ( (&) ) import Data.Functor +import qualified Data.Map.Strict as M import Data.IORef ( IORef, modifyIORef, newIORef, readIORef ) import Data.List @@ -88,10 +88,10 @@ import System.FilePath import Control.Concurrent ( threadDelay ) import Optics ( to, (^.) ) import Optics.Getter ( view ) -import Optics.Operators ( (%~), (.~) ) +import Optics.Operators ( (.~) ) import Optics.Optic ( (%) ) import Optics.State ( use ) -import Optics.State.Operators ( (.=) ) +import Optics.State.Operators ( (.=), (%=) ) @@ -127,35 +127,37 @@ constructList appD settings = -- | 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. + L.listModify + (\(t, (td, vlr)) -> (t, (td, maybe vlr (`L.listMoveToElement` vlr) . V.find predicate $ L.listElements vlr))) + (L.listFindBy (\(t, _) -> tool == t) internal_state) -- | Select the latest 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] + -> ToolListResult -> 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 + let oldElem = s >>= L.listSelectedElement -- Maybe (Int, e) in case oldElem of - Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList - Nothing -> selectLatest newSectionList + Just (_, (tool, (toolDesc, elr))) -> do + case L.listSelectedElement elr of + Just (_, lr) -> + selectBy tool (\lr' -> lVer lr == lVer lr' && lCross lr == lCross lr') newList + Nothing -> selectBy tool (elem Latest . lTag) newList + Nothing -> selectBy ghc (elem Latest . lTag) newList where - toolEqual e1 e2 = - lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 + newList :: BrickInternalState + newList = + L.list + AllTools + (V.fromList $ fmap (\(tool, (td, filter filterF -> lr)) -> (tool, (td, L.list (Singular tool) (V.fromList lr) 1))) $ M.toList list_result) 1 + filterVisible :: Bool -> ListResult -> Bool @@ -166,35 +168,61 @@ filterVisible v e | lInstalled e = True , Old `notElem` lTag e , Nightly `notElem` lTag e = True | otherwise = (Old `notElem` lTag e) && - (Nightly `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)) + => ( (Int, Tool, Maybe ToolDescription, ListResult) -> ReaderT AppState IO (Either String a)) -> Brick.EventM n BrickState () withIOAction action = do as <- Brick.get - case sectionListSelectedElement (view appState as) of + case L.listSelectedElement (view appState as) of + Nothing -> pure () + Just (curr_ix, (tool, (td, vlr))) -> case L.listSelectedElement vlr of + Just (curr_ix', lr) -> + Brick.suspendAndResume $ do + settings <- readIORef settings' + flip runReaderT settings $ action (curr_ix', tool, td, lr) >>= \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 + Nothing -> pure () + +withIOActionRecommended :: (Ord n, Eq n) + => ( (Int, Tool, Maybe ToolDescription, ListResult) -> ReaderT AppState IO (Either String a)) + -> Brick.EventM n BrickState () +withIOActionRecommended action = do + as <- Brick.get + case L.listSelectedElement (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 + Just (curr_ix, (tool, (td, vlr))) -> do + let mlr = V.find (\ListResult{..} -> Recommended `elem` lTag) $ L.listElements vlr + case mlr of + Just lr -> + Brick.suspendAndResume $ do + settings <- readIORef settings' + flip runReaderT settings $ action (curr_ix, tool, td, lr) >>= \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 + Nothing -> pure () installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => AdvancedInstall.InstallOptions - -> (Int, ListResult) + -> (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) -installWithOptions opts (_, ListResult {..}) = do +installWithOptions opts (_, lTool, td, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask let misolated = opts ^. AdvancedInstall.isolateDirL @@ -274,6 +302,7 @@ installWithOptions opts (_, ListResult {..}) = do runBothE' (withNoVerify $ installBindist lTool + td (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (Just $ RegexDir "ghc-.*") "" Nothing Nothing Nothing Nothing) v shouldIsolate @@ -311,13 +340,13 @@ installWithOptions opts (_, ListResult {..}) = do <> "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 ()) + => (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) install' = installWithOptions (AdvancedInstall.InstallOptions Nothing False Nothing Nothing False [] Nothing) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => (Int, ListResult) + => (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) -set' input@(_, ListResult {..}) = do +set' input@(_, lTool, _, ListResult {..}) = do settings <- liftIO $ readIORef settings' let run = @@ -398,9 +427,9 @@ logGHCPostRm ghcVer = do del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) - => (Int, ListResult) + => (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) -del' (_, ListResult {..}) = do +del' (_, lTool, _, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask let run = runE @'[NotInstalled, UninstallFailed, ParseError, MalformedInstallInfo] @@ -424,9 +453,9 @@ del' (_, ListResult {..}) = do changelog' :: (MonadReader AppState m, MonadIO m) - => (Int, ListResult) + => (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) -changelog' (_, ListResult {..}) = do +changelog' (_, lTool, _, ListResult {..}) = do AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask case getChangeLog dls lTool (ToolVersion lVer) of Nothing -> pure $ Left $ @@ -449,8 +478,8 @@ changelog' (_, ListResult {..}) = do 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 = Tool "ghc", ..}) = do + => CompileGHC.CompileGHCOptions -> (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) +compileGHC compopts (_, Tool "ghc", _, lr@ListResult{..}) = do appstate <- ask let run = runResourceT @@ -547,12 +576,11 @@ compileGHC compopts (_, lr@ListResult{lTool = Tool "ghc", ..}) = 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 ()) - +compileGHC _ (_, _, _, _) = 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 = Tool "hls", ..}) = do + => CompileHLS.CompileHLSOptions -> (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ()) +compileHLS compopts (_, Tool "hls", _, lr@ListResult{..}) = do appstate <- ask let run = runResourceT @@ -638,7 +666,7 @@ compileHLS compopts (_, lr@ListResult{lTool = Tool "hls", ..}) = 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 ()) +compileHLS _ (_, _, _, _) = pure (Right ()) settings' :: IORef AppState @@ -688,50 +716,75 @@ getAppData mgi = runExceptT $ do -- -keyHandlers :: KeyBindings +keyHandlersToolList :: KeyBindings + -> [ ( KeyCombination + , Maybe (BrickSettings -> String) + , Brick.EventM Name BrickState () + ) + ] +keyHandlersToolList KeyBindings {..} = + [ (bQuit, Just $ const "Quit" , Brick.halt) + , (bInstall, Just $ const "Install and set recommended version", + withIOActionRecommended $ installWithOptions (AdvancedInstall.InstallOptions Nothing True Nothing Nothing False [] Nothing)) + , ( bShowAllVersions + , Just $ \BrickSettings {..} -> + if _showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . _showAllVersions) + ) + , (KeyCombination (Vty.KChar 'h') [], Just $ const "help", mode .= KeyInfo) + , (KeyCombination Vty.KEnter [], Just $ const "Show tool details", mode .= Common.ToolInfo ) + , (KeyCombination KLeft [], Nothing, versionFocus .= False) + , (KeyCombination KRight [], Nothing, versionFocus .= True) + , (KeyCombination (Vty.KChar '\t') [], Nothing, versionFocus %= not) + ] + +keyHandlersVersionList :: KeyBindings -> [ ( KeyCombination - , BrickSettings -> String + , Maybe (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') +keyHandlersVersionList KeyBindings {..} = + [ (bQuit, Just $ const "Quit" , Brick.halt) + , (bInstall, Just $ const "Install" , withIOAction install') + , (bUninstall, Just $ const "Uninstall", withIOAction del') + , (bSet, Just $ const "Set" , withIOAction set') + , (bChangelog, Just $ const "ChangeLog", withIOAction changelog') , ( bShowAllVersions - , \BrickSettings {..} -> + , Just $ \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 "advanced options", createMenuforTool ) + , (KeyCombination (Vty.KChar 'h') [], Just $ const "help", mode .= KeyInfo) + , (KeyCombination Vty.KEnter [], Just $ const "advanced options", createMenuforTool ) + , (KeyCombination KLeft [], Nothing, versionFocus .= False) + , (KeyCombination KRight [], Nothing, versionFocus .= True) + , (KeyCombination (Vty.KChar '\t') [], Nothing, versionFocus %= not) ] where createMenuforTool = do - e <- use (appState % to sectionListSelectedElement) + e <- use (appState % to L.listSelectedElement) 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 - (MenuKeyBindings { mKbUp = bUp, mKbDown = bDown, mKbQuit = bQuit}) - -- Set mode to context - mode .= ContextPanel + Nothing -> pure () + Just (_, (t, (td, vlr))) -> case L.listSelectedElement vlr of + Just (_, lr) -> 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 (t, (td, lr)) + (MenuKeyBindings { mKbUp = bUp, mKbDown = bDown, mKbQuit = bQuit}) + -- Set mode to context + mode .= ContextPanel + Nothing -> pure () 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) +hideShowHandler' :: (BrickSettings -> Bool) -> Brick.EventM Name BrickState () +hideShowHandler' f = do + app_settings <- use appSettings + let + vers = f app_settings + newAppSettings = app_settings & Common.showAllVersions .~ vers + ad <- use appData + current_app_state <- use appState + appSettings .= newAppSettings + appState .= constructList ad newAppSettings (Just current_app_state) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index de77a354..0fb9ff60 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -25,10 +25,11 @@ module GHCup.Brick.App where import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Attributes as Attributes -import GHCup.Brick.BrickState (BrickState (..), advancedInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu, compileHLSMenu) +import GHCup.Brick.BrickState (BrickState (..), advancedInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu, compileHLSMenu, versionFocus) 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.ToolInfo as ToolInfo 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 @@ -36,7 +37,7 @@ import qualified GHCup.Brick.Widgets.Menu as Menu import qualified GHCup.Brick.Widgets.Menus.AdvancedInstall as AdvancedInstall import GHCup.Command.List (ListResult) -import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination), KeyBindings (..)) +import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination), KeyBindings (..), Tool, ToolDescription) import qualified Brick.Focus as F import Brick ( @@ -68,6 +69,7 @@ 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 (void, when) +import Control.Monad.State.Class (get) app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -93,15 +95,20 @@ drawUI dimAttrs st = . 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) + . fmap (\(KeyCombination key mods, mpretty_setting, _) -> + case mpretty_setting of + Just pretty_setting -> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings) + Nothing -> "" ) - $ Actions.keyHandlers (st ^. appKeys) - navg = Navigation.draw dimAttrs (st ^. appState) <=> footer + $ if st ^. versionFocus + then Actions.keyHandlersVersionList (st ^. appKeys) + else Actions.keyHandlersToolList (st ^. appKeys) + navg = Navigation.draw (st ^. versionFocus) dimAttrs (st ^. appState) <=> footer in case st ^. mode of Navigation -> [navg] Tutorial -> [Tutorial.draw (bQuit $ st ^. appKeys), navg] KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] + ToolInfo -> [ToolInfo.draw (st ^. appState) (st ^. appKeys), navg] ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg] AdvancedInstallPanel -> AdvancedInstall.draw (st ^. advancedInstallMenu) ++ [navg] CompileGHCPanel -> CompileGHC.draw (st ^. compileGHCMenu) ++ [navg] @@ -118,6 +125,14 @@ keyInfoHandler ev = do | bQuit kb == KeyCombination key mods -> mode .= Navigation _ -> pure () +toolInfoHandler :: BrickEvent Name e -> EventM Name BrickState () +toolInfoHandler ev = do + AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' + case ev of + VtyEvent (Vty.EvKey key mods) + | bQuit kb == KeyCombination key mods -> mode .= Navigation + _ -> pure () + -- | On q, go back to navigation. Else, do nothing tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () tutorialHandler ev = do @@ -130,13 +145,19 @@ tutorialHandler ev = do -- | Tab/Arrows to navigate. navigationHandler :: BrickEvent Name e -> EventM Name BrickState () navigationHandler ev = do + BrickState{..} <- get 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 + inner_event@(VtyEvent (Vty.EvKey key mods)) + | _versionFocus -> do + case find (\(key', _, _) -> key' == KeyCombination key mods) (Actions.keyHandlersVersionList kb) of + Just (_, _, handler) -> handler + Nothing -> void $ Common.zoom appState $ Navigation.handler _versionFocus inner_event + | otherwise -> do + case find (\(key', _, _) -> key' == KeyCombination key mods) (Actions.keyHandlersToolList kb) of + Just (_, _, handler) -> handler + Nothing -> void $ Common.zoom appState $ Navigation.handler _versionFocus inner_event + inner_event -> Common.zoom appState $ Navigation.handler _versionFocus inner_event contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState () contextMenuHandler ev = do @@ -162,8 +183,9 @@ compileHLSHandler = menuWithOverlayHandler compileHLSMenu Actions.compileHLS Com -- | Passes all events to innerHandler if an overlay is opened -- else handles the exitKey and Enter key for the Menu's "OkButton" -menuWithOverlayHandler :: Lens' BrickState (Menu.Menu t Name) - -> (t -> ((Int, ListResult) -> ReaderT AppState IO (Either String a))) +menuWithOverlayHandler :: + Lens' BrickState (Menu.Menu t Name) + -> (t -> ((Int, Tool, Maybe ToolDescription, ListResult) -> ReaderT AppState IO (Either String a))) -> (BrickEvent Name e -> EventM Name (Menu.Menu t Name) ()) -> BrickEvent Name e -> EventM Name BrickState () @@ -187,6 +209,7 @@ eventHandler ev = do m <- use mode case m of KeyInfo -> keyInfoHandler ev + ToolInfo -> toolInfoHandler ev Tutorial -> tutorialHandler ev Navigation -> navigationHandler ev ContextPanel -> contextMenuHandler ev diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index cd8c8d6f..231e1150 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -48,6 +48,7 @@ data BrickState = BrickState , _compileHLSMenu :: CompileHLSMenu , _appKeys :: KeyBindings , _mode :: Mode + , _versionFocus :: Bool } --deriving Show diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 6e4ee491..fe8eb8e5 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -51,7 +51,7 @@ module GHCup.Brick.Common ( , BootstrapGhcSelectBox, HadrianGhcSelectBox, ToolVersionBox, GHCInstallTargets ) ) where -import GHCup.Command.List ( ListResult ) +import GHCup.Command.List ( ToolListResult ) import GHCup.Prelude ( isWindows ) import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) import Data.List (intercalate) @@ -159,6 +159,7 @@ data Name = AllTools -- ^ The main list widget -- | Mode type. It helps to dispatch events to different handlers. data Mode = Navigation | KeyInfo + | ToolInfo | Tutorial | ContextPanel | AdvancedInstallPanel @@ -206,7 +207,7 @@ frontwardLayer layer_name = Brick.centerLayer . Brick.hLimitPercent 80 . Brick.vLimitPercent 75 - . Brick.withBorderStyle Border.unicode + . Brick.withBorderStyle Border.unicodeBold . Border.borderWithLabel (Brick.txt layer_name) -- | puts a cursor at the line beginning so It can be read by screen readers @@ -219,7 +220,7 @@ enableScreenReader n = Brick.putCursor n (Brick.Location (0,0)) zoom l = Brick.zoom (toLensVL l) data BrickData = BrickData - { _lr :: [ListResult] + { _lr :: ToolListResult } deriving Show diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs index 9122cfb9..8eea1c5d 100644 --- a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -40,7 +40,12 @@ draw KeyBindings {..} = Brick.hBox [ Brick.txt "Press " , Common.keyToWidget bUp, Brick.txt " and ", Common.keyToWidget bDown - , Brick.txtWrap " to navigate the list of tools" + , Brick.txtWrap " to select an element in the currently focused list (tools or versions)" + ], + Brick.hBox [ + Brick.txt "Press " + , Brick.txt "← and →" + , Brick.txtWrap " to switch between tool and version list" ] , Brick.hBox [ Brick.txt "Press " diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index ad315b8d..364fb336 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -527,8 +527,15 @@ isValidMenu :: Menu s n -> Bool isValidMenu m = all isValidField (menuFields m) && (case menuValidator m (menuState m) of { Nothing -> True; _ -> False }) -createMenu :: n -> s -> T.Text -> (s -> Maybe ErrorMessage) - -> MenuKeyBindings -> [Button s n] -> [MenuField s n] -> Menu s n +createMenu :: + n + -> s + -> T.Text + -> (s -> Maybe ErrorMessage) + -> MenuKeyBindings + -> [Button s n] + -> [MenuField s n] + -> Menu s n createMenu n initial title validator keys buttons fields = Menu fields initial validator buttons ring keys n title where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons] diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs index b4ff36ae..8a05521d 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -10,7 +10,7 @@ import Prelude hiding (appendFile) import Data.Versions (prettyVer) import GHCup.Command.List ( ListResult(..) ) -import GHCup.Types (Tool (..)) +import GHCup.Types (Tool (..), ToolDescription(..)) import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.Widgets.Menu as Menu @@ -21,16 +21,16 @@ import qualified Brick.Widgets.Border as Border import qualified Brick.Focus as F import Brick.Widgets.Core ((<+>)) -import Optics (to) +import Optics (to, _1, _2) import Optics.Operators ((.~), (^.)) import Optics.Optic ((%)) import Data.Foldable (foldl') import qualified Data.Text as T -type ContextMenu = Menu ListResult Name +type ContextMenu = Menu (Tool, (Maybe ToolDescription, ListResult)) Name -create :: ListResult -> MenuKeyBindings -> ContextMenu -create lr keyBindings = Menu.createMenu Common.ContextBox lr "" validator keyBindings buttons [] +create :: (Tool, (Maybe ToolDescription, ListResult)) -> MenuKeyBindings -> ContextMenu +create (tool, (td, lr)) keyBindings = Menu.createMenu Common.ContextBox (tool, (td, lr)) "" validator keyBindings buttons [] where advInstallButton = Menu.createButtonField (MenuElement Common.AdvancedInstallButton) @@ -45,7 +45,7 @@ create lr keyBindings = Menu.createMenu Common.ContextBox lr "" validator keyBin & Menu.fieldLabelL .~ "Compile" & Menu.fieldHelpMsgL .~ "Compile HLS from source" buttons = - case lTool lr of + case tool of Tool "ghc" -> [advInstallButton, compileGhcButton] Tool "hls" -> [advInstallButton, compileHLSButton] _ -> [advInstallButton] @@ -54,7 +54,7 @@ create lr keyBindings = Menu.createMenu Common.ContextBox lr "" validator keyBin draw :: ContextMenu -> Widget Name draw menu = Common.frontwardLayer - ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ menu ^. Menu.menuStateL)) + ("Context Menu for " <> tool_str <> " " <> prettyVer (menu ^. Menu.menuStateL % _2 % _2 % to lVer)) $ Brick.vBox [ Brick.vBox buttonWidgets , Brick.txt " " @@ -73,7 +73,7 @@ draw menu = 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 + case menu ^. Menu.menuStateL % _1 of Tool "ghc" -> "GHC" Tool "ghcup" -> "GHCup" Tool "cabal" -> "Cabal" diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs index bc764916..6ae1aa86 100644 --- a/lib-tui/GHCup/Brick/Widgets/Navigation.hs +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -7,6 +7,7 @@ {-# OPTIONS_GHC -Wno-unused-matches #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} {- 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) @@ -15,7 +16,7 @@ and a label which we can use in rendering. This data-structure helps to reuse Br -} -module GHCup.Brick.Widgets.Navigation (BrickInternalState, create, handler, draw) where +module GHCup.Brick.Widgets.Navigation (BrickInternalState, handler, draw) where import GHCup.Command.List ( ListResult(..) ) import GHCup.Types @@ -23,10 +24,9 @@ import GHCup.Types Tool(..), Tag(..), tVerToText, - tagToString ) + tagToString, ToolDescription ) 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), @@ -36,55 +36,88 @@ import Brick (<+>), (<=>)) import qualified Brick -import Brick.Widgets.Border ( hBorder, borderWithLabel) +import Brick.Widgets.Border ( hBorder, borderWithLabel, vBorder) 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 import Text.PrettyPrint.HughesPJClass (prettyShow) +import Control.Monad.State.Class (get, modify) +import qualified Graphics.Vty as Vty +type BrickList = L.GenericList Common.Name V.Vector -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 +type BrickInternalState = BrickList (Tool, (Maybe ToolDescription, BrickList ListResult)) -- | How the navigation handler handle events -handler :: BrickEvent Common.Name e -> EventM Common.Name BrickInternalState () -handler = SectionList.handleGenericListEvent +handler :: Bool -> BrickEvent Common.Name e -> EventM Common.Name BrickInternalState () +handler False (Brick.VtyEvent e) = L.handleListEvent e +handler True (Brick.VtyEvent e) = do + bis :: BrickInternalState <- get + case L.listSelectedElement bis of + Nothing -> pure () + Just (_, (t, (td, vlr))) -> do + updatedVlr <- Brick.nestEventM' vlr (handleVersionEvent e) + modify (L.listModify $ (fmap . fmap) (const updatedVlr)) + where + -- need to reverse because we reversed the list + handleVersionEvent (Vty.EvKey Vty.KUp []) = L.handleListEvent (Vty.EvKey Vty.KDown []) + handleVersionEvent (Vty.EvKey Vty.KDown []) = L.handleListEvent (Vty.EvKey Vty.KUp []) + handleVersionEvent (Vty.EvKey Vty.KPageDown []) = L.handleListEvent (Vty.EvKey Vty.KPageUp []) + handleVersionEvent (Vty.EvKey Vty.KPageUp []) = L.handleListEvent (Vty.EvKey Vty.KPageDown []) + handleVersionEvent (Vty.EvKey Vty.KHome []) = L.handleListEvent (Vty.EvKey Vty.KEnd []) + handleVersionEvent (Vty.EvKey Vty.KEnd []) = L.handleListEvent (Vty.EvKey Vty.KHome []) + handleVersionEvent e' = L.handleListEvent e' +handler _ _ = pure () + -- | How to draw the navigation widget -draw :: AttrMap -> BrickInternalState -> Widget Common.Name -draw dimAttrs section_list +draw :: Bool -> AttrMap -> BrickInternalState -> Widget Common.Name +draw versionFocus dimAttrs bis = Brick.padBottom Max - ( Brick.withBorderStyle unicode + ( Brick.joinBorders $ Brick.withBorderStyle unicode $ borderWithLabel (Brick.str "GHCup") - (center (header <=> hBorder <=> renderList' section_list)) + (center (Brick.vLimit 1 header <=> hBorder <=> renderList')) ) where + minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') + allElements = L.listElements bis + minToolSize = V.maximum $ V.map (length . prettyShow . fst) allElements + selectedTool = fmap snd $ L.listSelectedElement bis + minTagSize = maybe 0 (\(t, (_, vlr)) -> V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) $ L.listElements vlr) selectedTool + minVerSizeList = maybe 0 (\(t, (_, vlr)) -> V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (TargetVersion lCross lVer)) $ L.listElements vlr) selectedTool + minVerHeaderSize = length $ maybe "Versions" (\(fst -> t) -> prettyShow t <> " versions") selectedTool + minVerSize = max minVerSizeList minVerHeaderSize 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 1) (minHSize (minToolSize + 2) (Brick.str "Tool")) + <+> vBorder + <+> Brick.padLeft (Pad 1) (minHSize (minVerSize + 2) (maybe (Brick.str "Versions") (\(fst -> t) -> printTool t <+> Brick.str " versions") selectedTool)) + <+> Brick.padLeft (Pad 2) (minHSize minTagSize (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 (TargetVersion lCross lVer)) allElements - minToolSize = V.maximum $ V.map (\ListResult{..} -> length $ prettyShow lTool) allElements - in Brick.withDefAttr L.listAttr $ SectionList.renderSectionList (renderItem minToolSize minTagSize minVerSize) True bis - renderItem minToolSize minTagSize minVerSize listIx b listResult@ListResult{lTag = lTag', ..} = + + renderList' = + let toolColumn = Brick.hLimit (minToolSize + 2) + (Brick.withDefAttr L.listAttr (L.renderList renderTool (not versionFocus) bis)) + versionColumn = maybe Brick.emptyWidget + (\(t, (_, vlr)) -> + Brick.withDefAttr L.listAttr + $ L.renderListWithIndex (renderItem t) versionFocus + $ L.listReverse vlr + ) + selectedTool + in Brick.padLeft (Pad 1) toolColumn + <+> vBorder + <+> Brick.padLeft (Pad 1) versionColumn + + renderTool :: Bool -> (Tool, (Maybe ToolDescription, BrickList ListResult)) -> Widget Common.Name + renderTool b (t, (tDesc, _)) = minHSize minToolSize $ printTool t + + renderItem t listIx 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) @@ -95,21 +128,17 @@ draw dimAttrs section_list dim | lNoBindist && not lInstalled && not b -- TODO: overloading dim and active ignores active - -- so we hack around it here + -- 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.ListItem lTool listIx) else id - in Brick.clickable (Common.ListItem lTool listIx) $ hooray $ active $ dim + active = if b then Common.enableScreenReader (Common.ListItem t listIx) else id + in Brick.clickable (Common.ListItem t listIx) $ hooray $ active $ dim ( marks - <+> Brick.padLeft (Pad 2) - ( minHSize (minToolSize + 1) - (printTool lTool) - ) - <+> minHSize minVerSize (Brick.str ver) + <+> Brick.padLeft (Pad 1) (minHSize minVerSize (Brick.str ver)) <+> (let l = mapMaybe printTag $ sort lTag' in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l then Brick.emptyWidget @@ -150,9 +179,3 @@ draw dimAttrs section_list Nothing -> mempty Just d -> [Brick.withAttr Attributes.dayAttr $ Brick.str (show d)]) - minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') - -instance SectionList.ListItemSectionNameIndex Common.Name where - getListItemSectionNameIndex = \case - Common.ListItem tool ix -> Just (Common.Singular tool, ix) - _ -> Nothing diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs deleted file mode 100644 index 3c62f940..00000000 --- a/lib-tui/GHCup/Brick/Widgets/SectionList.hs +++ /dev/null @@ -1,206 +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 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 - --- | To support selection by mouse click we need to obtain section name and item --- index from the name of the item that got clicked. This helper class is to get that -class ListItemSectionNameIndex n where - getListItemSectionNameIndex :: n -> Maybe (n, Int) - --- | 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 - -sectionListSelectItem :: (L.Splittable t, Eq n, ListItemSectionNameIndex n, Foldable t) => n -> EventM n (GenericSectionList n t e) () -sectionListSelectItem selectedItem = case getListItemSectionNameIndex selectedItem of - Nothing -> pure () - Just (secName, ix) -> do - sectionListFocusRingL %= F.focusSetCurrent secName - Common.zoom (sectionL secName) (Brick.modify $ L.listMoveTo ix) - --- | 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) --- * Select an element via Mouse left click -handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n, ListItemSectionNameIndex 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 n Vty.BLeft _ _) = sectionListSelectItem n -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)) - => (Int -> 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.renderListWithIndex (\i b -> renderElem i (b && hasFocus)) hasFocus l - - -- compute the location to focus on within the active section - (c, r) :: (Int, Int) = case sectionListSelectedElement ge of - Nothing -> (0, 0) - Just (selElIx, _) -> (0, selElIx) - - --- | Equivalent to listSelectedElement -sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) -sectionListSelectedElement generic_section_list = do - current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent - let current_section = generic_section_list ^. sectionL current_focus - L.listSelectedElement current_section diff --git a/lib-tui/GHCup/Brick/Widgets/ToolInfo.hs b/lib-tui/GHCup/Brick/Widgets/ToolInfo.hs new file mode 100644 index 00000000..e0856fde --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/ToolInfo.hs @@ -0,0 +1,108 @@ +{-# 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 #-} +{-# LANGUAGE ViewPatterns #-} + +module GHCup.Brick.Widgets.ToolInfo where + +import GHCup.Brick.Widgets.Navigation ( BrickInternalState ) +import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Types ( KeyBindings (..) ) +import GHCup.Types.Optics + +import qualified GHCup.Brick.Common as Common + +import Brick + ( Padding (Max), Widget (..), (<+>), (<=>) ) +import Brick.Widgets.Center ( center ) +import Data.Maybe ( fromMaybe ) +import Optics ( to, (%), (^.) ) +import Prelude hiding ( appendFile ) +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString ( serializeURIRef' ) + +import qualified Brick +import qualified Brick.Widgets.List as L +import qualified Data.Text as T + + +mkTextBox :: [Widget Common.Name] -> Widget Common.Name +mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + +draw :: BrickInternalState -> KeyBindings -> Widget Common.Name +draw (L.listSelectedElement -> (Just (_, (tool, (Just td, _))))) (KeyBindings {..}) = + Common.frontwardLayer (T.pack (prettyShow tool) <> " details") + $ Brick.vBox [ + center $ Brick.hLimitPercent 70 $ + (Brick.vBox . fmap (Brick.padRight (Brick.Pad 2))) [ + Brick.hBox [ + Brick.txt "Description: " + ], + Brick.hBox [ + Brick.txt "Homepage: " + ], + Brick.hBox [ + Brick.txt "Repository: " + ], + Brick.hBox [ + Brick.txt "Author: " + ], + Brick.hBox [ + Brick.txt "Maintainer: " + ], + Brick.hBox [ + Brick.txt "Contact: " + ], + Brick.hBox [ + Brick.txt "License: " + ] + ] + <+> + (Brick.vBox . fmap (Brick.padRight Brick.Max)) [ + Brick.hBox [ + Brick.txt (td ^. toolDescription) + ], + Brick.hBox [ + td ^. toolHomepage % to maybeURI + ], + Brick.hBox [ + td ^. toolRepository % to maybeURI + ], + Brick.hBox [ + Brick.txt (td ^. toolAuthor % to maybeString) + ], + Brick.hBox [ + Brick.txt (td ^. toolMaintainer % to maybeString) + ], + Brick.hBox [ + Brick.txt (td ^. toolContact % to maybeString) + ], + Brick.hBox [ + Brick.txt (td ^. toolLicense % to maybeString) + ] + ] + ] + <=> Brick.hBox [Brick.txt "Press " <+> Common.keyToWidget bQuit <+> Brick.txt " to return to Navigation"] + where + maybeString = T.pack . fromMaybe "-- Not specified --" + maybeURI = maybe (Brick.txt "-- Not specified --") + (\url -> let link = decUTF8Safe . serializeURIRef' $ url + in Brick.hyperlink link . Brick.txt $ link + ) +draw _ (KeyBindings {..}) = + Common.frontwardLayer "Tool details" + $ Brick.vBox [ + center $ + mkTextBox [ + Brick.hBox [ + Brick.txt "No details available" + ] + ] + ] <=> + Brick.hBox [Brick.txt "Press " <+> Common.keyToWidget bQuit <+> Brick.txt " to return to Navigation"] diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index 32592d89..5feee6e7 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -17,8 +17,8 @@ module GHCup.BrickMain where import GHCup.Command.List ( ListResult (..)) import GHCup.Types - ( Settings(noColor), ghc, - AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings(..) ) + ( Settings(noColor), + AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings(..), Tool(..) ) import GHCup.Prelude.Logger ( logError ) import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Common as Common @@ -26,10 +26,10 @@ 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.AdvancedInstall as AdvancedInstall import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC import GHCup.Brick.Widgets.Menu (MenuKeyBindings(..)) +import qualified Brick.Widgets.List as L import qualified Brick import Control.Monad.Reader ( ReaderT(runReaderT) ) @@ -41,6 +41,7 @@ import System.Exit ( ExitCode(ExitFailure), exitWith ) import qualified Data.Text as T import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS import Data.Maybe (isNothing) +import qualified Data.Map.Strict as M @@ -53,7 +54,7 @@ brickMain s = do case eAppData of Right ad -> do let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing - current_element = Navigation.sectionListSelectedElement initial_list + current_element = L.listSelectedElement initial_list exit_key = let KeyBindings {..} = keyBindings s in MenuKeyBindings { mKbUp = bUp, mKbDown = bDown, mKbQuit = bQuit} @@ -61,25 +62,32 @@ brickMain s = do 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) - installedGHCs = fmap lVer $ - filter (\(ListResult {..}) -> lInstalled && lTool == ghc && isNothing lCross) (Common._lr ad) - initstate = - AppState.BrickState ad - Common.defaultAppSettings - initial_list - (ContextMenu.create e exit_key) - (AdvancedInstall.create exit_key) - (CompileGHC.create exit_key installedGHCs) - (CompileHLS.create exit_key installedGHCs) - (keyBindings s) - Common.Navigation - in Brick.defaultMain initapp initstate - $> () + Just (_, (t, (td, vlr))) -> + case L.listSelectedElement vlr of + Nothing -> do + flip runReaderT s $ logError "Error building app state: empty ResultList" + exitWith $ ExitFailure 2 + Just (_, lr) -> + let initapp = + BrickApp.app + (Attributes.defaultAttributes $ noColor $ settings s) + (Attributes.dimAttributes $ noColor $ settings s) + installedGHCs = maybe [] (fmap lVer) $ do + (_, lr') <- M.lookup (Tool "ghc") $ Common._lr ad + pure $ filter (\(ListResult {..}) -> lInstalled && isNothing lCross) lr' + initstate = + AppState.BrickState ad + Common.defaultAppSettings + initial_list + (ContextMenu.create (t, (td, lr)) exit_key) + (AdvancedInstall.create exit_key) + (CompileGHC.create exit_key installedGHCs) + (CompileHLS.create exit_key installedGHCs) + (keyBindings s) + Common.Navigation + False + in Brick.defaultMain initapp initstate + $> () Left e -> do flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) exitWith $ ExitFailure 2 diff --git a/lib/GHCup/Command/Compile/GHC.hs b/lib/GHCup/Command/Compile/GHC.hs index 6cf7f6c8..cd61398e 100644 --- a/lib/GHCup/Command/Compile/GHC.hs +++ b/lib/GHCup/Command/Compile/GHC.hs @@ -391,12 +391,14 @@ compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs _ -> pure () + let toolDesc = preview (ix ghc % toolDetails % _Just) dls + case mBindist of Just bindist -> do spec <- liftE $ compileInstallSpec bindist installVer cSize <- liftIO $ getFileSize bindist cDigest <- liftIO $ getFileDigest bindist - liftE $ void $ installPackedBindist ghc bindist + liftE $ void $ installPackedBindist ghc toolDesc bindist (DownloadInfo { _dlUri = "file:" <> T.pack bindist , _dlSubdir = Just $ RegexDir "ghc-.*" @@ -424,7 +426,7 @@ compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs , _dlTag = Nothing , _dlInstallSpec = Just (toInstallationInputSpec spec) }) - lift $ recordInstallationInfo ghcdir ghc installVer dlInfo spec + lift $ recordInstallationInfo ghcdir ghc toolDesc installVer dlInfo spec case installDir of -- set and make symlinks for regular (non-isolated) installs diff --git a/lib/GHCup/Command/Compile/HLS.hs b/lib/GHCup/Command/Compile/HLS.hs index 234459c6..769793ef 100644 --- a/lib/GHCup/Command/Compile/HLS.hs +++ b/lib/GHCup/Command/Compile/HLS.hs @@ -113,6 +113,7 @@ compileHLS :: ( MonadMask m compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do pfreq@PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let toolDesc = preview (ix hls % toolDetails % _Just) dls Dirs { .. } <- lift getDirs when updateCabal $ reThrowAll @_ @'[ProcessError] DownloadFailed $ do @@ -331,14 +332,14 @@ compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal upd runE (getInstallMetadata hls (mkTVer installVer)) >>= \case VRight metadata -> do destdir <- lift withGHCupTmpDir - liftE $ addAdHocBinaries (Just metadata) tmpInstallDir installDirResolved destdir installVer True + liftE $ addAdHocBinaries (Just metadata) toolDesc tmpInstallDir installDirResolved destdir installVer True VLeft (V (FileDoesNotExistError _)) -> do inst <- lift $ isInstalled hls (mkTVer installVer) if inst then liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True else do destdir <- lift withGHCupTmpDir - liftE $ addAdHocBinaries Nothing tmpInstallDir installDirResolved destdir installVer True + liftE $ addAdHocBinaries Nothing toolDesc tmpInstallDir installDirResolved destdir installVer True VLeft (V (ParseError pe)) -> liftE $ throwE @_ @'[ParseError] (ParseError pe) VLeft v -> lift $ fail (prettyHFError v) ) @@ -382,6 +383,7 @@ compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal upd , MonadIOish m ) => Maybe InstallMetadata + -> Maybe ToolDescription -> FilePath -> InstallDirResolved -- ^ Path to install to -> GHCupPath -- ^ DESTDIR @@ -394,30 +396,34 @@ compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal upd , NoInstallInfo , ProcessError ] m () - addAdHocBinaries mMetadata workdir installDest tmpInstallDest (mkTVer -> tver) forceInstall = do + addAdHocBinaries mMetadata toolDesc workdir installDest tmpInstallDest (mkTVer -> tver) forceInstall = do binaries <- liftIO $ listDirectoryFiles workdir let spec = adHocInstallationSpec (dropSuffix exeExt <$> binaries) logDebug $ T.pack (show spec) + logDebug "Install into tmp dir as per the spec" liftE $ installTheSpec (toInstallationInputSpec spec) workdir installDest tmpInstallDest [] Nothing forceInstall + logDebug "Merge to filesystem" liftE $ mergeToFileSystem hls tver installDest tmpInstallDest (_isPreserveMtimes spec) forceInstall True case installDir of -- set and make symlinks for regular (non-isolated) installs GHCupInternal -> do + logDebug "Symlink binaries" Dirs {..} <- lift getDirs parsedSymlinkSpec <- forM (_isExeSymLinked spec) (liftE . parseSymlinkSpec (_tvVersion tver)) liftE $ symlinkBinaries installDest parsedSymlinkSpec (GHCupBinDir binDir) hls tver -- write InstallationInfo to the disk + logDebug "Writing installation info to disk" case mMetadata of (Just (InstallMetadata { _imResolvedInstallSpec, _imDownloadInfo })) -> do - lift $ recordInstallationInfo installDest hls tver _imDownloadInfo (manipulateSpec _imResolvedInstallSpec spec) + lift $ recordInstallationInfo installDest hls toolDesc tver _imDownloadInfo (manipulateSpec _imResolvedInstallSpec spec) Nothing -> do let dlInfo = DownloadInfo "" Nothing "" Nothing Nothing Nothing (Just $ toInstallationInputSpec spec) - lift $ recordInstallationInfo installDest hls tver dlInfo spec + lift $ recordInstallationInfo installDest hls toolDesc tver dlInfo spec _ -> pure () pure () diff --git a/lib/GHCup/Command/GC.hs b/lib/GHCup/Command/GC.hs index a59015cc..df1c25d4 100644 --- a/lib/GHCup/Command/GC.hs +++ b/lib/GHCup/Command/GC.hs @@ -41,6 +41,7 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) import Data.ByteString ( ByteString ) +import Data.Foldable.WithIndex import Data.List import Data.Maybe import Data.Variant.Excepts @@ -86,7 +87,7 @@ rmUnsetTools :: ( MonadReader env m => Excepts '[NotInstalled, UninstallFailed, ParseError, MalformedInstallInfo] m () rmUnsetTools = do vers <- liftE $ listVersions Nothing [ListInstalled True, ListSet False] False True (Nothing, Nothing) - forM_ vers $ \ListResult{..} -> liftE $ rmToolVersion lTool (TargetVersion lCross lVer) + iforM_ vers $ \tool (_, ls) -> forM_ ls $ \ListResult{..} -> liftE $ rmToolVersion tool (TargetVersion lCross lVer) rmProfilingLibs :: ( MonadReader env m diff --git a/lib/GHCup/Command/Install.hs b/lib/GHCup/Command/Install.hs index 31954876..855ae251 100644 --- a/lib/GHCup/Command/Install.hs +++ b/lib/GHCup/Command/Install.hs @@ -91,8 +91,9 @@ installTool :: m (InstallationSpecResolved, FilePath) installTool tool tver installDir forceInstall extraArgs installTargets = do + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo dlinfo <- liftE $ getDownloadInfo' tool tver - installBindist tool dlinfo tver installDir forceInstall extraArgs installTargets + installBindist tool (preview (ix tool % toolDetails % _Just) dls) dlinfo tver installDir forceInstall extraArgs installTargets -- | Like 'installCabalBin', except takes the 'DownloadInfo' as -- argument instead of looking it up from 'GHCupDownloads'. @@ -106,6 +107,7 @@ installBindist :: , MonadIOish m ) => Tool + -> Maybe ToolDescription -> DownloadInfo -> TargetVersion -> InstallDir @@ -136,7 +138,7 @@ installBindist :: ] m (InstallationSpecResolved, FilePath) -installBindist tool dlinfo tver installDir forceInstall extraArgs installTargets = do +installBindist tool toolDesc dlinfo tver installDir forceInstall extraArgs installTargets = do lift $ logDebug $ "Requested to install " <> T.pack (prettyShow tool) <> " version " <> T.pack (prettyShow tver) @@ -163,12 +165,12 @@ installBindist tool dlinfo tver installDir forceInstall extraArgs installTargets case installDir of IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir - installSpec <- liftE $ installPackedBindist tool dl dlinfo (IsolateDirResolved isoDir) tver forceInstall extraArgs installTargets + installSpec <- liftE $ installPackedBindist tool toolDesc dl dlinfo (IsolateDirResolved isoDir) tver forceInstall extraArgs installTargets pure (installSpec, isoDir) GHCupInternal -> do -- regular install instDir <- lift $ toolInstallDestination tool tver - installSpec <- liftE $ installPackedBindist tool dl dlinfo (GHCupDir instDir) tver forceInstall extraArgs installTargets + installSpec <- liftE $ installPackedBindist tool toolDesc dl dlinfo (GHCupDir instDir) tver forceInstall extraArgs installTargets pure (installSpec, fromGHCupPath instDir) installPackedBindist :: @@ -181,6 +183,7 @@ installPackedBindist :: , MonadIOish m ) => Tool + -> Maybe ToolDescription -> FilePath -- ^ Path to the tarball -> DownloadInfo -> InstallDirResolved -- ^ Path to install to @@ -200,7 +203,7 @@ installPackedBindist :: , NoInstallInfo , MalformedInstallInfo ] m InstallationSpecResolved -installPackedBindist tool dl dlInfo inst tver forceInstall extraArgs installTargets = do +installPackedBindist tool toolDesc dl dlInfo inst tver forceInstall extraArgs installTargets = do PlatformRequest {..} <- lift getPlatformReq unless forceInstall @@ -217,7 +220,7 @@ installPackedBindist tool dl dlInfo inst tver forceInstall extraArgs installTarg tmpInstallDest <- lift withGHCupTmpDir - liftE $ runBuildAction tmpUnpack $ installUnpackedBindist tool workdir + liftE $ runBuildAction tmpUnpack $ installUnpackedBindist tool toolDesc workdir inst tmpInstallDest dlInfo tver forceInstall extraArgs installTargets -- | Install an unpacked distribution. @@ -230,6 +233,7 @@ installUnpackedBindist :: forall m env . , MonadIOish m ) => Tool + -> Maybe ToolDescription -> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) -> InstallDirResolved -- ^ Path to install to -> GHCupPath -- ^ DESTDIR @@ -246,7 +250,7 @@ installUnpackedBindist :: forall m env . , NoInstallInfo , MalformedInstallInfo ] m InstallationSpecResolved -installUnpackedBindist tool workdir installDest tmpInstallDest dlInfo tver forceInstall extraArgs installTargets = do +installUnpackedBindist tool toolDesc workdir installDest tmpInstallDest dlInfo tver forceInstall extraArgs installTargets = do instSpec <- liftE $ installationSpecFromMetadata' dlInfo tool tver lift $ logInfo $ "Installing " <> T.pack (prettyShow tool) liftE $ installTheSpec instSpec workdir installDest tmpInstallDest extraArgs installTargets forceInstall @@ -264,7 +268,7 @@ installUnpackedBindist tool workdir installDest tmpInstallDest dlInfo tver force liftE $ symlinkBinaries installDest parsedSymlinkSpec (GHCupBinDir binDir) tool tver -- write InstallationInfo to the disk - lift $ recordInstallationInfo installDest tool tver dlInfo resolvedInstSpec + lift $ recordInstallationInfo installDest tool toolDesc tver dlInfo resolvedInstSpec pure resolvedInstSpec diff --git a/lib/GHCup/Command/Install/LowLevel.hs b/lib/GHCup/Command/Install/LowLevel.hs index bad977be..16271fdf 100644 --- a/lib/GHCup/Command/Install/LowLevel.hs +++ b/lib/GHCup/Command/Install/LowLevel.hs @@ -22,21 +22,23 @@ import GHCup.Types.Optics import Control.Applicative import Control.Exception.Safe import Control.Monad +import Data.Yaml.Pretty #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif -import Control.Monad.Reader -import Data.Aeson ( encodeFile ) -import Data.Maybe -import qualified Data.Text as T -import Data.Variant.Excepts -import Data.Versions hiding ( patch ) -import Data.Void -import Prelude hiding ( abs ) -import System.FilePath -import qualified System.FilePath.Posix as Posix -import System.FilePattern.Directory -import qualified Text.Megaparsec as MP +import Control.Monad.Reader +import Data.Maybe +import Data.Variant.Excepts +import Data.Versions hiding ( patch ) +import Data.Void +import Prelude hiding ( abs ) +import System.FilePath +import System.FilePattern.Directory + +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified System.FilePath.Posix as Posix +import qualified Text.Megaparsec as MP @@ -215,20 +217,25 @@ recordInstallationInfo :: ) => InstallDirResolved -> Tool + -> Maybe ToolDescription -> TargetVersion -> DownloadInfo -> InstallationSpecResolved -> m () -recordInstallationInfo installDest tool tver dlInfo instSpec +recordInstallationInfo installDest tool toolDesc tver dlInfo instSpec | isSafeDir installDest = do spec <- recordedInstallationSpecFile tool tver liftIO $ createDirectoryIfMissing True (takeDirectory spec) - let metadata = InstallMetadata dlInfo instSpec + let metadata = InstallMetadata dlInfo instSpec toolDesc logDebug2 $ "Writing install metadata to " <> T.pack spec <> "\n " <> T.pack (show metadata) - liftIO $ encodeFile spec metadata + liftIO $ encodeFilePretty spec metadata | otherwise = do logDebug2 $ "Skipping spec installation, because installing into isolated dir: " <> T.pack (show installDest) pure () + where + encodeFilePretty file json = + let encoded = encodePretty defConfig json + in B.writeFile file encoded sanitizefConfOptions :: MonadFail m => [String] -> m [String] sanitizefConfOptions args diff --git a/lib/GHCup/Command/List.hs b/lib/GHCup/Command/List.hs index 97e8d004..954813d2 100644 --- a/lib/GHCup/Command/List.hs +++ b/lib/GHCup/Command/List.hs @@ -18,6 +18,7 @@ module GHCup.Command.List where import GHCup.Download import GHCup.Errors import GHCup.Query.DB +import GHCup.Query.DB.HLS ( getHLSGHCs ) import GHCup.Query.Metadata import GHCup.Types import GHCup.Types.JSON @@ -51,10 +52,6 @@ import qualified Data.Set as Set - - - - ------------------ --[ List tools ]-- ------------------ @@ -67,11 +64,13 @@ data ListCriteria | ListAvailable Bool deriving (Eq, Show) + +type ToolListResult = M.Map Tool (Maybe ToolDescription, [ListResult]) + -- | A list result describes a single tool version -- and various of its properties. data ListResult = ListResult - { lTool :: Tool - , lVer :: Version + { lVer :: Version , lCross :: Maybe Text -- ^ currently only for GHC , lTag :: [Tag] @@ -110,7 +109,7 @@ listVersions :: -> Bool -> Bool -> (Maybe Day, Maybe Day) - -> Excepts '[ParseError] m [ListResult] + -> Excepts '[ParseError] m ToolListResult listVersions lt' criteria hideOld showNightly days = do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo instTools <- getAllInstalledTools lt' @@ -124,15 +123,20 @@ listVersions lt' criteria hideOld showNightly days = do ioRefAvToolsProcessed :: IORef (M.Map Tool (M.Map (Maybe Text) (Set Version))) <- liftIO $ newIORef mempty -- process installed tools first - lInst <- fmap (mconcat . mconcat) $ forM instTools $ \(tool, targetMap) -> - forM (M.toList targetMap) $ \(target, (vers', mset)) -> + lInst :: ToolListResult <- fmap M.fromList $ forM instTools $ \(tool, targetMap) -> do + toolVersions' <- forM (M.toList targetMap) $ \(target, (vers', mset)) -> forM vers' $ \ver' -> do -- versions from the metadata let avVers :: Set Version = fromMaybe mempty $ (avTools M.!? tool) >>= (M.!? target) let tver = TargetVersion target ver' - dli <- fmap veitherToEither $ runE @'[NoDownload] $ getDownloadInfo' tool tver + -- we fetch the tags from the metadata first, because e.g. 'Recommended' and 'Latest' + -- are rolling tags and may be more up to date there + dli <- runE @'[NoDownload] (getDownloadInfo' tool tver) >>= \case + VLeft _ -> fmap (veitherToEither . fmap _imDownloadInfo) $ runE (getInstallMetadata tool tver) + VRight m -> pure (Right m) let bTags = either (const []) (fromMaybe [] . _dlTag) dli + let mvi = getVersionInfo tver tool dls let tags = maybe [] _viTags mvi let lReleaseDay = mvi >>= _viReleaseDay @@ -147,22 +151,24 @@ listVersions lt' criteria hideOld showNightly days = do alterAvTarget (Just xs) = Just $ Set.insert ver' xs liftIO $ modifyIORef ioRefAvToolsProcessed (M.alter alterAvTools tool) + hlsPowered <- getHlsPowered tool target ver' pure ListResult { lVer = ver' , lCross = target , lTag = tags <> bTags - , lTool = tool , lSet = mset == Just ver' , lInstalled = True , lNoBindist = isLeft dli && not lStray - , hlsPowered = False -- TODO , .. } + let tDesc = preview (ix tool % toolDetails % _Just) dls + pure (tool, (tDesc, mconcat toolVersions')) + avToolsProcessed <- liftIO $ readIORef ioRefAvToolsProcessed -- then process tools in the metadata, that are not installed - lAv <- fmap (mconcat . mconcat) $ forM (M.toList avTools) $ \(tool, targetMap) -> - forM (M.toList targetMap) $ \(target, vers') -> fmap catMaybes $ + lAv <- fmap M.fromList $ forM (M.toList avTools) $ \(tool, targetMap) -> do + toolVersions' <- forM (M.toList targetMap) $ \(target, vers') -> fmap catMaybes $ forM (Set.toList vers') $ \ver' -> do -- versions from the metadata that's already installed let avInstVers :: Set Version = fromMaybe mempty $ (avToolsProcessed M.!? tool) >>= (M.!? target) @@ -178,20 +184,36 @@ listVersions lt' criteria hideOld showNightly days = do let tags = maybe [] _viTags mvi let lReleaseDay = mvi >>= _viReleaseDay + hlsPowered <- getHlsPowered tool target ver' + pure $ Just $ ListResult { lVer = ver' , lCross = target , lTag = tags <> bTags - , lTool = tool , lSet = False , lInstalled = False , lNoBindist = isLeft dli - , hlsPowered = False -- TODO , lStray = False , .. } - pure . sort . filter' $ lInst <> lAv + let tDesc = preview (ix tool % toolDetails % _Just) dls + pure (tool, (tDesc, mconcat toolVersions')) + + pure $ M.unionWith (\(d, vs) (d', vs') -> (d <|> d', sort $ filter' (vs <> vs'))) lInst lAv where + getHlsPowered tool target ver' = + if tool == ghc && isNothing target + then do + hlsSet <- liftE $ getSetVersion' hls Nothing + case hlsSet of + Just (hlsVer, _) -> do + ghcs <- getHLSGHCs hlsVer + pure (ver' `elem` ghcs) + Nothing -> pure False + else pure False + + + filter' :: [ListResult] -> [ListResult] filter' = filterNightly . filterOld . filter (\lr -> foldr (\a b -> fromCriteria a lr && b) True criteria) . filterDays diff --git a/lib/GHCup/Command/Set.hs b/lib/GHCup/Command/Set.hs index 052e47fa..ea5f26e9 100644 --- a/lib/GHCup/Command/Set.hs +++ b/lib/GHCup/Command/Set.hs @@ -11,7 +11,7 @@ import GHCup.Errors import GHCup.Legacy.Cabal import GHCup.Legacy.HLS import GHCup.Legacy.Stack -import GHCup.Legacy.Utils +import GHCup.Legacy.Utils (rmPlainGHC, binarySymLinkDestination, ghcInternalBinDir, ghcToolFiles) import GHCup.Prelude import GHCup.Query.DB import GHCup.Query.GHCupDirs @@ -19,6 +19,7 @@ import GHCup.Query.Symlink import GHCup.System.Directory import GHCup.Types import GHCup.Types.Optics +import GHCup.Warnings import Control.Applicative import Control.Monad @@ -36,6 +37,7 @@ import System.IO.Error import qualified Data.Text as T import qualified Data.Text.IO as T +import GHCup.Query.DB.HLS setToolVersion :: ( MonadReader env m @@ -74,7 +76,7 @@ setToolVersion' tool tver mTmpDir = do | tool == cabal -> liftE $ setCabal ver' mTmpDir | tool == stack -> liftE $ setStack ver' mTmpDir | tool == hls -> liftE $ setHLS ver' SetHLSOnly mTmpDir - | otherwise -> fail "Could not find installation metadata... your DB seems corrupted" + | otherwise -> throwE $ NotInstalled tool tver VRight spec -> do lift $ logDebug2 $ T.pack (show spec) toolDir <- lift $ fmap fromGHCupPath $ toolInstallDestination tool tver @@ -82,17 +84,22 @@ setToolVersion' tool tver mTmpDir = do (lift $ getUnqualifiedSymlinks spec toolDir) (\tmpDir -> lift $ getUnqualifiedSymlinks' tmpDir spec toolDir) mTmpDir - forM_ symls $ \(target, bin) -> do - liftIO (isShadowed bin) >>= \case - Nothing -> pure () - Just pa -> logWarn $ T.pack $ prettyHFError (ToolShadowed tool pa bin (_tvVersion tver)) + shadows <- fmap catMaybes <$> forM symls $ \(target, bin) -> do lift $ createLink target bin + liftIO (isShadowed bin) >>= \case + Nothing -> pure Nothing + Just pa -> pure $ Just (pa, bin) + logWarn $ T.pack $ prettyHFError (ToolShadowed tool (_tvVersion tver) shadows) -- record in 'set' file when (isNothing mTmpDir) $ do setFile <- lift $ recordedSetVersionFile tool (_tvTarget tver) liftIO $ createDirRecursive' (takeDirectory setFile) liftIO $ T.writeFile setFile (prettyVer . _tvVersion $ tver) + currentHLS <- liftE $ getSetVersion' hls Nothing + currentGHC <- liftE $ getSetVersion' ghc Nothing + supportedGHC <- lift $ maybe (pure []) (getHLSGHCs . fst) currentHLS + lift $ warnAboutHlsCompatibility (fst <$> currentHLS) (fst <$> currentGHC) supportedGHC pure tver where diff --git a/lib/GHCup/Command/Upgrade.hs b/lib/GHCup/Command/Upgrade.hs index 875ccdc2..ad7db528 100644 --- a/lib/GHCup/Command/Upgrade.hs +++ b/lib/GHCup/Command/Upgrade.hs @@ -152,9 +152,9 @@ upgradeGHCup' mtarget force' fatal latestVer = do liftIO (isShadowed destFile) >>= \case Nothing -> pure () Just pa - | fatal -> throwE (ToolShadowed ghcup pa destFile latestVer) + | fatal -> throwE (ToolShadowed ghcup latestVer [(pa, destFile)]) | otherwise -> - lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed ghcup pa destFile latestVer) + lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed ghcup latestVer [(pa, destFile)]) pure latestVer diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 39833166..9ee506fe 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -167,10 +167,21 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do dl' (NewSetupInfo si) = pure (Right si) dl' (NewURI uri) = do base <- liftE $ getBase uri - catchE @JSONError (\(JSONDecodeError s) -> do - logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: " <> T.pack s - Right <$> decodeMetadata @Stack.SetupInfo base) - $ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI) + gr <- runE $ decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI + case gr of + VRight r -> pure $ Left r + VLeft (V (JSONDecodeError ge)) -> do + logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: " <> T.pack ge + sr <- runE $ decodeMetadata @Stack.SetupInfo base + case sr of + VRight r -> pure $ Right r + VLeft (V (JSONDecodeError se)) -> do + throwE $ JSONDecodeError $ "\nError decoding as GHCupInfo:\n" + <> (unlines . fmap (" " <>) . lines $ ge) + <> "\nError decoding as StackSetupURL:\n" + <> (unlines . fmap (" " <>) . lines $ se) + VLeft err -> throwSomeE err + VLeft err -> throwSomeE err fromStackSetupInfo :: MonadThrow m => Stack.SetupInfo @@ -199,7 +210,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do -> m GHCupInfo mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo" mergeGhcupInfo xs@(GHCupInfo{}: _) = - let newDownloads = M.unionsWith (\(ToolInfo a _) (ToolInfo a' b') -> ToolInfo (M.unionWith (\_ b2 -> b2) a a') b') + let newDownloads = M.unionsWith (\(ToolInfo a b) (ToolInfo a' b') -> ToolInfo (M.unionWith (\_ b2 -> b2) a a') (b <|> b')) (_ghcupDownloads <$> xs) newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs) in pure $ GHCupInfo newToolReqs newDownloads Nothing diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index faf4ae19..ba49b61d 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -33,9 +33,11 @@ import System.FilePath import Text.PrettyPrint hiding ( (<>) ) import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import URI.ByteString +import Data.Functor ((<&>)) import qualified Data.Map.Strict as M import qualified Data.Text as T +import Data.List (intercalate) @@ -666,22 +668,21 @@ instance HFErrorProject HadrianNotFound where eBase _ = 320 eDesc _ = "Could not find Hadrian build files. Does this GHC version support Hadrian builds?" -data ToolShadowed = ToolShadowed Tool FilePath FilePath Version +data ToolShadowed = ToolShadowed Tool Version [(FilePath, FilePath)] -- upgraded version deriving (Show) instance Pretty ToolShadowed where - pPrint (ToolShadowed tool sh up _) = + pPrint (ToolShadowed tool ver shadows) = text (prettyShow tool - <> " is shadowed by " - <> sh - <> ".\nThe upgrade will not be in effect, unless you remove " - <> sh - <> "\nor make sure " - <> takeDirectory up - <> " comes before " - <> takeDirectory sh - <> " in PATH." + <> " version " <> T.unpack (prettyVer ver) + <> " has shadowed binaries:\n" + <> intercalate "\n" (shadows <&> \(sh, bin) -> + " * " <> bin <> " shadowed by " <> sh + ) + <> ".\nThe upgrade will not be in effect, unless you make sure that " + <> (takeDirectory . snd . head $ shadows) + <> " comes first in PATH." ) instance HFErrorProject ToolShadowed where diff --git a/lib/GHCup/Hardcoded/URLs.hs b/lib/GHCup/Hardcoded/URLs.hs index 8d90a0ea..95c469f3 100644 --- a/lib/GHCup/Hardcoded/URLs.hs +++ b/lib/GHCup/Hardcoded/URLs.hs @@ -24,7 +24,7 @@ import qualified Data.Text as T -- 'https://www.haskell.org/ghcup/exp/ghcup-.yaml' with some newlines added. -- TODO: revert to master ghcupURL :: URI -ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/installer-dsl/ghcup-0.0.9.yaml|] +ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.1.0.yaml|] stackSetupURL :: URI stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|] @@ -39,6 +39,8 @@ channelURL :: ChannelAlias -> URI channelURL = \case DefaultChannel -> ghcupURL StackChannel -> stackSetupURL - CrossChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.9.yaml|] - PrereleasesChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.9.yaml|] - VanillaChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-vanilla-0.0.9.yaml|] + CrossChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.1.0.yaml|] + PrereleasesChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.1.0.yaml|] + VanillaChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-vanilla-0.1.0.yaml|] + ThirdPartyChannel -> [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-3rdparty-0.1.0.yaml|] + diff --git a/lib/GHCup/Legacy/Cabal.hs b/lib/GHCup/Legacy/Cabal.hs index cbdf2302..17cbbbd0 100644 --- a/lib/GHCup/Legacy/Cabal.hs +++ b/lib/GHCup/Legacy/Cabal.hs @@ -81,7 +81,7 @@ setCabal ver mTmpDir = do liftIO (isShadowed cabalbin) >>= \case Nothing -> pure () - Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed cabal pa cabalbin ver) + Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed cabal ver [(pa, cabalbin)]) pure () diff --git a/lib/GHCup/Legacy/HLS.hs b/lib/GHCup/Legacy/HLS.hs index fff23fd2..1ab4c1ba 100644 --- a/lib/GHCup/Legacy/HLS.hs +++ b/lib/GHCup/Legacy/HLS.hs @@ -199,7 +199,7 @@ setHLS ver shls mBinDir = do liftIO (isShadowed wrapper) >>= \case Nothing -> pure () - Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed hls pa wrapper ver) + Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed hls ver [(pa, wrapper)]) unsetHLS :: ( MonadMask m diff --git a/lib/GHCup/Legacy/Stack.hs b/lib/GHCup/Legacy/Stack.hs index 91f196f0..a80949fd 100644 --- a/lib/GHCup/Legacy/Stack.hs +++ b/lib/GHCup/Legacy/Stack.hs @@ -80,7 +80,7 @@ setStack ver mTmpDir = do liftIO (isShadowed stackbin) >>= \case Nothing -> pure () - Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed stack pa stackbin ver) + Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed stack ver [(pa, stackbin)]) pure () diff --git a/lib/GHCup/Legacy/Utils.hs b/lib/GHCup/Legacy/Utils.hs index 88c88376..d1c7949a 100644 --- a/lib/GHCup/Legacy/Utils.hs +++ b/lib/GHCup/Legacy/Utils.hs @@ -39,6 +39,8 @@ import GHCup.Types import GHCup.Types.JSON (safeVersion, cabalBadNames) import GHCup.Types.Optics +import qualified GHCup.Warnings as Warnings + #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif @@ -55,7 +57,6 @@ import GHC.IO.Exception import Safe import System.FilePath import System.IO.Error -import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix import qualified Data.Text as T @@ -70,7 +71,6 @@ import qualified Text.Megaparsec as MP ------------------------ --- TODO: rename to binarySymLinkTarget -- | Create a relative symlink destination for the binary directory, -- given a target toolpath. binarySymLinkDestination :: ( MonadThrow m @@ -279,7 +279,6 @@ getInstalledCabals = filter (either (const True) (safeVersion . mkTVer)) <$> do Nothing -> pure $ Left f pure $ nub vs where - -- TODO: disgusting notPrefixElem a xs = not (any (`isPrefixOf` a) xs) @@ -327,6 +326,7 @@ cabalSet = do = MP.try (stripAbsolutePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse) <|> cabalParse + <|> (_tvVersion <$> toolVersionFromPath cabal) -- parses the version of "cabal-3.2.0.0" -> "3.2.0.0" cabalParse = MP.chunk "cabal-" *> version' -- parses any path component ending with path separator, @@ -389,7 +389,6 @@ getInstalledStacks = filter (either (const True) (safeVersion . mkTVer)) <$> do Nothing -> pure $ Left f -- Return the currently set stack version, if any. --- TODO: there's a lot of code duplication here :> stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version) stackSet = do Dirs {..} <- getDirs @@ -423,6 +422,7 @@ stackSet = do = MP.try (stripAbsolutePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse) <|> cabalParse + <|> (_tvVersion <$> toolVersionFromPath stack) -- parses the version of "stack-2.7.1" -> "2.7.1" cabalParse = MP.chunk "stack-" *> version' -- parses any path component ending with path separator, @@ -476,6 +476,7 @@ hlsSet = do = MP.try (stripAbsolutePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse) <|> cabalParse + <|> (_tvVersion <$> toolVersionFromPath hls) -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0" cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version' -- parses any path component ending with path separator, @@ -689,25 +690,11 @@ ghcBinaryName (TargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt) warnAboutHlsCompatibility :: ( MonadReader env m , HasDirs env , HasLog env - , MonadThrow m - , MonadCatch m - , MonadIO m + , MonadIOish m ) => m () warnAboutHlsCompatibility = do supportedGHC <- hlsGHCVersions currentGHC <- fmap _tvVersion <$> ghcSet Nothing currentHLS <- hlsSet - - case (currentGHC, currentHLS) of - (Just gv, Just hv) | gv `notElem` supportedGHC -> do - logWarn $ - "GHC-" <> T.pack (prettyShow gv) <> " appears to have no corresponding HLS-" <> T.pack (prettyShow hv) <> " binary." <> "\n" <> - "Haskell IDE support may not work." <> "\n" <> - "You can try to either: " <> "\n" <> - " 1. Install a different HLS version (e.g. downgrade for older GHCs)" <> "\n" <> - " 2. Install and set one of the following GHCs: " <> T.pack (prettyShow supportedGHC) <> "\n" <> - " 3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " <> T.pack (prettyShow hv) <> " --ghc " <> T.pack (prettyShow gv) <> - " (see https://www.haskell.org/ghcup/guide/#hls for more information)" - - _ -> return () + Warnings.warnAboutHlsCompatibility currentHLS currentGHC supportedGHC diff --git a/lib/GHCup/Prelude/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs index a58d8a31..f4a202fa 100644 --- a/lib/GHCup/Prelude/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -24,6 +24,7 @@ import Data.Text ( Text ) import Data.Versions import Data.Void import System.FilePath +import Text.PrettyPrint.HughesPJClass (prettyShow) import Data.List.NonEmpty ( NonEmpty ((:|)) ) import qualified Data.List.NonEmpty as NE @@ -32,6 +33,7 @@ import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MPC + choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a choice' [] = fail "Empty list" choice' [x ] = x @@ -168,15 +170,24 @@ isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') -- ../ghc//bin/ghc -- ../ghc//bin/ghc- ghcVersionFromPath :: MP.Parsec Void Text TargetVersion -ghcVersionFromPath = +ghcVersionFromPath = toolVersionFromPath ghc + +toolVersionFromPath :: Tool -> MP.Parsec Void Text TargetVersion +toolVersionFromPath tool = do - beforeBin <- parseUntil1 binDir <* MP.some pathSep - MP.setInput beforeBin - _ <- parseTillLastPathSep + let toolPath = T.pack $ "/" <> prettyShow tool <> "/" + ver <- parseUntilEmpty (MP.chunk toolPath) *> parseUntil1 (MP.chunk "/") + MP.setInput ver ghcTargetVerP - where - binDir = MP.some pathSep <* MP.chunk "bin" *> MP.some pathSep <* MP.takeWhile1P Nothing (not . isPathSeparator) <* MP.eof - parseTillLastPathSep = (MP.try (parseUntil1 pathSep *> MP.some pathSep) *> parseTillLastPathSep) <|> pure () + +parseUntilEmpty :: MP.Parsec Void Text a -> MP.Parsec Void Text Text +parseUntilEmpty p = go "" + where + go lastParse = do + mt <- MP.try (Just <$> parseUntil p) <|> pure Nothing + case mt of + Nothing -> pure lastParse + Just t -> p *> go t versionCmpP :: MP.Parsec Void T.Text VersionCmp versionCmpP = either (fail . T.unpack) pure =<< (translate <$> (MPC.space *> MP.try (MP.takeWhileP Nothing (`elem` ['>', '<', '=']))) <*> (MPC.space *> versioningEnd)) diff --git a/lib/GHCup/Prelude/Process/Posix.hs b/lib/GHCup/Prelude/Process/Posix.hs index 21ed996b..097daffe 100644 --- a/lib/GHCup/Prelude/Process/Posix.hs +++ b/lib/GHCup/Prelude/Process/Posix.hs @@ -114,9 +114,10 @@ execLogged exe args chdir lfile env = do $ forkIO $ EX.handle (\(_ :: IOException) -> pure ()) $ EX.finally - (if verbose > 0 - then tee fd stdoutRead - else printToRegion fd stdoutRead 6 pState no_color + (case verbose of + Verbosity i + | i > 0 -> tee fd stdoutRead + | otherwise -> printToRegion fd stdoutRead 6 pState no_color ) (putMVar done ()) diff --git a/lib/GHCup/Query/DB.hs b/lib/GHCup/Query/DB.hs index aa7326ad..e288cccd 100644 --- a/lib/GHCup/Query/DB.hs +++ b/lib/GHCup/Query/DB.hs @@ -25,7 +25,6 @@ import Control.Monad.Catch ( MonadCatch ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Reader ( MonadReader ) import Control.Monad.Trans ( lift ) -import Data.Aeson ( eitherDecodeFileStrict ) import Data.Either ( rights ) import Data.Functor ( (<&>) ) import Data.List ( nub ) @@ -34,11 +33,13 @@ import Data.Text ( Text ) import Data.Variant.Excepts ( Excepts, liftE, pattern V, pattern VLeft, pattern VRight, runE, throwE ) import Data.Versions ( Version, version ) +import Data.Yaml ( decodeEither' ) import Optics ( preview, (%) ) import System.FilePath ( takeExtension, () ) import System.IO.Error ( doesNotExistErrorType ) import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import qualified Data.ByteString as B import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T @@ -64,8 +65,13 @@ getInstallMetadata :: -> Excepts '[FileDoesNotExistError, ParseError] m InstallMetadata getInstallMetadata tool tver = do f <- lift $ recordedInstallationSpecFile tool tver - r <- liftIOException doesNotExistErrorType (FileDoesNotExistError f) (liftIO $ eitherDecodeFileStrict f) - either (throwE . ParseError) pure r + -- we have to trigger 'doesNotExistErrorType' explicitly, since libyaml swallows it, so + -- we have to avoid 'decodeFileEither': + -- https://github.com/snoyberg/yaml/blob/7380d7f560daa2f45ff265d425866f497ca07966/libyaml/src/Text/Libyaml.hs#L656-L657 + r <- liftIOException doesNotExistErrorType (FileDoesNotExistError f) $ liftIO $ do + contents <- B.readFile f + pure $ decodeEither' contents + either (throwE . ParseError . displayException) pure r diff --git a/lib/GHCup/Query/DB/HLS.hs b/lib/GHCup/Query/DB/HLS.hs new file mode 100644 index 00000000..1946ff98 --- /dev/null +++ b/lib/GHCup/Query/DB/HLS.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHCup.Query.DB.HLS where + +import GHCup.Legacy.Utils +import GHCup.Prelude +import GHCup.Query.DB +import GHCup.Types +import GHCup.Types.Optics + +import Control.Monad.Reader ( MonadReader ) +import Data.List ( stripPrefix ) +import Data.Maybe ( catMaybes ) +import Data.Variant.Excepts ( pattern VLeft, pattern VRight, runE ) +import Data.Versions ( Version, version ) +import Safe ( headMay ) + +import qualified Data.Text as T + + +getHLSGHCs :: + ( MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasLog env + , MonadIOish m + ) + => Version + -> m [Version] +getHLSGHCs hlsVer = do + vspec <- runE $ getSymlinkSpec hls (mkTVer hlsVer) + case vspec of + VRight (fmap (\SymlinkSpec{..} -> _slLinkName) -> bins) -> do + let extractGHCVerFromBinary bin = do + prefix <- headMay $ splitOn "~" bin + s <- stripPrefix "haskell-language-server-" prefix + either (const Nothing) pure . version . T.pack $ s + ghcs = catMaybes $ extractGHCVerFromBinary <$> bins + pure ghcs + -- legacy + VLeft _ -> do + hlsGHCVersions' hlsVer + diff --git a/lib/GHCup/Query/GHCupDirs.hs b/lib/GHCup/Query/GHCupDirs.hs index 146e6851..479e4384 100644 --- a/lib/GHCup/Query/GHCupDirs.hs +++ b/lib/GHCup/Query/GHCupDirs.hs @@ -399,7 +399,6 @@ toolBaseDir tool = do Dirs {..} <- getDirs pure (baseDir `appendGHCupPath` prettyShow tool) --- TODO rm -- | Gets '~/.ghcup/ghc/'. -- The dir may be of the form -- * armv7-unknown-linux-gnueabihf-8.8.3 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index e55f4654..75eaf1be 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -195,7 +195,7 @@ data ToolDescription = ToolDescription { , _toolLicense :: Maybe String , _toolContact :: Maybe String } - deriving (Eq, GHC.Generic, Show) + deriving (Eq, GHC.Generic, Show, Ord) instance NFData ToolDescription @@ -412,6 +412,7 @@ instance NFData DownloadInfo data InstallMetadata = InstallMetadata { _imDownloadInfo :: DownloadInfo , _imResolvedInstallSpec :: InstallationSpecResolved + , _imToolDescription :: Maybe ToolDescription } deriving (Eq, GHC.Generic, Ord, Show) @@ -728,6 +729,7 @@ data ChannelAlias | CrossChannel | PrereleasesChannel | VanillaChannel + | ThirdPartyChannel deriving (Bounded, Enum, Eq, GHC.Generic, Show) channelAliasText :: ChannelAlias -> Text @@ -736,6 +738,7 @@ channelAliasText StackChannel = "stack" channelAliasText CrossChannel = "cross" channelAliasText PrereleasesChannel = "prereleases" channelAliasText VanillaChannel = "vanilla" +channelAliasText ThirdPartyChannel = "3rdparty" fromURLSource :: URLSource -> [NewURLSource] fromURLSource GHCupURL = [NewGHCupURL] @@ -764,6 +767,11 @@ data MetaMode instance NFData MetaMode +newtype Verbosity = Verbosity Int + deriving (Eq, GHC.Generic, Show) + +instance NFData Verbosity + -- If you add, remove, or rename any fields, -- make sure to update the GHCup.OptParse.Reset module as well. data UserSettings = UserSettings @@ -771,7 +779,7 @@ data UserSettings = UserSettings , uMetaCache :: Maybe Integer , uMetaMode :: Maybe MetaMode , uNoVerify :: Maybe Bool - , uVerbose :: Maybe Int + , uVerbose :: Maybe Verbosity , uKeepDirs :: Maybe KeepDirs , uDownloader :: Maybe Downloader , uKeyBindings :: Maybe UserKeyBindings @@ -921,7 +929,7 @@ data Settings = Settings , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader - , verbose :: Int + , verbose :: Verbosity , urlSource :: [NewURLSource] , noNetwork :: Bool , gpgSetting :: GPGSetting @@ -962,7 +970,7 @@ defaultMetaCache :: Integer defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings -defaultSettings = Settings False defaultMetaCache Lax False Never Curl 0 [NewGHCupURL] False GPGNone False Nothing (DM mempty) [] defaultPagerConfig True Nothing +defaultSettings = Settings False defaultMetaCache Lax False Never Curl (Verbosity 0) [NewGHCupURL] False GPGNone False Nothing (DM mempty) [] defaultPagerConfig True Nothing instance NFData Settings diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index ac494996..bae67740 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -41,6 +41,7 @@ import Data.Aeson.Types hiding ( Key ) import Data.ByteString ( ByteString ) import Data.Foldable import Data.Maybe +import Data.Scientific (toBoundedInteger) import Data.Text.Encoding as E import Data.Versions import System.FilePath ( hasDrive, isAbsolute, splitPath ) @@ -443,7 +444,27 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = mapHead lower . drop 1 } ''ToolDescription -deriveJSON defaultOptions { fieldLabelModifier = mapHead lower . drop 3 } ''InstallMetadata + +instance FromJSON InstallMetadata where + parseJSON v = newParse v <|> legacyParse v + where + legacyParse o = do + v'@DownloadInfo{..} <- parseJSON o + case _dlInstallSpec of + Nothing -> fail "No install metadata in legacy parser" + Just InstallationSpec{..} -> do + isExeSymLinked' <- forM _isExeSymLinked toSymlSpec + pure $ InstallMetadata v' InstallationSpec{ _isExeSymLinked = isExeSymLinked', ..} Nothing + + toSymlSpec SymlinkInputSpec{..} = pure SymlinkSpec{..} + toSymlSpec _ = fail "Can't handle SymlinkPatternSpec in legacy parser" + + newParse = do + withObject "InstallMetadata" $ \o -> do + _imDownloadInfo <- o .: "downloadInfo" + _imResolvedInstallSpec <- o .: "resolvedInstallSpec" + _imToolDescription <- o .:? "toolDescription" + pure InstallMetadata{..} instance FromJSON ToolInfo where parseJSON v = newParse v <|> legacyParse v @@ -457,6 +478,7 @@ instance FromJSON ToolInfo where _toolDetails <- o .: "toolDetails" pure ToolInfo{..} +deriveToJSON defaultOptions { fieldLabelModifier = mapHead lower . drop 3 } ''InstallMetadata deriveToJSON defaultOptions { fieldLabelModifier = mapHead lower . drop 1 } ''ToolInfo instance FromJSON GHCupInfo where @@ -637,7 +659,16 @@ instance FromJSON PagerConfig where cmd <- o .:? "cmd" pure $ PagerConfig list cmd +instance FromJSON Verbosity where + parseJSON v = new v <|> legacy v + where + legacy = withBool "Verbosity" $ \b -> do + pure $ Verbosity (if b then 1 else 0) + new = withScientific "Verbosity" $ \s -> do + int <- maybe (fail "Verbosity integer out of bounds") pure $ toBoundedInteger s + pure $ Verbosity int +deriveToJSON defaultOptions { unwrapUnaryRecords = True } ''Verbosity deriveToJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "pager-") . T.pack . kebab $ str' } ''PagerConfig deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings diff --git a/lib/GHCup/Warnings.hs b/lib/GHCup/Warnings.hs new file mode 100644 index 00000000..aace7cc3 --- /dev/null +++ b/lib/GHCup/Warnings.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHCup.Warnings where + +import GHCup.Prelude +import GHCup.Types +import GHCup.Types.Optics + +import Control.Monad.Reader ( MonadReader ) +import Data.Versions ( Version ) +import Text.PrettyPrint.HughesPJClass ( prettyShow ) + +import qualified Data.Text as T + + +warnAboutHlsCompatibility :: + ( MonadReader env m + , HasLog env + , MonadIOish m + ) + => Maybe Version + -> Maybe Version + -> [Version] + -> m () +warnAboutHlsCompatibility currentHLS currentGHC supportedGHC = do + case (currentGHC, currentHLS) of + (Just gv, Just hv) | gv `notElem` supportedGHC -> do + logWarn $ + "GHC-" <> T.pack (prettyShow gv) <> " appears to have no corresponding HLS-" <> T.pack (prettyShow hv) <> " binary." <> "\n" <> + "Haskell IDE support may not work." <> "\n" <> + "You can try to either: " <> "\n" <> + " 1. Install a different HLS version (e.g. downgrade for older GHCs)" <> "\n" <> + " 2. Install and set one of the following GHCs: " <> T.pack (prettyShow supportedGHC) <> "\n" <> + " 3. Let GHCup compile HLS for you, e.g. run: ghcup compile hls -g " <> T.pack (prettyShow hv) <> " --ghc " <> T.pack (prettyShow gv) <> + " (see https://www.haskell.org/ghcup/guide/#hls for more information)" + + _ -> return () + diff --git a/scripts/bootstrap/bootstrap-haskell b/scripts/bootstrap/bootstrap-haskell index 5ea96f4a..f91b6e47 100755 --- a/scripts/bootstrap/bootstrap-haskell +++ b/scripts/bootstrap/bootstrap-haskell @@ -607,6 +607,43 @@ ask_cross_channel() { unset crosschannel_answer } +ask_thirdparty_channel() { + if [ -n "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then + return 0 + fi + while true; do + echo "-------------------------------------------------------------------------------" + + warn "" + warn "Do you also want to enable the 3rdparty channel, getting access to" + warn "to various non-core tools such as hlint, dhall and ormolu?" + warn "" + warn "[N] No [Y] Yes [?] Help (default is \"N\")." + warn "" + + read -r thirdparty_answer