diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for ghcup +## 0.1.50.0 -- 2025-03-23 + +* Fix logic when guessing incomplete PVP versions, fixes [#1243](https://github.com/haskell/ghcup-hs/pull/1243) +* Speed up metadata parsing significantly wrt [#1213](https://github.com/haskell/ghcup-hs/issues/1213) +* Implement "install targets", fixes [#1210](https://github.com/haskell/ghcup-hs/issues/1210) +* Add `default` channel alias wrt [#1196](https://github.com/haskell/ghcup-hs/pull/1196) +* Print post rm messages in TUI wrt [#1202](https://github.com/haskell/ghcup-hs/pull/1202) +* Print pre install messages in TUI wrt [#1241](https://github.com/haskell/ghcup-hs/issues/1241) +* Fix handling of 'ghc' subdir in parser for obtaining set ghc version wrt [#1215](https://github.com/haskell/ghcup-hs/issues/1215) + ## 0.1.40.0 -- 2025-01-01 ### New features diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,4 +15,5 @@ * [the metadata YAML files](https://github.com/haskell/ghcup-metadata) * [homepage and documentation](https://github.com/haskell/ghcup-www) * [docker images](https://github.com/haskell/ghcup-docker) +* [github action](https://github.com/haskell/ghcup-setup) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -98,6 +98,7 @@ pager = case fromMaybe (fromMaybe (Types.pager defaultSettings) uPager) (flip PagerConfig Nothing <$> optPager) of PagerConfig b Nothing -> PagerConfig b pagerCmd x -> x + guessVersion = fromMaybe (fromMaybe (Types.guessVersion defaultSettings) uGuessVersion) optGuessVersion in (Settings {..}, keyBindings) #if defined(INTERNAL_DOWNLOADER) defaultDownloader = Internal @@ -310,7 +311,7 @@ Install installCommand -> install installCommand settings appState runLogger InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger Test testCommand -> test testCommand settings appState runLogger - Set setCommand -> set setCommand runAppState runLeanAppState runLogger + Set setCommand -> set setCommand settings runAppState runLeanAppState runLogger UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger List lo -> list lo no_color (pager settings) runAppState Rm rmCommand -> rm rmCommand runAppState runLogger @@ -318,14 +319,14 @@ Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger Config configCommand -> config configCommand settings userConf keybindings runLogger Whereis whereisOptions - whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger + whereisCommand -> whereis whereisCommand whereisOptions settings runAppState leanAppstate runLogger Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger ToolRequirements topts -> toolRequirements topts runAppState runLogger ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger Nuke -> nuke appState runLogger - Prefetch pfCom -> prefetch pfCom runAppState runLogger + Prefetch pfCom -> prefetch pfCom settings runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger - Run runCommand -> run runCommand appState leanAppstate runLogger + Run runCommand -> run runCommand settings appState leanAppstate runLogger PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess case res of @@ -391,6 +392,6 @@ , NoToolVersionSet ] m Bool cmp' tool instVer ver = do - (v, _) <- liftE $ fromVersion instVer tool + (v, _) <- liftE $ fromVersion instVer GLax tool pure (v == ver) diff --git a/ghcup.cabal b/ghcup.cabal --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcup -version: 0.1.40.0 +version: 0.1.50.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2024 @@ -77,7 +77,19 @@ default: False manual: True +flag yaml-streamly + description: Use yaml-streamly instead of yaml (based on conduit) + default: False + manual: True + +common common-ghc-options + ghc-options: + -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates -Werror=incomplete-patterns + common app-common-depends + import: common-ghc-options + build-depends: , aeson >=1.4 , aeson-pretty ^>=0.8.8 @@ -85,8 +97,8 @@ , attoparsec ^>= 0.14 , base >=4.12 && <5 , bytestring >=0.10 && <0.13 - , containers ^>=0.6 - , deepseq ^>=1.4 || ^>=1.5 + , containers ^>=0.6 || ^>=0.7 + , deepseq ^>=1.4 || ^>=1.5 || ^>=1.6 , directory ^>=1.3.6.0 , filepath >=1.4.101.0 , variant ^>=1.0 @@ -102,17 +114,23 @@ , safe-exceptions ^>=0.1 , tagsoup ^>=0.14 , transformers ^>=0.5 || ^>=0.6 - , template-haskell >=2.7 && <2.23 + , template-haskell >=2.7 && <2.24 , temporary ^>=1.3 , text ^>=2.0 || ^>=2.1 - , time >=1.9.3 && <1.13 + , time >=1.9.3 && <1.15 , unordered-containers ^>=0.2 - , uri-bytestring ^>=0.3.2.2 + , uri-bytestring ^>=0.4.0.0 , utf8-string ^>=1.0 , vector >=0.12 && <0.14 , versions >=6.0.5 && <6.1 - , yaml ^>=0.11.0 + if flag(yaml-streamly) + build-depends: + yaml-streamly ^>=0.12.5 + else + build-depends: + yaml ^>=0.11.0 + if flag(tar) cpp-options: -DTAR build-depends: @@ -186,28 +204,24 @@ TypeFamilies ViewPatterns - ghc-options: - -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates - build-depends: , aeson >=1.4 , async >=0.8 && <2.3 , attoparsec ^>= 0.14 , base >=4.12 && <5 , base16-bytestring >=0.1.1.6 && <1.1 - , binary ^>=0.8.6.0 + , binary ^>=0.8.6.0 || ^>=0.9 || ^>=0.10 , bytestring >=0.10 && <0.13 , bz2 ^>=1.0.1.1 - , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 - , Cabal-syntax ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 + , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 || ^>= 3.14.0.0 + , Cabal-syntax ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 || ^>= 3.14.0.0 , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 - , containers ^>=0.6 + , containers ^>=0.6 || ^>=0.7 , conduit ^>=1.3 , conduit-extra ^>=1.3 , cryptohash-sha256 ^>=0.11.101.0 - , deepseq ^>=1.4.4.0 || ^>=1.5 + , deepseq ^>=1.4 || ^>=1.5 || ^>=1.6 , directory ^>=1.3.6.0 , disk-free-space ^>=0.1.0.1 , exceptions ^>=0.10 @@ -229,22 +243,28 @@ , safe-exceptions ^>=0.1 , split ^>=0.2.3.4 , strict-base ^>=0.4 - , template-haskell >=2.7 && <2.23 + , template-haskell >=2.7 && <2.24 , temporary ^>=1.3 , terminal-size ^>=0.3.3 , text ^>=2.0 || ^>=2.1 - , time >=1.9.3 && <1.13 + , time >=1.9.3 && <1.15 , transformers ^>=0.5 || ^>=0.6 , unliftio-core ^>=0.2.0.1 , unordered-containers ^>=0.2.10.0 - , uri-bytestring ^>=0.3.2.2 + , uri-bytestring ^>=0.4.0.0 , utf8-string ^>=1.0 , vector >=0.12 && <0.14 , versions >=6.0.5 && <6.1 , word8 ^>=0.1.3 - , yaml ^>=0.11.0 - , zlib ^>=0.6.2.2 + , zlib ^>=0.6.2.2 || ^>=0.7 + if flag(yaml-streamly) + build-depends: + yaml-streamly ^>=0.12.5 + else + build-depends: + yaml ^>=0.11.0 + if flag(tar) cpp-options: -DTAR build-depends: @@ -333,10 +353,6 @@ StrictData TupleSections - ghc-options: - -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates - build-depends: ghcup if flag(internal-downloader) @@ -382,13 +398,9 @@ StrictData TupleSections - ghc-options: - -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates - build-depends: , ghcup - , brick ^>=2.1 + , brick >=2.1 && <2.8 , vty ^>=6.0 || ^>=6.1 || ^>=6.2 if !flag(tui) @@ -417,8 +429,7 @@ TupleSections ghc-options: - -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates -threaded + -threaded build-depends: , ghcup @@ -442,6 +453,7 @@ buildable: False test-suite ghcup-test + import: common-ghc-options type: exitcode-stdio-1.0 main-is: Main.hs build-tool-depends: hspec-discover:hspec-discover -any @@ -451,6 +463,7 @@ GHCup.Prelude.File.Posix.TraversalsSpec GHCup.Types.JSONSpec GHCup.Utils.FileSpec + GHCup.ParserSpec Spec default-language: Haskell2010 @@ -463,25 +476,25 @@ TupleSections ghc-options: - -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates + -fconstraint-solver-iterations=0 build-depends: , base >=4.12 && <5 , bytestring >=0.10 && <0.13 - , containers ^>=0.6 + , containers ^>=0.6 || ^>=0.7 , conduit ^>=1.3 , directory ^>=1.3.6.0 , filepath >=1.4.101.0 - , generic-arbitrary ^>=0.1.0 || ^>=0.2.2 + , generic-arbitrary ^>=0.1.0 || ^>=0.2.2 || ^>=1.0.0 , ghcup , hspec >=2.7.10 && <2.12 , hspec-golden-aeson ^>=0.9 - , QuickCheck ^>=2.14.1 + , megaparsec >=8.0.0 && <9.8 + , QuickCheck ^>=2.14.1 || ^>=2.15 , quickcheck-arbitrary-adt ^>=0.3.1.0 , text ^>=2.0 || ^>=2.1 - , time >=1.9.3 && <1.13 - , uri-bytestring ^>=0.3.2.2 + , time >=1.9.3 && <1.15 + , uri-bytestring ^>=0.4.0.0 , versions >=6.0.5 && <6.1 if os(windows) @@ -491,6 +504,7 @@ build-depends: unix ^>=2.7 || ^>=2.8 test-suite ghcup-optparse-test + import: common-ghc-options type: exitcode-stdio-1.0 hs-source-dirs: test/optparse-test main-is: Main.hs @@ -514,7 +528,6 @@ cpp-options: -DIS_WINDOWS default-language: Haskell2010 - ghc-options: -Wall build-depends: , base , ghcup diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -89,6 +89,7 @@ , optGpg :: Maybe GPGSetting , optStackSetup :: Maybe Bool , optPager :: Maybe Bool + , optGuessVersion :: Maybe Bool -- commands , optCommand :: Command } @@ -143,7 +144,7 @@ (eitherReader parseUrlSource) ( short 's' <> long "url-source" - <> metavar "" + <> metavar "" <> help "Alternative ghcup download info" <> internal <> completer urlSourceCompleter @@ -186,6 +187,7 @@ )) <*> invertableSwitch "stack-setup" Nothing False (help "Use stack's setup info for discovering and installing GHC versions") <*> (invertableSwitch "paginate" Nothing False (help "Send output (e.g. from 'ghcup list') through pager (default: disabled)")) + <*> invertableSwitch "guess-version" Nothing True (help "Whether to guess the full version from an incomplete tool version, e.g. GHC '9.12' resolving to '9.12.2'") <*> com diff --git a/lib-opt/GHCup/OptParse/Compile.hs b/lib-opt/GHCup/OptParse/Compile.hs --- a/lib-opt/GHCup/OptParse/Compile.hs +++ b/lib-opt/GHCup/OptParse/Compile.hs @@ -81,6 +81,7 @@ , buildFlavour :: Maybe String , buildSystem :: Maybe BuildSystem , isolateDir :: Maybe FilePath + , installTargets :: T.Text } deriving (Eq, Show) @@ -166,7 +167,7 @@ ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = - (\targetGhc bootstrapGhc hadrianGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir -> GHCCompileOptions {..}) + (\targetGhc bootstrapGhc hadrianGhc jobs patches crossTarget addConfArgs setCompile overwriteVer buildFlavour (buildSystem, buildConfig) isolateDir installTargets -> GHCCompileOptions {..}) <$> ((GHC.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) @@ -315,6 +316,13 @@ <> completer (bashCompleter "directory") ) ) + <*> strOption + ( long "install-targets" + <> metavar "TARGETS" + <> help "Space separated list of install targets (default: install)" + <> completer (listCompleter ["install", "install_bin", "install_lib", "install_extra", "install_man", "install_docs", "install_data", "update_package_db"]) + <> value "install" + ) hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts = @@ -479,6 +487,7 @@ , BuildFailed , UninstallFailed , MergeFileTreeError + , URIParseError ] type HLSEffects = '[ AlreadyInstalled , BuildFailed @@ -501,6 +510,7 @@ , ArchiveResult , UninstallFailed , MergeFileTreeError + , URIParseError ] @@ -563,7 +573,7 @@ "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene _ -> pure () - ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) + ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) guessMode $ GHC) targetVer <- liftE $ compileHLS targetHLS ghcs @@ -630,6 +640,7 @@ buildFlavour buildSystem (maybe GHCupInternal IsolateDir isolateDir) + installTargets GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer GHC dls when setCompile $ void $ liftE $ @@ -663,3 +674,6 @@ VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e pure $ ExitFailure 9 + where + guessMode = if guessVersion settings then GLaxWithInstalled else GStrict + diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -147,7 +147,8 @@ mirrors' = uMirrors usl <|> uMirrors usr defGHCconfOptions' = uDefGHCConfOptions usl <|> uDefGHCConfOptions usr pagerConfig' = uPager usl <|> uPager usr - in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions' pagerConfig' + guessVersion' = uGuessVersion usl <|> uGuessVersion usr + in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' defGHCconfOptions' pagerConfig' guessVersion' where updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings updateKeyBindings Nothing Nothing = Nothing diff --git a/lib-opt/GHCup/OptParse/DInfo.hs b/lib-opt/GHCup/OptParse/DInfo.hs --- a/lib-opt/GHCup/OptParse/DInfo.hs +++ b/lib-opt/GHCup/OptParse/DInfo.hs @@ -29,11 +29,14 @@ import Control.Monad.Trans.Resource import Data.Functor import Data.Maybe +import Data.List ( intercalate ) import Data.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) import System.Exit +import System.FilePath import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString (serializeURIRef') import qualified Data.Text as T import Control.Exception.Safe (MonadMask) @@ -63,15 +66,34 @@ prettyDebugInfo :: DebugInfo -> String -prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <> - "==========" <> "\n" <> - "GHCup base dir: " <> diBaseDir <> "\n" <> - "GHCup bin dir: " <> diBinDir <> "\n" <> - "GHCup GHC directory: " <> diGHCDir <> "\n" <> - "GHCup cache directory: " <> diCacheDir <> "\n" <> - "Architecture: " <> prettyShow diArch <> "\n" <> - "Platform: " <> prettyShow diPlatform <> "\n" <> - "Version: " <> describe_result +prettyDebugInfo DebugInfo { diDirs = Dirs { .. }, ..} = + "===== Main ======" <> "\n" <> + "Architecture: " <> prettyShow diArch <> "\n" <> + "Platform: " <> prettyShow diPlatform <> "\n" <> + "GHCup Version: " <> describe_result <> "\n" <> + "===== Directories ======" <> "\n" <> + "base: " <> fromGHCupPath baseDir <> "\n" <> + "bin: " <> binDir <> "\n" <> + "GHCs: " <> (fromGHCupPath baseDir "ghc") <> "\n" <> + "cache: " <> fromGHCupPath cacheDir <> "\n" <> + "logs: " <> fromGHCupPath logsDir <> "\n" <> + "config: " <> fromGHCupPath confDir <> "\n" <> + "db: " <> fromGHCupPath dbDir <> "\n" <> + whenWin ("recycle: " <> fromGHCupPath recycleDir <> "\n") <> + "temp: " <> fromGHCupPath tmpDir <> "\n" <> + whenWin ("msys2: " <> msys2Dir <> "\n") <> + "\n===== Metadata ======\n" <> + intercalate "\n" ((\(c, u) -> pad (c <> ":") <> " " <> u) <$> channels) + where + pad xs + | xl < maxLength = xs <> replicate (maxLength - xl) ' ' + | otherwise = xs + where + xl = length xs + channels = (\(c, u) -> (T.unpack . channelAliasText $ c, T.unpack . decUTF8Safe . serializeURIRef'$ u)) <$> diChannels + maxLength = (+1) . maximum . fmap (length . fst) $ channels + whenWin x = if isWindows then x else mempty + diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -71,6 +71,7 @@ , instSet :: Bool , isolateDir :: Maybe FilePath , forceInstall :: Bool + , installTargets :: T.Text , addConfArgs :: [T.Text] } deriving (Eq, Show) @@ -207,6 +208,13 @@ ) <*> switch (short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)") + <*> strOption + ( long "install-targets" + <> metavar "TARGETS" + <> help "Space separated list of install targets (default: install)" + <> completer (listCompleter ["install", "install_bin", "install_lib", "install_extra", "install_man", "install_docs", "install_data", "update_package_db"]) + <> value "install" + ) <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)")) where setDefault = case tool of @@ -259,6 +267,7 @@ , UninstallFailed , MergeFileTreeError , InstallSetError + , URIParseError ] @@ -300,6 +309,7 @@ , UnsupportedSetupCombo , DistroNotFound , NoCompatibleArch + , URIParseError ] runInstGHC :: AppState @@ -327,12 +337,13 @@ (Left (InstallHLS iopts)) -> installHLS iopts (Left (InstallStack iopts)) -> installStack iopts where + guessMode = if guessVersion settings then GLax else GStrict installGHC :: InstallOptions -> IO ExitCode installGHC InstallOptions{..} = do s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstGHC s' $ do - (v, vi) <- liftE $ fromVersion instVer GHC + (v, vi) <- liftE $ fromVersion instVer guessMode GHC forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn @@ -343,23 +354,25 @@ (maybe GHCupInternal IsolateDir isolateDir) forceInstall addConfArgs + installTargets ) $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing pure vi Just uri -> do runInstGHC s'{ settings = settings {noVerify = True}} $ do - (v, vi) <- liftE $ fromVersion instVer GHC + (v, vi) <- liftE $ fromVersion instVer guessMode GHC forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene liftE $ runBothE' (installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing Nothing) + (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (Just $ RegexDir "ghc-.*") "" Nothing Nothing Nothing) v (maybe GHCupInternal IsolateDir isolateDir) forceInstall addConfArgs + installTargets ) $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing pure vi @@ -414,7 +427,7 @@ s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstTool s' $ do - (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal + (_tvVersion -> v, vi) <- liftE $ fromVersion instVer guessMode Cabal forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn @@ -428,14 +441,14 @@ pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} $ do - (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal + (_tvVersion -> v, vi) <- liftE $ fromVersion instVer guessMode Cabal forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene liftE $ runBothE' (installCabalBindist - (DownloadInfo uri Nothing "" Nothing Nothing Nothing) + (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) Nothing "" Nothing Nothing Nothing) v (maybe GHCupInternal IsolateDir isolateDir) forceInstall @@ -473,7 +486,7 @@ s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstTool s' $ do - (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS + (_tvVersion -> v, vi) <- liftE $ fromVersion instVer guessMode HLS forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn @@ -487,7 +500,7 @@ pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} $ do - (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS + (_tvVersion -> v, vi) <- liftE $ fromVersion instVer guessMode HLS forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn @@ -495,7 +508,7 @@ liftIO $ threadDelay 5000000 -- give the user a sec to intervene -- TODO: support legacy liftE $ runBothE' (installHLSBindist - (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing Nothing) + (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing Nothing) v (maybe GHCupInternal IsolateDir isolateDir) forceInstall @@ -533,7 +546,7 @@ s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of Nothing -> runInstTool s' $ do - (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack + (_tvVersion -> v, vi) <- liftE $ fromVersion instVer guessMode Stack forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn @@ -547,14 +560,14 @@ pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} $ do - (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack + (_tvVersion -> v, vi) <- liftE $ fromVersion instVer guessMode Stack forM_ (_viPreInstall =<< vi) $ \msg -> do lift $ logWarn msg lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene liftE $ runBothE' (installStackBindist - (DownloadInfo uri Nothing "" Nothing Nothing Nothing) + (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) Nothing "" Nothing Nothing Nothing) v (maybe GHCupInternal IsolateDir isolateDir) forceInstall diff --git a/lib-opt/GHCup/OptParse/Prefetch.hs b/lib-opt/GHCup/OptParse/Prefetch.hs --- a/lib-opt/GHCup/OptParse/Prefetch.hs +++ b/lib-opt/GHCup/OptParse/Prefetch.hs @@ -162,6 +162,7 @@ , JSONError , FileDoesNotExistError , StackPlatformDetectError + , URIParseError ] @@ -189,30 +190,31 @@ , MonadFail m ) => PrefetchCommand + -> Settings -> (forall a. ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -prefetch prefetchCommand runAppState runLogger = +prefetch prefetchCommand settings runAppState runLogger = runPrefetch runAppState (do case prefetchCommand of PrefetchGHC (PrefetchGHCOptions pfGHCSrc pfCacheDir) mt -> do forM_ pfCacheDir (liftIO . createDirRecursive') - (v, _) <- liftE $ fromVersion mt GHC + (v, _) <- liftE $ fromVersion mt guessMode GHC if pfGHCSrc then liftE $ fetchGHCSrc v pfCacheDir else liftE $ fetchToolBindist v GHC pfCacheDir PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do forM_ pfCacheDir (liftIO . createDirRecursive') - (v, _) <- liftE $ fromVersion mt Cabal + (v, _) <- liftE $ fromVersion mt guessMode Cabal liftE $ fetchToolBindist v Cabal pfCacheDir PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do forM_ pfCacheDir (liftIO . createDirRecursive') - (v, _) <- liftE $ fromVersion mt HLS + (v, _) <- liftE $ fromVersion mt guessMode HLS liftE $ fetchToolBindist v HLS pfCacheDir PrefetchStack PrefetchOptions {pfCacheDir} mt -> do forM_ pfCacheDir (liftIO . createDirRecursive') - (v, _) <- liftE $ fromVersion mt Stack + (v, _) <- liftE $ fromVersion mt guessMode Stack liftE $ fetchToolBindist v Stack pfCacheDir PrefetchMetadata -> do pfreq <- lift getPlatformReq @@ -224,3 +226,6 @@ VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e pure $ ExitFailure 15 + + where + guessMode = if guessVersion settings then GLaxWithInstalled else GStrict diff --git a/lib-opt/GHCup/OptParse/Rm.hs b/lib-opt/GHCup/OptParse/Rm.hs --- a/lib-opt/GHCup/OptParse/Rm.hs +++ b/lib-opt/GHCup/OptParse/Rm.hs @@ -35,6 +35,7 @@ import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) import System.Exit +import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) @@ -176,8 +177,8 @@ ) >>= \case VRight vi -> do + postRmLog (tVerToText ghcVer) GHC vi runLogger $ logGHCPostRm ghcVer - postRmLog vi pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e @@ -192,7 +193,7 @@ ) >>= \case VRight vi -> do - postRmLog vi + postRmLog (prettyVer tv) Cabal vi pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e @@ -207,7 +208,7 @@ ) >>= \case VRight vi -> do - postRmLog vi + postRmLog (prettyVer tv) HLS vi pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e @@ -222,12 +223,12 @@ ) >>= \case VRight vi -> do - postRmLog vi + postRmLog (prettyVer tv) Stack vi pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e pure $ ExitFailure 15 - postRmLog vi = - forM_ (_viPostRemove =<< vi) $ \msg -> - runLogger $ logInfo msg + postRmLog tv tool vi = runLogger $ do + logInfo $ "Successfuly removed " <> T.pack (prettyShow tool) <> " " <> tv + forM_ (_viPostRemove =<< vi) logInfo diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -193,6 +193,7 @@ , UnsupportedSetupCombo , DistroNotFound , NoCompatibleArch + , URIParseError ] runLeanRUN :: (MonadUnliftIO m, MonadIO m) @@ -235,11 +236,12 @@ , Alternative m ) => RunOptions + -> Settings -> IO AppState -> LeanAppState -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -run RunOptions{..} runAppState leanAppstate runLogger = do +run RunOptions{..} settings runAppState leanAppstate runLogger = do r <- if not runQuick then runRUN runAppState $ do toolchain <- liftE resolveToolchainFull @@ -285,6 +287,8 @@ where + guessMode = if guessVersion settings then GLaxWithInstalled else GStrict + -- TODO: doesn't work for cross resolveToolchainFull :: ( MonadFail m , MonadThrow m @@ -299,16 +303,16 @@ ] (ResourceT (ReaderT AppState m)) Toolchain resolveToolchainFull = do ghcVer <- forM runGHCVer $ \ver -> do - (v, _) <- liftE $ fromVersion (Just ver) GHC + (v, _) <- liftE $ fromVersion (Just ver) guessMode GHC pure v cabalVer <- forM runCabalVer $ \ver -> do - (v, _) <- liftE $ fromVersion (Just ver) Cabal + (v, _) <- liftE $ fromVersion (Just ver) guessMode Cabal pure (_tvVersion v) hlsVer <- forM runHLSVer $ \ver -> do - (v, _) <- liftE $ fromVersion (Just ver) HLS + (v, _) <- liftE $ fromVersion (Just ver) guessMode HLS pure (_tvVersion v) stackVer <- forM runStackVer $ \ver -> do - (v, _) <- liftE $ fromVersion (Just ver) Stack + (v, _) <- liftE $ fromVersion (Just ver) guessMode Stack pure (_tvVersion v) pure Toolchain{..} @@ -370,6 +374,7 @@ , UnsupportedSetupCombo , DistroNotFound , NoCompatibleArch + , URIParseError ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do case ghcVer of @@ -380,6 +385,7 @@ GHCupInternal False [] + (T.pack "install") setGHC' v tmp _ -> pure () case cabalVer of diff --git a/lib-opt/GHCup/OptParse/Set.hs b/lib-opt/GHCup/OptParse/Set.hs --- a/lib-opt/GHCup/OptParse/Set.hs +++ b/lib-opt/GHCup/OptParse/Set.hs @@ -259,13 +259,14 @@ , HasLog env ) => Either SetCommand SetOptions + -> Settings -> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion) -> m (VEither eff GHCTargetVersion)) -> (forall eff. ReaderT env m (VEither eff GHCTargetVersion) -> m (VEither eff GHCTargetVersion)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -set setCommand runAppState _ runLogger = case setCommand of +set setCommand settings runAppState _ runLogger = case setCommand of (Right sopts) -> do runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") setGHC' sopts @@ -275,10 +276,12 @@ (Left (SetStack sopts)) -> setStack' sopts where + guessMode = if guessVersion settings then GLaxWithInstalled else GStrict + setGHC' :: SetOptions -> m ExitCode setGHC' SetOptions{ sToolVer } = runSetGHC runAppState (do - v <- liftE $ fst <$> fromVersion' sToolVer GHC + v <- liftE $ fst <$> fromVersion' sToolVer guessMode GHC liftE $ setGHC v SetGHCOnly Nothing ) >>= \case @@ -295,7 +298,7 @@ setCabal' :: SetOptions -> m ExitCode setCabal' SetOptions{ sToolVer } = runSetCabal runAppState (do - v <- liftE $ fst <$> fromVersion' sToolVer Cabal + v <- liftE $ fst <$> fromVersion' sToolVer guessMode Cabal liftE $ setCabal (_tvVersion v) pure v ) @@ -312,7 +315,7 @@ setHLS' :: SetOptions -> m ExitCode setHLS' SetOptions{ sToolVer } = runSetHLS runAppState (do - v <- liftE $ fst <$> fromVersion' sToolVer HLS + v <- liftE $ fst <$> fromVersion' sToolVer guessMode HLS liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing pure v ) @@ -330,7 +333,7 @@ setStack' :: SetOptions -> m ExitCode setStack' SetOptions{ sToolVer } = runSetStack runAppState (do - v <- liftE $ fst <$> fromVersion' sToolVer Stack + v <- liftE $ fst <$> fromVersion' sToolVer guessMode Stack liftE $ setStack (_tvVersion v) pure v ) diff --git a/lib-opt/GHCup/OptParse/Test.hs b/lib-opt/GHCup/OptParse/Test.hs --- a/lib-opt/GHCup/OptParse/Test.hs +++ b/lib-opt/GHCup/OptParse/Test.hs @@ -21,6 +21,7 @@ import GHCup.Types import GHCup.Utils.Dirs import GHCup.Utils.Parsers (fromVersion, uriParser) +import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ @@ -142,6 +143,7 @@ , TagNotFound , DayNotFound , NoToolVersionSet + , URIParseError ] runTestGHC :: AppState @@ -163,18 +165,20 @@ test testCommand settings getAppState' runLogger = case testCommand of (TestGHC iopts) -> go iopts where + guessMode = if guessVersion settings then GLaxWithInstalled else GStrict + go :: TestOptions -> IO ExitCode go TestOptions{..} = do s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case testBindist of Nothing -> runTestGHC s' $ do - (v, vi) <- liftE $ fromVersion testVer GHC + (v, vi) <- liftE $ fromVersion testVer guessMode GHC liftE $ testGHCVer v addMakeArgs pure vi Just uri -> do runTestGHC s'{ settings = settings {noVerify = True}} $ do - (v, vi) <- liftE $ fromVersion testVer GHC - liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing Nothing) v addMakeArgs + (v, vi) <- liftE $ fromVersion testVer guessMode GHC + liftE $ testGHCBindist (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (Just $ RegexDir ".*/.*") "" Nothing Nothing Nothing) v addMakeArgs pure vi ) >>= \case diff --git a/lib-opt/GHCup/OptParse/Upgrade.hs b/lib-opt/GHCup/OptParse/Upgrade.hs --- a/lib-opt/GHCup/OptParse/Upgrade.hs +++ b/lib-opt/GHCup/OptParse/Upgrade.hs @@ -97,6 +97,7 @@ , CopyError , DownloadFailed , ToolShadowed + , URIParseError ] diff --git a/lib-opt/GHCup/OptParse/Whereis.hs b/lib-opt/GHCup/OptParse/Whereis.hs --- a/lib-opt/GHCup/OptParse/Whereis.hs +++ b/lib-opt/GHCup/OptParse/Whereis.hs @@ -264,11 +264,12 @@ ) => WhereisCommand -> WhereisOptions + -> Settings -> (forall a. ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a)) -> LeanAppState -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do +whereis whereisCommand whereisOptions settings runAppState leanAppstate runLogger = do Dirs{ .. } <- runReaderT getDirs leanAppstate case (whereisCommand, whereisOptions) of (WhereisTool GHCup _, WhereisOptions{..}) -> do @@ -309,7 +310,7 @@ (WhereisTool tool whereVer, WhereisOptions{..}) -> do runWhereIs runAppState (do - (v, _) <- liftE $ fromVersion whereVer tool + (v, _) <- liftE $ fromVersion whereVer guessMode tool loc <- liftE $ whereIsTool tool v if directory then pure $ takeDirectory loc @@ -342,3 +343,5 @@ (WhereisConfDir, _) -> do liftIO $ putStr $ fromGHCupPath confDir pure ExitSuccess + where + guessMode = if guessVersion settings then GLaxWithInstalled else GStrict diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -193,6 +193,7 @@ shouldForce = opts ^. AdvanceInstall.forceInstallL shouldSet = opts ^. AdvanceInstall.instSetL extraArgs = opts ^. AdvanceInstall.addConfArgsL + installTargets = opts ^. AdvanceInstall.installTargetsL v = fromMaybe (GHCTargetVersion lCross lVer) (opts ^. AdvanceInstall.instVersionL) toolV = _tvVersion v let run = @@ -225,6 +226,7 @@ , DistroNotFound , NoCompatibleArch , InstallSetError + , URIParseError ] withNoVerify :: (MonadReader AppState m) => m a -> m a @@ -237,27 +239,39 @@ case lTool of GHC -> do let vi = getVersionInfo v GHC dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene case opts ^. AdvanceInstall.instBindistL of Nothing -> do liftE $ runBothE' - (installGHCBin v shouldIsolate shouldForce extraArgs) + (installGHCBin v shouldIsolate shouldForce extraArgs installTargets) (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing)) pure (vi, dirs, ce) Just uri -> do liftE $ runBothE' (withNoVerify $ installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing Nothing) + (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (Just $ RegexDir "ghc-.*") "" Nothing Nothing Nothing) v shouldIsolate shouldForce - extraArgs) + extraArgs + installTargets + ) (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing)) pure (vi, dirs, ce) Cabal -> do let vi = getVersionInfo v Cabal dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene case opts ^. AdvanceInstall.instBindistL of Nothing -> do liftE $ @@ -268,15 +282,25 @@ Just uri -> do liftE $ runBothE' - (withNoVerify $ installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) + (withNoVerify $ installCabalBindist (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) Nothing "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal toolV)) pure (vi, dirs, ce) GHCup -> do let vi = snd <$> getLatest dls GHCup + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) HLS -> do let vi = getVersionInfo v HLS dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene case opts ^. AdvanceInstall.instBindistL of Nothing -> do liftE $ @@ -288,7 +312,7 @@ liftE $ runBothE' (withNoVerify $ installHLSBindist - (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing Nothing) + (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) @@ -307,7 +331,7 @@ Just uri -> do liftE $ runBothE' - (withNoVerify $ installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) + (withNoVerify $ installStackBindist (DownloadInfo ((decUTF8Safe . serializeURIRef') uri) Nothing "" Nothing Nothing Nothing) toolV shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setStack toolV)) pure (vi, dirs, ce) @@ -339,7 +363,7 @@ install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => (Int, ListResult) -> m (Either String ()) -install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing Nothing False []) +install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing Nothing False [] "install") set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => (Int, ListResult) @@ -377,6 +401,7 @@ , UnsupportedSetupCombo , DistroNotFound , NoCompatibleArch + , URIParseError ] run (do @@ -433,9 +458,9 @@ let run = runE @'[NotInstalled, UninstallFailed] run (do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls + let vi = getVersionInfo crossVer lTool dls case lTool of - GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi + GHC -> liftE $ rmGHCVer crossVer $> vi Cabal -> liftE $ rmCabalVer lVer $> vi HLS -> liftE $ rmHLSVer lVer $> vi Stack -> liftE $ rmStackVer lVer $> vi @@ -443,11 +468,14 @@ ) >>= \case VRight vi -> do - when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) + when (lTool == GHC) $ logGHCPostRm crossVer + logInfo $ "Successfuly removed " <> T.pack (prettyShow lTool) <> " " <> (if lTool == GHC then tVerToText crossVer else prettyVer lVer) forM_ (_viPostRemove =<< vi) $ \msg -> logInfo msg pure $ Right () VLeft e -> pure $ Left (prettyHFError e) + where + crossVer = GHCTargetVersion lCross lVer changelog' :: (MonadReader AppState m, MonadIO m) @@ -463,6 +491,7 @@ Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + OpenBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing Windows -> do let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri) c <- liftIO $ system $ args @@ -503,6 +532,7 @@ , BuildFailed , UninstallFailed , MergeFileTreeError + , URIParseError ] compileResult <- run (do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask @@ -511,6 +541,11 @@ Nothing -> do -- Compile the version user is pointing to in the tui let vi = getVersionInfo (mkTVer lVer) GHC dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene forM_ (_viPreCompile =<< vi) $ \msg -> do logInfo msg logInfo @@ -531,6 +566,7 @@ (compopts ^. CompileGHC.buildFlavour) (compopts ^. CompileGHC.buildSystem) (maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir) + (compopts ^. CompileGHC.installTargets) AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask let vi2 = getVersionInfo targetVer GHC dls2 when @@ -592,6 +628,7 @@ , ArchiveResult , UninstallFailed , MergeFileTreeError + , URIParseError ] compileResult <- run (do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask @@ -600,6 +637,11 @@ Nothing -> do -- Compile the version user is pointing to in the tui let vi = getVersionInfo (mkTVer lVer) HLS dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene forM_ (_viPreCompile =<< vi) $ \msg -> do logInfo msg logInfo @@ -609,7 +651,7 @@ ghcs <- liftE $ forM (compopts ^. CompileHLS.targetGHCs) - (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) $ GHC) + (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) GStrict $ GHC) targetVer <- liftE $ GHCup.compileHLS hlsVer ghcs diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -48,7 +48,7 @@ , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton , CompileGHCButton, CompileHLSButton, CabalProjectEditBox , CabalProjectLocalEditBox, UpdateCabalCheckBox, GitRefEditBox - , BootstrapGhcSelectBox, HadrianGhcSelectBox, ToolVersionBox + , BootstrapGhcSelectBox, HadrianGhcSelectBox, ToolVersionBox, GHCInstallTargets ) ) where import GHCup.List ( ListResult ) @@ -135,6 +135,9 @@ pattern ToolVersionBox :: ResourceId pattern ToolVersionBox = ResourceId 23 + +pattern GHCInstallTargets :: ResourceId +pattern GHCInstallTargets = ResourceId 24 -- | Name data type. Uniquely identifies each widget in the TUI. -- some constructors might end up unused, but still is a good practise diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -248,8 +248,8 @@ type EditableField = MenuField -createEditableInput :: (Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> FieldInput a (EditState n) n -createEditableInput name validator = FieldInput initEdit validateEditContent "" drawEdit handler +createEditableInput :: (Ord n, Show n) => T.Text -> n -> (T.Text -> Either ErrorMessage a) -> FieldInput a (EditState n) n +createEditableInput initText name validator = FieldInput initEdit validateEditContent "" drawEdit handler where drawEdit focus errMsg help label (EditState edi overlayOpen) amp = (field, mOverlay) where @@ -258,6 +258,8 @@ borderBox w = amp (Brick.vLimit 1 $ Border.vBorder <+> Brick.padRight Brick.Max w <+> Border.vBorder) editorContents = Brick.txt $ T.unlines $ Edit.getEditContents edi isEditorEmpty = Edit.getEditContents edi == [mempty] + || Edit.getEditContents edi == [initText] + in case errMsg of Valid | isEditorEmpty -> borderBox $ renderAsHelpMsg help | otherwise -> borderBox editorContents @@ -287,12 +289,15 @@ VtyEvent (Vty.EvKey Vty.KEnter []) -> editStateOverlayOpenL .= True _ -> pure () validateEditContent = validator . T.init . T.unlines . Edit.getEditContents . editState - initEdit = EditState (Edit.editorText name (Just 1) "") False + initEdit = EditState (Edit.editorText name (Just 1) initText) False -createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n -createEditableField name validator access = MenuField access input "" Valid name +createEditableField' :: (Eq n, Ord n, Show n) => T.Text -> n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n +createEditableField' initText name validator access = MenuField access input "" Valid name where - input = createEditableInput name validator + input = createEditableInput initText name validator + +createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n +createEditableField = createEditableField' "" {- ***************** Button widget diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -26,6 +26,7 @@ isolateDirL, forceInstallL, addConfArgsL, + installTargetsL, ) where import GHCup.Types (GHCTargetVersion(..)) @@ -55,6 +56,7 @@ , isolateDir :: Maybe FilePath , forceInstall :: Bool , addConfArgs :: [T.Text] + , installTargets :: T.Text } deriving (Eq, Show) makeLensesFor [ @@ -64,6 +66,7 @@ , ("isolateDir", "isolateDirL") , ("forceInstall", "forceInstallL") , ("addConfArgs", "addConfArgsL") + , ("installTargets", "installTargetsL") ] ''InstallOptions @@ -72,7 +75,8 @@ create :: MenuKeyBindings -> AdvanceInstallMenu create k = Menu.createMenu AdvanceInstallBox initialState "Advance Install" validator k [ok] fields where - initialState = InstallOptions Nothing False Nothing Nothing False [] + initialInstallTargets = "install" + initialState = InstallOptions Nothing False Nothing Nothing False [] initialInstallTargets validator InstallOptions {..} = case (instSet, isolateDir) of (True, Just _) -> Just "Cannot set active when doing an isolated install" _ -> Nothing @@ -105,6 +109,9 @@ , Menu.createEditableField (Common.MenuElement Common.ToolVersionBox) toolVersionValidator instVersionL & Menu.fieldLabelL .~ "version" & Menu.fieldHelpMsgL .~ "Specify a custom version" + , Menu.createEditableField' initialInstallTargets (Common.MenuElement Common.GHCInstallTargets) Right installTargetsL + & Menu.fieldLabelL .~ "install-targets" + & Menu.fieldHelpMsgL .~ "Specify space separated list of make install targets" , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathValidator isolateDirL & Menu.fieldLabelL .~ "isolated" & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -33,6 +33,7 @@ buildSystem, isolateDir, gitRef, + installTargets, ) where import GHCup.Brick.Widgets.Menu (Menu, MenuKeyBindings) @@ -77,6 +78,7 @@ , _buildSystem :: Maybe BuildSystem , _isolateDir :: Maybe FilePath , _gitRef :: Maybe String + , _installTargets :: T.Text } deriving (Eq, Show) makeLenses ''CompileGHCOptions @@ -86,6 +88,7 @@ create :: MenuKeyBindings -> [Version] -> CompileGHCMenu create k availableGHCs = Menu.createMenu CompileGHCBox initialState "Compile GHC" validator k buttons fields where + initialInstallTargets = "install" initialState = CompileGHCOptions (Right "") @@ -101,6 +104,7 @@ Nothing Nothing Nothing + initialInstallTargets validator CompileGHCOptions {..} = case (_setCompile, _isolateDir) of (True, Just _) -> Just "Cannot set active when doing an isolated install" _ -> case (_buildConfig, _buildSystem) of @@ -223,6 +227,9 @@ , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef & Menu.fieldLabelL .~ "git-ref" & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from" + , Menu.createEditableField' initialInstallTargets (Common.MenuElement Common.GHCInstallTargets) Right installTargets + & Menu.fieldLabelL .~ "install-targets" + & Menu.fieldHelpMsgL .~ "Specify space separated list of make install targets" ] buttons = [ diff --git a/lib/GHCup.hs b/lib/GHCup.hs --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -109,6 +109,7 @@ , GPGError , DownloadFailed , NoDownload + , URIParseError ] m FilePath @@ -258,11 +259,9 @@ m DebugInfo getDebugInfo = do - Dirs {..} <- lift getDirs - let diBaseDir = fromGHCupPath baseDir - let diBinDir = binDir - diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir - let diCacheDir = fromGHCupPath cacheDir + diDirs <- lift getDirs + let diChannels = fmap (\c -> (c, channelURL c)) [minBound..maxBound] + let diShimGenURL = shimGenURL diArch <- lE getArchitecture diPlatform <- liftE getPlatform pure $ DebugInfo { .. } @@ -304,6 +303,7 @@ , NoDownload , NoUpdate , ToolShadowed + , URIParseError ] m Version @@ -344,6 +344,7 @@ , NoDownload , NoUpdate , ToolShadowed + , URIParseError ] m Version @@ -355,7 +356,8 @@ dli <- liftE $ getDownloadInfo GHCup latestVer tmp <- fromGHCupPath <$> lift withGHCupTmpDir let fn = "ghcup" <> exeExt - p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) tmp (Just fn) False + dlu <- lE $ parseURI' (_dlUri dli) + p <- liftE $ download dlu Nothing (Just (_dlHash dli)) (_dlCSize dli) tmp (Just fn) False let destDir = takeDirectory destFile destFile = fromMaybe (binDir fn) mtarget lift $ logDebug $ "mkdir -p " <> T.pack destDir diff --git a/lib/GHCup/Cabal.hs b/lib/GHCup/Cabal.hs --- a/lib/GHCup/Cabal.hs +++ b/lib/GHCup/Cabal.hs @@ -89,6 +89,7 @@ , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError + , URIParseError ] m () @@ -193,6 +194,7 @@ , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError + , URIParseError ] m () diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -153,6 +153,7 @@ m (Either GHCupInfo Stack.SetupInfo) dl' NewGHCupURL = fmap Left $ liftE (getBase ghcupURL) >>= liftE . decodeMetadata @GHCupInfo dl' NewStackSetupURL = fmap Right $ liftE (getBase stackSetupURL) >>= liftE . decodeMetadata @Stack.SetupInfo + dl' (NewChannelAlias StackChannel) = fmap Right $ liftE (getBase $ channelURL StackChannel) >>= liftE . decodeMetadata @Stack.SetupInfo dl' (NewChannelAlias c) = fmap Left $ liftE (getBase $ channelURL c) >>= liftE . decodeMetadata @GHCupInfo dl' (NewGHCupInfo gi) = pure (Left gi) dl' (NewSetupInfo si) = pure (Right si) @@ -181,9 +182,8 @@ fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do - url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI . E.encodeUtf8 $ downloadInfoUrl - sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256 - pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing Nothing + sha256 <- maybe (throwM $ DigestMissing downloadInfoUrl) (pure . E.decodeUtf8) downloadInfoSha256 + pure $ DownloadInfo downloadInfoUrl (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing Nothing mergeGhcupInfo :: MonadFail m @@ -741,14 +741,15 @@ ) => DownloadInfo -> Maybe FilePath -- ^ optional filename - -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath + -> Excepts '[URIParseError, DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath downloadCached dli mfn = do Settings{ cache } <- lift getSettings case cache of True -> downloadCached' dli mfn Nothing False -> do + dlu <- lE $ parseURI' (_dlUri dli) tmp <- lift withGHCupTmpDir - liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False + liftE $ download dlu Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False where outputFileName = mfn <|> _dlOutput dli @@ -765,11 +766,12 @@ => DownloadInfo -> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional destination dir (default: cacheDir) - -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath + -> Excepts '[URIParseError, DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath downloadCached' dli mfn mDestDir = do Dirs { cacheDir } <- lift getDirs + dlu <- lE $ parseURI' (_dlUri dli) let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir - let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) outputFileName + let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view pathL' dlu) outputFileName let cachfile = destDir fn fileExists <- liftIO $ doesFileExist cachfile if @@ -777,7 +779,7 @@ forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile liftE $ checkDigest (view dlHash dli) cachfile pure cachfile - | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir outputFileName False + | otherwise -> liftE $ download dlu Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir outputFileName False where outputFileName = mfn <|> _dlOutput dli diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -17,7 +17,7 @@ Stability : experimental Portability : portable -} -module GHCup.Errors where +module GHCup.Errors ( module GHCup.Errors, URIParseError ) where import GHCup.Types @@ -34,8 +34,6 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import qualified Data.Text.Encoding.Error as E import Data.Data (Proxy(..)) import Data.Time (Day) @@ -849,12 +847,12 @@ eBase _ = 520 eDesc _ = "URL does not have a base filename." -data DigestMissing = DigestMissing URI +data DigestMissing = DigestMissing Text deriving Show instance Pretty DigestMissing where pPrint (DigestMissing uri) = - text "Digest missing for:" <+> (text . T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri + text "Digest missing for:" <+> text (T.unpack uri) instance Exception DigestMissing diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -118,6 +118,7 @@ , TarDirDoesNotExist , UnknownArchive , TestFailed + , URIParseError ] m () @@ -158,6 +159,7 @@ , TarDirDoesNotExist , UnknownArchive , TestFailed + , URIParseError ] m () @@ -256,6 +258,7 @@ , GPGError , DownloadFailed , NoDownload + , URIParseError ] m FilePath @@ -292,6 +295,7 @@ -> InstallDir -> Bool -- ^ Force install -> [T.Text] -- ^ additional configure args for bindist + -> T.Text -> Excepts '[ AlreadyInstalled , BuildFailed @@ -308,10 +312,11 @@ , ProcessError , UninstallFailed , MergeFileTreeError + , URIParseError ] m () -installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do +installGHCBindist dlinfo tver installDir forceInstall addConfArgs installTargets = do lift $ logDebug $ "Requested to install GHC with " <> tVerToText tver regularGHCInstalled <- lift $ ghcInstalled tver @@ -339,12 +344,12 @@ case installDir of IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) tver forceInstall addConfArgs + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) tver forceInstall addConfArgs installTargets GHCupInternal -> do -- regular install -- prepare paths ghcdir <- lift $ ghcupGHCDir tver - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) tver forceInstall addConfArgs + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) tver forceInstall addConfArgs installTargets -- make symlinks & stuff when regular install, liftE $ postGHCInstall tver @@ -381,6 +386,7 @@ -> GHCTargetVersion -- ^ The GHC version -> Bool -- ^ Force install -> [T.Text] -- ^ additional configure args for bindist + -> T.Text -> Excepts '[ BuildFailed , UnknownArchive @@ -390,7 +396,7 @@ , ProcessError , MergeFileTreeError ] m () -installPackedGHC dl msubdir inst ver forceInstall addConfArgs = do +installPackedGHC dl msubdir inst ver forceInstall addConfArgs installTargets = do PlatformRequest {..} <- lift getPlatformReq unless forceInstall @@ -407,7 +413,7 @@ msubdir liftE $ runBuildAction tmpUnpack - (installUnpackedGHC workdir inst ver forceInstall addConfArgs) + (installUnpackedGHC workdir inst ver forceInstall addConfArgs installTargets) -- | Install an unpacked GHC distribution. This only deals with the GHC @@ -429,8 +435,9 @@ -> GHCTargetVersion -- ^ The GHC version -> Bool -- ^ Force install -> [T.Text] -- ^ additional configure args for bindist + -> T.Text -> Excepts '[ProcessError, MergeFileTreeError] m () -installUnpackedGHC path inst tver forceInstall addConfArgs +installUnpackedGHC path inst tver forceInstall addConfArgs installTargets | isWindows = do lift $ logInfo "Installing GHC (this may take a while)" -- Windows bindists are relocatable and don't need @@ -456,7 +463,7 @@ "ghc-configure" Nothing tmpInstallDest <- lift withGHCupTmpDir - lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) + lEM $ make (["DESTDIR=" <> fromGHCupPath tmpInstallDest] <> (words . T.unpack $ installTargets)) (Just $ fromGHCupPath path) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) liftE $ mergeGHCFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) inst tver forceInstall pure () @@ -521,6 +528,7 @@ -> InstallDir -> Bool -- ^ force install -> [T.Text] -- ^ additional configure args for bindist + -> T.Text -> Excepts '[ AlreadyInstalled , BuildFailed @@ -542,12 +550,13 @@ , UnsupportedSetupCombo , DistroNotFound , NoCompatibleArch + , URIParseError ] m () -installGHCBin tver installDir forceInstall addConfArgs = do +installGHCBin tver installDir forceInstall addConfArgs installTargets = do dlinfo <- liftE $ getDownloadInfo' GHC tver - liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs + liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs installTargets @@ -801,6 +810,7 @@ -> Maybe String -- ^ build flavour -> Maybe BuildSystem -> InstallDir + -> T.Text -> Excepts '[ AlreadyInstalled , BuildFailed @@ -825,10 +835,11 @@ , BuildFailed , UninstallFailed , MergeFileTreeError + , URIParseError ] m GHCTargetVersion -compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs buildFlavour buildSystem installDir +compileGHC targetGhc crossTarget vps bstrap hghc jobs mbuildConfig patches aargs buildFlavour buildSystem installDir installTargets = do pfreq@PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo @@ -1022,6 +1033,7 @@ installVer False -- not a force install, since we already overwrite when compiling. [] + installTargets case installDir of -- set and make symlinks for regular (non-isolated) installs diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -118,6 +118,7 @@ , DirNotEmpty , UninstallFailed , MergeFileTreeError + , URIParseError ] m () @@ -311,6 +312,7 @@ , DirNotEmpty , UninstallFailed , MergeFileTreeError + , URIParseError ] m () @@ -352,6 +354,7 @@ , ArchiveResult , BuildFailed , NotInstalled + , URIParseError ] m Version compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do pfreq@PlatformRequest { .. } <- lift getPlatformReq diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs --- a/lib/GHCup/List.hs +++ b/lib/GHCup/List.hs @@ -117,16 +117,17 @@ hlses <- getInstalledHLSs sSet <- stackSet stacks <- getInstalledStacks + hlsGHCVs <- fmap mkTVer <$> hlsGHCVersions - go lt' cSet cabals hlsSet' hlses sSet stacks + go lt' hlsGHCVs cSet cabals hlsSet' hlses sSet stacks where - go lt cSet cabals hlsSet' hlses sSet stacks = do + go lt hlsGHCVs cSet cabals hlsSet' hlses sSet stacks = do case lt of Just t -> do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo -- get versions from GHCupDownloads let avTools = availableToolVersions dls t - lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) + lr <- filter' <$> forM (Map.toList avTools) (toListResult t hlsGHCVs cSet cabals hlsSet' hlses sSet stacks) case t of GHC -> do @@ -145,11 +146,11 @@ let cg = maybeToList $ currentGHCup avTools pure (sort (cg ++ lr)) Nothing -> do - ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks - cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks - hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks - ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks - stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks + ghcvers <- go (Just GHC) hlsGHCVs cSet cabals hlsSet' hlses sSet stacks + cabalvers <- go (Just Cabal) hlsGHCVs cSet cabals hlsSet' hlses sSet stacks + hlsvers <- go (Just HLS) hlsGHCVs cSet cabals hlsSet' hlses sSet stacks + ghcupvers <- go (Just GHCup) hlsGHCVs cSet cabals hlsSet' hlses sSet stacks + stackvers <- go (Just Stack) hlsGHCVs cSet cabals hlsSet' hlses sSet stacks pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) strayGHCs :: ( MonadCatch m , MonadReader env m @@ -182,7 +183,7 @@ } Left e -> do logWarn - $ "Could not parse version of stray directory" <> T.pack e + $ "Could not parse version of stray directory " <> T.pack e pure Nothing strayCabals :: ( MonadReader env m @@ -217,7 +218,7 @@ } Left e -> do logWarn - $ "Could not parse version of stray directory" <> T.pack e + $ "Could not parse version of stray directory " <> T.pack e pure Nothing strayHLS :: ( MonadReader env m @@ -251,7 +252,7 @@ } Left e -> do logWarn - $ "Could not parse version of stray directory" <> T.pack e + $ "Could not parse version of stray directory " <> T.pack e pure Nothing strayStacks :: ( MonadReader env m @@ -286,7 +287,7 @@ } Left e -> do logWarn - $ "Could not parse version of stray directory" <> T.pack e + $ "Could not parse version of stray directory " <> T.pack e pure Nothing currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult @@ -319,6 +320,7 @@ , MonadCatch m ) => Tool + -> [GHCTargetVersion] -> Maybe Version -> [Either FilePath Version] -> Maybe Version @@ -327,7 +329,7 @@ -> [Either FilePath Version] -> (GHCTargetVersion, VersionInfo) -> m ListResult - toListResult t cSet cabals hlsSet' hlses stackSet' stacks (tver, VersionInfo{..}) = do + toListResult t hlsGHCVs cSet cabals hlsSet' hlses stackSet' stacks (tver, VersionInfo{..}) = do let v = _tvVersion tver case t of GHC -> do @@ -336,7 +338,7 @@ let bTags = either (const []) (fromMaybe [] . _dlTag) dli lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver) lInstalled <- ghcInstalled tver - hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions) + let hlsPowered = tver `elem` hlsGHCVs pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags <> bTags diff --git a/lib/GHCup/Prelude/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs --- a/lib/GHCup/Prelude/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| -Module : GHCup.Utils.MegaParsec +Module : GHCup.Prelude.MegaParsec Description : MegaParsec utilities Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -137,3 +137,16 @@ isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') {-# INLINE isSpace #-} +-- Obtain the version from the link or shim path +-- ../ghc//bin/ghc +-- ../ghc//bin/ghc- +ghcVersionFromPath :: MP.Parsec Void Text GHCTargetVersion +ghcVersionFromPath = + do + beforeBin <- parseUntil1 binDir <* MP.some pathSep + MP.setInput beforeBin + _ <- parseTillLastPathSep + 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 () diff --git a/lib/GHCup/Stack.hs b/lib/GHCup/Stack.hs --- a/lib/GHCup/Stack.hs +++ b/lib/GHCup/Stack.hs @@ -90,6 +90,7 @@ , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError + , URIParseError ] m () @@ -129,6 +130,7 @@ , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError + , URIParseError ] m () diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -329,7 +329,7 @@ -- | An encapsulation of a download. This can be used -- to download, extract and install a tool. data DownloadInfo = DownloadInfo - { _dlUri :: URI + { _dlUri :: Text , _dlSubdir :: Maybe TarDir , _dlHash :: Text , _dlCSize :: Maybe Integer @@ -396,12 +396,16 @@ instance NFData NewURLSource -- | Alias for ease of URLSource selection -data ChannelAlias = CrossChannel +data ChannelAlias = DefaultChannel + | StackChannel + | CrossChannel | PrereleasesChannel | VanillaChannel deriving (Eq, GHC.Generic, Show, Enum, Bounded) channelAliasText :: ChannelAlias -> Text +channelAliasText DefaultChannel = "default" +channelAliasText StackChannel = "stack" channelAliasText CrossChannel = "cross" channelAliasText PrereleasesChannel = "prereleases" channelAliasText VanillaChannel = "vanilla" @@ -448,11 +452,12 @@ , uMirrors :: Maybe DownloadMirrors , uDefGHCConfOptions :: Maybe [String] , uPager :: Maybe PagerConfig + , uGuessVersion :: Maybe Bool } deriving (Show, GHC.Generic, Eq) defaultUserSettings :: UserSettings -defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = @@ -472,6 +477,7 @@ , uMirrors = Just mirrors , uDefGHCConfOptions = Just defGHCConfOptions , uPager = Just pager + , uGuessVersion = Just guessVersion } fromSettings Settings{..} (Just KeyBindings{..}) = let ukb = UserKeyBindings @@ -500,6 +506,7 @@ , uMirrors = Just mirrors , uDefGHCConfOptions = Just defGHCConfOptions , uPager = Just pager + , uGuessVersion = Just guessVersion } data UserKeyBindings = UserKeyBindings @@ -587,6 +594,7 @@ , mirrors :: DownloadMirrors , defGHCConfOptions :: [String] , pager :: PagerConfig + , guessVersion :: Bool } deriving (Show, GHC.Generic) @@ -608,7 +616,7 @@ defaultMetaCache = 300 -- 5 minutes defaultSettings :: Settings -defaultSettings = Settings False defaultMetaCache Lax False Never Curl False [NewGHCupURL] False GPGNone False Nothing (DM mempty) [] defaultPagerConfig +defaultSettings = Settings False defaultMetaCache Lax False Never Curl False [NewGHCupURL] False GPGNone False Nothing (DM mempty) [] defaultPagerConfig True instance NFData Settings @@ -662,12 +670,11 @@ instance NFData GPGSetting data DebugInfo = DebugInfo - { diBaseDir :: FilePath - , diBinDir :: FilePath - , diGHCDir :: FilePath - , diCacheDir :: FilePath - , diArch :: Architecture - , diPlatform :: PlatformResult + { diDirs :: Dirs + , diArch :: Architecture + , diPlatform :: PlatformResult + , diChannels :: [(ChannelAlias, URI)] + , diShimGenURL :: URI } deriving Show @@ -880,3 +887,11 @@ deriving (Eq, Show, GHC.Generic) instance (NFData k, NFData v) => NFData (MapIgnoreUnknownKeys k v) + +-- | Type representing our guessing modes when e.g. "incomplete" PVP version +-- is specified, such as @ghcup set ghc 9.12@. +data GuessMode = GStrict -- ^ don't guess the proper tool version + | GLax -- ^ guess by using the metadata + | GLaxWithInstalled -- ^ guess by using metadata and installed versions + deriving (Eq, Show) + diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -220,23 +220,16 @@ versionCmpToText (VR_eq ver') = "== " <> prettyV ver' versionCmpP :: MP.Parsec Void T.Text VersionCmp -versionCmpP = - fmap VR_gt (MP.try $ MPC.space *> MP.chunk ">" *> MPC.space *> versioningEnd) - <|> fmap - VR_gteq - (MP.try $ MPC.space *> MP.chunk ">=" *> MPC.space *> versioningEnd) - <|> fmap - VR_lt - (MP.try $ MPC.space *> MP.chunk "<" *> MPC.space *> versioningEnd) - <|> fmap - VR_lteq - (MP.try $ MPC.space *> MP.chunk "<=" *> MPC.space *> versioningEnd) - <|> fmap - VR_eq - (MP.try $ MPC.space *> MP.chunk "==" *> MPC.space *> versioningEnd) - <|> fmap - VR_eq - (MP.try $ MPC.space *> versioningEnd) +versionCmpP = either (fail . T.unpack) pure =<< (translate <$> (MPC.space *> MP.try (MP.takeWhileP Nothing (`elem` ['>', '<', '=']))) <*> (MPC.space *> versioningEnd)) + where + translate ">" v = Right $ VR_gt v + translate ">=" v = Right $ VR_gteq v + translate "<" v = Right $ VR_lt v + translate "<=" v = Right $ VR_lteq v + translate "==" v = Right $ VR_eq v + translate "" v = Right $ VR_eq v + translate c _ = Left $ "unexpected comparator: " <> c + instance ToJSON VersionRange where toJSON = String . verRangeToText diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -305,23 +305,7 @@ Just <$> ghcLinkVersion link where ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion - ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t - where - parser = - (do - _ <- parseUntil1 ghcSubPath - _ <- ghcSubPath - r <- parseUntil1 pathSep - rest <- MP.getInput - MP.setInput r - x <- ghcTargetVerP - MP.setInput rest - pure x - ) - <* MP.some pathSep - <* MP.takeRest - <* MP.eof - ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep + ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse ghcVersionFromPath "ghcLinkVersion" t -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. @@ -1119,18 +1103,18 @@ , MonadUnliftIO m , MonadFail m ) - => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m () + => Excepts '[URIParseError, GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m () ensureShimGen | isWindows = do dirs <- lift getDirs - let shimDownload = DownloadInfo shimGenURL Nothing shimGenSHA Nothing Nothing Nothing + let shimDownload = DownloadInfo (decUTF8Safe . serializeURIRef' $ shimGenURL) Nothing shimGenSHA Nothing Nothing Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing void $ (\DigestError{} -> do lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) "gs.exe")) lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) "gs.exe") - liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl - ) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl + liftE @'[URIParseError, GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl + ) `catchE` liftE @'[URIParseError, GPGError, DigestError, ContentLengthError, DownloadFailed] dl | otherwise = pure () @@ -1286,4 +1270,3 @@ go (GitDescribe:xs) = gitDescribe <> go xs go (GitBranchName:xs) = gitBranch <> go xs go (S str:xs) = str <> go xs - diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -44,6 +44,7 @@ import Data.Versions import Data.Void import Data.Variant.Excepts +import Optics hiding ( set ) import Prelude hiding ( appendFile ) import Safe import System.FilePath @@ -56,7 +57,43 @@ import qualified Text.Megaparsec as MP import GHCup.Version +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XQuasiQuotes +-- >>> import System.Directory +-- >>> import URI.ByteString +-- >>> import qualified Data.Text as T +-- >>> import GHCup.Prelude +-- >>> import GHCup.Download +-- >>> import GHCup.Version +-- >>> import GHCup.Errors +-- >>> import GHCup.Types +-- >>> import GHCup.Utils.Dirs +-- >>> import GHCup.Types.Optics +-- >>> import Data.Versions +-- >>> import Optics +-- >>> import GHCup.Prelude.Version.QQ +-- >>> import qualified Data.Text.Encoding as E +-- >>> import qualified Data.Map.Strict as M +-- >>> import Control.Monad.Reader +-- >>> import Data.Variant.Excepts +-- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow ) +-- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False } +-- >>> dirs' <- getAllDirs +-- >>> let installedVersions = [ ([pver|8.10.7|], "-debug+lol", Nothing), ([pver|8.10.4|], "", Nothing), ([pver|8.8.4|], "", Nothing), ([pver|8.8.3|], "", Nothing) ] +-- >>> let settings = defaultSettings { cache = True, metaCache = 0, noNetwork = True } +-- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc +-- >>> cwd <- getCurrentDirectory +-- >>> (Right ref) <- pure $ GHCup.Utils.parseURI $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL) +-- >>> (Right ref') <- pure $ GHCup.Utils.parseURI $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ channelURL PrereleasesChannel) +-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, ContentLengthError] $ liftE (getBase ref) >>= liftE . decodeMetadata @GHCupInfo +-- >>> (VRight r') <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, ContentLengthError] $ liftE (getBase ref') >>= liftE . decodeMetadata @GHCupInfo +-- >>> let rr = M.unionsWith (M.unionWith (\_ b2 -> b2)) [r, r'] +-- >>> let go = flip runReaderT leanAppState . fmap (tVerToText . fst) + ------------- --[ Types ]-- ------------- @@ -259,6 +296,7 @@ , MonadCatch m ) => Maybe ToolVersion + -> GuessMode -> Tool -> Excepts '[ TagNotFound @@ -278,6 +316,7 @@ , MonadCatch m ) => SetToolVersion + -> GuessMode -> Tool -> Excepts '[ TagNotFound @@ -285,55 +324,37 @@ , NextVerNotFound , NoToolVersionSet ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion' SetRecommended tool = do +fromVersion' SetRecommended _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getRecommended dls tool ?? TagNotFound Recommended tool -fromVersion' (SetGHCVersion v) tool = do +fromVersion' (SetGHCVersion v) guessMode tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo v tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case - Just (pvp_, vi', mt) -> do - v' <- lift $ pvpToVersion pvp_ "" - when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mt v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolVersion (mkTVer -> v)) tool = do + lift $ guessFullVersion dls v tool guessMode +fromVersion' (SetToolVersion (mkTVer -> v)) guessMode tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo v tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case - Just (pvp_, vi', mt) -> do - v' <- lift $ pvpToVersion pvp_ "" - when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mt v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolTag Latest) tool = do + lift $ guessFullVersion dls v tool guessMode +fromVersion' (SetToolTag Latest) _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getLatest dls tool ?? TagNotFound Latest tool -fromVersion' (SetToolDay day) tool = do +fromVersion' (SetToolDay day) _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> case getByReleaseDay dls tool day of Left ad -> throwE $ DayNotFound day tool ad Right v -> pure v -fromVersion' (SetToolTag LatestPrerelease) tool = do +fromVersion' (SetToolTag LatestPrerelease) _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool -fromVersion' (SetToolTag LatestNightly) tool = do +fromVersion' (SetToolTag LatestNightly) _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool -fromVersion' (SetToolTag Recommended) tool = do +fromVersion' (SetToolTag Recommended) _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getRecommended dls tool ?? TagNotFound Recommended tool -fromVersion' (SetToolTag (Base pvp'')) GHC = do +fromVersion' (SetToolTag (Base pvp'')) _ GHC = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo second Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC -fromVersion' SetNext tool = do +fromVersion' SetNext _ tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo next <- case tool of GHC -> do @@ -379,10 +400,60 @@ GHCup -> fail "GHCup cannot be set" let vi = getVersionInfo next tool dls pure (next, vi) -fromVersion' (SetToolTag t') tool = +fromVersion' (SetToolTag t') _ tool = throwE $ TagNotFound t' tool +-- | Guess the full version from an input version, by possibly +-- examining the metadata and the installed versions. +-- +-- >>> go $ guessFullVersion rr (mkTVer [vver|8|]) GHC GLax +-- "8.10.7" +-- >>> go $ guessFullVersion rr (mkTVer [vver|8.10|]) GHC GLax +-- "8.10.7" +-- >>> go $ guessFullVersion rr (mkTVer [vver|8.10.7|]) GHC GLax +-- "8.10.7" +-- >>> go $ guessFullVersion rr (mkTVer [vver|9.12.1|]) GHC GLax +-- "9.12.1" +-- >>> go $ guessFullVersion rr (mkTVer [vver|8|]) GHC GStrict +-- "8" +guessFullVersion :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => GHCupDownloads + -> GHCTargetVersion + -> Tool + -> GuessMode + -> m (GHCTargetVersion, Maybe VersionInfo) +guessFullVersion dls v tool guessMode = do + let vi = getVersionInfo v tool dls + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) + Right pvpIn + | (guessMode /= GStrict) && hasn't (ix tool % ix v) dls -> do + ghcs <- if guessMode == GLaxWithInstalled then fmap rights getInstalledTools else pure [] + if v `notElem` ghcs + then getLatestToolFor tool (_tvTarget v) pvpIn dls >>= \case + Just (pvp_, vi', mt) -> do + v' <- pvpToVersion pvp_ "" + when (v' /= _tvVersion v) $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion mt v', Just vi') + Nothing -> pure (v, vi) + else pure (v, vi) + _ -> pure (v, vi) + where + getInstalledTools = case tool of + GHC -> getInstalledGHCs + Cabal -> (fmap . fmap) mkTVer <$> getInstalledCabals + HLS -> (fmap . fmap) mkTVer <$> getInstalledHLSs + Stack -> (fmap . fmap) mkTVer <$> getInstalledStacks + GHCup -> pure [] + parseUrlSource :: String -> Either String [NewURLSource] parseUrlSource s = (fromURLSource <$> parseUrlSource' s) <|> ((:[]) <$> parseNewUrlSource s) @@ -413,7 +484,7 @@ parse = (NewGHCupURL <$ AP.string "GHCupURL") <|> (NewStackSetupURL <$ AP.string "StackSetupURL") <|> AP.choice ((\x -> AP.string (UTF8.fromString . T.unpack . channelAliasText $ x) $> NewChannelAlias x) <$> ([minBound..maxBound] :: [ChannelAlias])) - <|> (NewURI <$> parseURI') + <|> (NewURI <$> parseURIP) parseChannelAlias :: String -> Either String ChannelAlias parseChannelAlias s = diff --git a/lib/GHCup/Utils/URI.hs b/lib/GHCup/Utils/URI.hs --- a/lib/GHCup/Utils/URI.hs +++ b/lib/GHCup/Utils/URI.hs @@ -15,12 +15,16 @@ -} module GHCup.Utils.URI where +import GHCup.Prelude.Internal + import Data.Bifunctor (first) +import Data.Text ( Text ) import Control.Applicative import Data.Attoparsec.ByteString import Data.ByteString import URI.ByteString hiding (parseURI) import System.URI.File +import qualified Data.Text.Encoding as E @@ -30,10 +34,13 @@ parseURI :: ByteString -> Either URIParseError (URIRef Absolute) -parseURI = first OtherError . parseOnly parseURI' +parseURI = first OtherError . parseOnly parseURIP -parseURI' :: Parser (URIRef Absolute) -parseURI' = do +parseURI' :: Text -> Either URIParseError (URIRef Absolute) +parseURI' = first OtherError . parseOnly parseURIP . E.encodeUtf8 + +parseURIP :: Parser (URIRef Absolute) +parseURIP = do ref <- (Right <$> parseFile) <|> (Left <$> uriParser laxURIParserOptions) case ref of Left (URI { uriScheme = (Scheme "file") }) -> diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -89,6 +89,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|] diff --git a/scripts/bootstrap/bootstrap-haskell b/scripts/bootstrap/bootstrap-haskell --- a/scripts/bootstrap/bootstrap-haskell +++ b/scripts/bootstrap/bootstrap-haskell @@ -41,7 +41,7 @@ plat="$(uname -s)" arch=$(uname -m) -ghver="0.1.40.0" +ghver="0.1.50.0" : "${GHCUP_BASE_URL:=https://downloads.haskell.org/~ghcup}" export GHCUP_SKIP_UPDATE_CHECK=yes @@ -307,16 +307,17 @@ _url=${GHCUP_BASE_URL}/${ghver}/i386-linux-ghcup-${ghver} ;; armv7*|*armv8l*) - _url=${GHCUP_BASE_URL}/${ghver}/armv7-linux-ghcup-${ghver} + # later versions don't support armv7 anymore + _url=${GHCUP_BASE_URL}/0.1.40.0/armv7-linux-ghcup-0.1.40.0 ;; aarch64|arm64) # we could be in a 32bit docker container, in which # case uname doesn't give us what we want if [ "$(getconf LONG_BIT)" = "32" ] ; then - _url=${GHCUP_BASE_URL}/${ghver}/armv7-linux-ghcup-${ghver} + # later versions don't support armv7 anymore + _url=${GHCUP_BASE_URL}/0.1.40.0/armv7-linux-ghcup-0.1.40.0 elif [ "$(getconf LONG_BIT)" = "64" ] ; then - # TODO: rm 'static-' - _url=${GHCUP_BASE_URL}/${ghver}/aarch64-linux-static-ghcup-${ghver} + _url=${GHCUP_BASE_URL}/${ghver}/aarch64-linux-ghcup-${ghver} else die "Unknown long bit size: $(getconf LONG_BIT)" fi @@ -467,6 +468,127 @@ esac } +ask_base_channel() { + if [ -n "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then + return 0 + fi + echo "-------------------------------------------------------------------------------" + warn "" + warn "GHCup provides different binary distribution \"channels\". These are collections of tools" + warn "and may differ in purpose and philosophy. First, we select the base channel." + warn "" + while true; do + + warn "[S] Skip [D] Default (GHCup maintained) [V] Vanilla (Upstream maintained) [?] Help (default is \"Skip\")." + warn "" + + read -r bashrc_answer = 8" `shouldBe` Right (SimpleRange (VR_gteq [vers|8|]:| [])) + MP.parse versionRangeP "" "< 9" `shouldBe` Right (SimpleRange (VR_lt [vers|9|]:| [])) + MP.parse versionRangeP "" "<= 10" `shouldBe` Right (SimpleRange (VR_lteq [vers|10|]:| [])) + MP.parse versionRangeP "" "=< 100" `shouldBe` Left (ParseErrorBundle {bundleErrors = FancyError 6 (Set.fromList [ErrorFail "unexpected comparator: =<"]) :| [], bundlePosState = PosState {pstateInput = "=< 100", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "", sourceLine = mkPos 1, sourceColumn = mkPos 1}, pstateTabWidth = mkPos 8, pstateLinePrefix = ""}}) + MP.parse versionRangeP "" "> 11" `shouldBe` Right (SimpleRange (VR_gt [vers|11|]:| [])) + MP.parse versionRangeP "" "12" `shouldBe` Right (SimpleRange (VR_eq [vers|12|]:| [])) + MP.parse versionRangeP "" "( >= 8 && < 9 )" `shouldBe` Right (SimpleRange (VR_gteq [vers|8|]:| [VR_lt [vers|9|]])) + MP.parse versionRangeP "" ">= 3 || < 1" `shouldBe` Right (OrRange (VR_gteq [vers|3|]:| []) (SimpleRange (VR_lt [vers|1|]:|[]))) + + it "ghcVersionFromPath" $ do + MP.parse ghcVersionFromPath "" "../ghc/8.10.7/bin/ghc" `shouldBe` Right ghc8107 + MP.parse ghcVersionFromPath "" "../ghc/8.10.7/bin/ghc-8.10.7" `shouldBe` Right ghc8107 + MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/8.10.7/bin/ghc" `shouldBe` Right ghc8107 + MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/8.10.7/bin/ghc-8.10.7" `shouldBe` Right ghc8107 + MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/8.10.7/bin/ghc" `shouldBe` Right ghc8107 + MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/8.10.7/bin/ghc-8.10.7" `shouldBe` Right ghc8107 + + -- a user specified version + MP.parse ghcVersionFromPath "" "../ghc/9.4.8-rc2/bin/ghc-9.4.8" `shouldBe` Right ghc948rc2 + MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/9.4.8-rc2/bin/ghc" `shouldBe` Right ghc948rc2 + MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/9.4.8-rc2/bin/ghc-9.4.8" `shouldBe` Right ghc948rc2 + MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/9.4.8-rc2/bin/ghc" `shouldBe` Right ghc948rc2 + MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/9.4.8-rc2/bin/ghc-9.4.8" `shouldBe` Right ghc948rc2 + + -- a user specified alphanum + MP.parse ghcVersionFromPath "" "../ghc/mytag9.4.8/bin/ghc-9.4.8" `shouldBe` Right ghcMytag + MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/mytag9.4.8/bin/ghc" `shouldBe` Right ghcMytag + MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/mytag9.4.8/bin/ghc-9.4.8" `shouldBe` Right ghcMytag + + -- With Target + MP.parse ghcVersionFromPath "" "../ghc/javascript-unknown-ghcjs-9.6.2/bin/javascript-unknown-ghcjs-ghc-9.6.2" `shouldBe` Right ghcjs962 + MP.parse ghcVersionFromPath "" "c:/ghc/bin/ghcup/ghc/javascript-unknown-ghcjs-9.6.2/bin/javascript-unknown-ghcjs-ghc-9.6.2" `shouldBe` Right ghcjs962 + + where + ghc8107 = GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 8 :| [Numeric 10,Numeric 7]), _vRel = Nothing, _vMeta = Nothing}} + ghc948rc2 = GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 9 :| [Numeric 4,Numeric 8]), _vRel = Just (Release (Alphanum "rc2" :| [])), _vMeta = Nothing}} + ghcMytag = GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Alphanum "mytag9" :| [Numeric 4,Numeric 8]), _vRel = Nothing, _vMeta = Nothing}} + ghcjs962 = GHCTargetVersion {_tvTarget = Just "javascript-unknown-ghcjs", _tvVersion = Version { _vEpoch = Nothing, _vChunks = Chunks (Numeric 9 :| [Numeric 6,Numeric 2]), _vRel = Nothing, _vMeta = Nothing}} diff --git a/test/optparse-test/CompileTest.hs b/test/optparse-test/CompileTest.hs --- a/test/optparse-test/CompileTest.hs +++ b/test/optparse-test/CompileTest.hs @@ -40,6 +40,7 @@ Nothing Nothing Nothing + "install" mkDefaultHLSCompileOptions :: HLSVer -> [ToolVersion] -> HLSCompileOptions mkDefaultHLSCompileOptions target ghcs = diff --git a/test/optparse-test/ConfigTest.hs b/test/optparse-test/ConfigTest.hs --- a/test/optparse-test/ConfigTest.hs +++ b/test/optparse-test/ConfigTest.hs @@ -32,6 +32,12 @@ , ("config add-release-channel StackSetupURL" , AddReleaseChannel False NewStackSetupURL ) + , ("config add-release-channel default" + , AddReleaseChannel False (NewChannelAlias DefaultChannel) + ) + , ("config add-release-channel stack" + , AddReleaseChannel False (NewChannelAlias StackChannel) + ) , ("config add-release-channel cross" , AddReleaseChannel False (NewChannelAlias CrossChannel) ) diff --git a/test/optparse-test/InstallTest.hs b/test/optparse-test/InstallTest.hs --- a/test/optparse-test/InstallTest.hs +++ b/test/optparse-test/InstallTest.hs @@ -32,15 +32,15 @@ ] defaultOptions :: InstallOptions -defaultOptions = InstallOptions Nothing Nothing False Nothing False [] +defaultOptions = InstallOptions Nothing Nothing False Nothing False "install" [] -- | Don't set as active version mkInstallOptions :: ToolVersion -> InstallOptions -mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False [] +mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False "install" [] -- | Set as active version mkInstallOptions' :: ToolVersion -> InstallOptions -mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False [] +mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False "install" [] oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)] oldStyleCheckList =