ghcup 0.1.17.3 → 0.1.17.4
raw patch · 24 files changed
+392/−658 lines, 24 filesdep ~basedep ~haskus-utils-variantPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, haskus-utils-variant
API changes (from Hackage documentation)
+ GHCup: applyAnyPatch :: (MonadReader env m, HasDirs env, HasLog env, HasSettings env, MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m, MonadMask m, MonadIO m) => Maybe (Either FilePath [URI]) -> FilePath -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
+ GHCup.Types: [$sel:metaCache:Settings] :: Settings -> Integer
+ GHCup.Types: [$sel:uMetaCache:UserSettings] :: UserSettings -> Maybe Integer
+ GHCup.Types: defaultMetaCache :: Integer
+ GHCup.Types: defaultSettings :: Settings
+ GHCup.Utils: applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m) => FilePath -> FilePath -> Excepts '[PatchFailed] m ()
- GHCup: compileGHC :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadThrow m, MonadResource m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) => Either GHCTargetVersion GitBranch -> Maybe Version -> Either Version FilePath -> Maybe Int -> Maybe FilePath -> Maybe FilePath -> [Text] -> Maybe String -> Bool -> Maybe FilePath -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, GHCupSetError, NoDownload, NotFoundInPATH, PatchFailed, UnknownArchive, TarDirDoesNotExist, NotInstalled, DirNotEmpty, ArchiveResult, FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig, ProcessError, CopyError, BuildFailed] m GHCTargetVersion
+ GHCup: compileGHC :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadThrow m, MonadResource m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) => Either GHCTargetVersion GitBranch -> Maybe Version -> Either Version FilePath -> Maybe Int -> Maybe FilePath -> Maybe (Either FilePath [URI]) -> [Text] -> Maybe String -> Bool -> Maybe FilePath -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, GHCupSetError, NoDownload, NotFoundInPATH, PatchFailed, UnknownArchive, TarDirDoesNotExist, NotInstalled, DirNotEmpty, ArchiveResult, FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig, ProcessError, CopyError, BuildFailed] m GHCTargetVersion
- GHCup: compileHLS :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Either Version GitBranch -> [Version] -> Maybe Int -> Maybe Version -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Excepts '[NoDownload, GPGError, DownloadFailed, DigestError, UnknownArchive, TarDirDoesNotExist, ArchiveResult, BuildFailed, NotInstalled] m Version
+ GHCup: compileHLS :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Either Version GitBranch -> [Version] -> Maybe Int -> Maybe Version -> Maybe FilePath -> Maybe (Either FilePath URI) -> Maybe URI -> Maybe (Either FilePath [URI]) -> [Text] -> Excepts '[NoDownload, GPGError, DownloadFailed, DigestError, UnknownArchive, TarDirDoesNotExist, ArchiveResult, BuildFailed, NotInstalled] m Version
- GHCup.Types: Settings :: Bool -> Bool -> KeepDirs -> Downloader -> Bool -> URLSource -> Bool -> GPGSetting -> Bool -> Settings
+ GHCup.Types: Settings :: Bool -> Integer -> Bool -> KeepDirs -> Downloader -> Bool -> URLSource -> Bool -> GPGSetting -> Bool -> Settings
- GHCup.Types: UserSettings :: Maybe Bool -> Maybe Bool -> Maybe Bool -> Maybe KeepDirs -> Maybe Downloader -> Maybe UserKeyBindings -> Maybe URLSource -> Maybe Bool -> Maybe GPGSetting -> UserSettings
+ GHCup.Types: UserSettings :: Maybe Bool -> Maybe Integer -> Maybe Bool -> Maybe Bool -> Maybe KeepDirs -> Maybe Downloader -> Maybe UserKeyBindings -> Maybe URLSource -> Maybe Bool -> Maybe GPGSetting -> UserSettings
- GHCup.Utils: getGHCForPVP' :: MonadThrow m => PVP -> [(PVP, Maybe Text)] -> Maybe Text -> m (Maybe GHCTargetVersion)
+ GHCup.Utils: getGHCForPVP' :: MonadThrow m => PVP -> [(PVP, Text, Maybe Text)] -> Maybe Text -> m (Maybe GHCTargetVersion)
- GHCup.Utils: make :: (MonadThrow m, MonadIO m, MonadReader env m, HasDirs env, HasSettings env) => [String] -> Maybe FilePath -> m (Either ProcessError ())
+ GHCup.Utils: make :: (MonadThrow m, MonadIO m, MonadReader env m, HasDirs env, HasLog env, HasSettings env) => [String] -> Maybe FilePath -> m (Either ProcessError ())
- GHCup.Utils.File: execLogged :: (MonadReader env m, HasSettings env, HasDirs env, MonadIO m, MonadThrow m) => FilePath -> [String] -> Maybe FilePath -> FilePath -> Maybe [(String, String)] -> m (Either ProcessError ())
+ GHCup.Utils.File: execLogged :: (MonadReader env m, HasSettings env, HasLog env, HasDirs env, MonadIO m, MonadThrow m) => FilePath -> [String] -> Maybe FilePath -> FilePath -> Maybe [(String, String)] -> m (Either ProcessError ())
- GHCup.Utils.Prelude: pvpToVersion :: MonadThrow m => PVP -> m Version
+ GHCup.Utils.Prelude: pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
- GHCup.Utils.Prelude: versionToPVP :: MonadThrow m => Version -> m PVP
+ GHCup.Utils.Prelude: versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
Files
- CHANGELOG.md +8/−0
- README.md +2/−0
- app/ghcup-gen/Main.hs +0/−155
- app/ghcup-gen/Validate.hs +0/−280
- app/ghcup/BrickMain.hs +32/−20
- app/ghcup/GHCup/OptParse.hs +2/−0
- app/ghcup/GHCup/OptParse/Common.hs +29/−49
- app/ghcup/GHCup/OptParse/Compile.hs +51/−24
- app/ghcup/GHCup/OptParse/Config.hs +2/−1
- app/ghcup/GHCup/OptParse/DInfo.hs +1/−1
- app/ghcup/GHCup/OptParse/Install.hs +2/−2
- app/ghcup/Main.hs +85/−10
- data/config.yaml +4/−0
- ghcup.cabal +15/−50
- lib/GHCup.hs +62/−33
- lib/GHCup/Download.hs +7/−3
- lib/GHCup/Platform.hs +4/−0
- lib/GHCup/Types.hs +11/−1
- lib/GHCup/Utils.hs +31/−22
- lib/GHCup/Utils/File/Posix.hs +2/−0
- lib/GHCup/Utils/File/Windows.hs +4/−0
- lib/GHCup/Utils/Prelude.hs +34/−6
- lib/GHCup/Utils/Version/QQ.hs +3/−0
- test/GHCup/Types/JSONSpec.hs +1/−1
CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for ghcup +## 0.1.17.4 -- 2021-11-13++* add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)+* make upgrading ghcup in TUI more pleasant wrt [#276](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/276)+* fix parsing of atypical GHC versions (e.g. `8.10.5-patch1`)+* fix compiling HLS dynamically linked, also see [#245](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/245)+* redo (and break) some of the `ghcup compile <tool>` interface, improving patch options and setting custom cabal.project files+ ## 0.1.17.3 -- 2021-10-27 * clean up during unpack failures as well
README.md view
@@ -9,3 +9,5 @@ GHCup is an installer for the general purpose language [Haskell](https://www.haskell.org/). Visit the [documentation](https://www.haskell.org/ghcup/) for installation instructions.++If you're looking for the metadata YAML files, see here: [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata)
− app/ghcup-gen/Main.hs
@@ -1,155 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}---module Main where--import GHCup.Types-import GHCup.Errors-import GHCup.Platform-import GHCup.Utils.Dirs-import GHCup.Utils.Logger-import GHCup.Types.JSON ( )--import Control.Exception ( displayException )-import Control.Monad.Trans.Reader ( runReaderT )-import Control.Monad.IO.Class-import Data.Char ( toLower )-import Data.Maybe-#if !MIN_VERSION_base(4,13,0)-import Data.Semigroup ( (<>) )-#endif-import Options.Applicative hiding ( style )-import Haskus.Utils.Variant.Excepts-import System.Console.Pretty-import System.Environment-import System.Exit-import System.IO ( stderr )-import Text.Regex.Posix-import Validate-import Text.PrettyPrint.HughesPJClass ( prettyShow )--import qualified Data.Text.IO as T-import qualified Data.Text as T-import qualified Data.ByteString as B-import qualified Data.Yaml.Aeson as Y---data Options = Options- { optCommand :: Command- }--data Command = ValidateYAML ValidateYAMLOpts- | ValidateTarballs ValidateYAMLOpts TarballFilter---data Input- = FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway- | StdInput--fileInput :: Parser Input-fileInput =- FileInput- <$> strOption- (long "file" <> short 'f' <> metavar "FILENAME" <> help- "Input file to validate"- )--stdInput :: Parser Input-stdInput = flag'- StdInput- (short 'i' <> long "stdin" <> help "Validate from stdin (default)")--inputP :: Parser Input-inputP = fileInput <|> stdInput--data ValidateYAMLOpts = ValidateYAMLOpts- { vInput :: Maybe Input- }--validateYAMLOpts :: Parser ValidateYAMLOpts-validateYAMLOpts = ValidateYAMLOpts <$> optional inputP--tarballFilterP :: Parser TarballFilter-tarballFilterP = option readm $- long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def- <> help "Only check certain tarballs (format: <tool>-<version>)"- where- def = TarballFilter (Right Nothing) (makeRegex ("" :: String))- readm = do- s <- str- case span (/= '-') s of- (_, []) -> fail "invalid format, missing '-' after the tool name"- (t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->- pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)- (t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->- pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)- _ -> fail "invalid tool"- low = fmap toLower---opts :: Parser Options-opts = Options <$> com--com :: Parser Command-com = subparser- ( command- "check"- ( ValidateYAML- <$> info (validateYAMLOpts <**> helper)- (progDesc "Validate the YAML")- )- <> command- "check-tarballs"- (info- ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)- (progDesc "Validate all tarballs (download and checksum)")- )- )----main :: IO ()-main = do- no_color <- isJust <$> lookupEnv "NO_COLOR"- let loggerConfig = LoggerConfig { lcPrintDebug = True- , consoleOutter = T.hPutStr stderr- , fileOutter = \_ -> pure ()- , fancyColors = not no_color- }- dirs <- liftIO getAllDirs- let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig-- pfreq <- (- flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest- ) >>= \case- VRight r -> pure r- VLeft e -> do- flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e- liftIO $ exitWith (ExitFailure 2)-- let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig-- _ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)- >>= \Options {..} -> case optCommand of- ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)- ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)- pure ()-- where- withValidateYamlOpts vopts f = case vopts of- ValidateYAMLOpts { vInput = Nothing } ->- B.getContents >>= valAndExit f- ValidateYAMLOpts { vInput = Just StdInput } ->- B.getContents >>= valAndExit f- ValidateYAMLOpts { vInput = Just (FileInput file) } ->- B.readFile file >>= valAndExit f- valAndExit f contents = do- (GHCupInfo _ av gt) <- case Y.decodeEither' contents of- Right r -> pure r- Left e -> die (color Red $ displayException e)- f av gt- >>= exitWith
− app/ghcup-gen/Validate.hs
@@ -1,280 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module Validate where--import GHCup-import GHCup.Download-import GHCup.Errors-import GHCup.Types-import GHCup.Types.Optics-import GHCup.Utils-import GHCup.Utils.Logger-import GHCup.Utils.Version.QQ--import Codec.Archive-import Control.Applicative-import Control.Exception.Safe-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Reader.Class-import Control.Monad.Trans.Class ( lift )-import Control.Monad.Trans.Reader ( runReaderT )-import Control.Monad.Trans.Resource ( runResourceT- , MonadUnliftIO- )-import Data.Containers.ListUtils ( nubOrd )-import Data.IORef-import Data.List-import Data.Versions-import Haskus.Utils.Variant.Excepts-import Optics-import System.FilePath-import System.Exit-import Text.ParserCombinators.ReadP-import Text.PrettyPrint.HughesPJClass ( prettyShow )-import Text.Regex.Posix--import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified Data.Version as V---data ValidationError = InternalError String- deriving Show--instance Exception ValidationError---addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()-addError = do- ref <- ask- liftIO $ modifyIORef ref (+ 1)---validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)- => GHCupDownloads- -> M.Map GlobalTool DownloadInfo- -> m ExitCode-validate dls _ = do- ref <- liftIO $ newIORef 0-- -- verify binary downloads --- flip runReaderT ref $ do- -- unique tags- forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t-- -- required platforms- forM_ (M.toList dls) $ \(t, versions) ->- forM_ (M.toList versions) $ \(v, vi) ->- forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do- checkHasRequiredPlatforms t v (_viTags vi) arch (M.keys pspecs)-- checkGHCVerIsValid- forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t- _ <- checkGHCHasBaseVersion-- -- exit- e <- liftIO $ readIORef ref- if e > 0- then pure $ ExitFailure e- else do- lift $ logInfo "All good"- pure ExitSuccess- where- checkHasRequiredPlatforms t v tags arch pspecs = do- let v' = prettyVer v- arch' = prettyShow arch- when (Linux UnknownLinux `notElem` pspecs) $ do- lift $ logError $- "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'- addError- when ((Darwin `notElem` pspecs) && arch == A_64) $ do- lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'- addError- when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $- "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'- when (Windows `notElem` pspecs && arch == A_64) $ do- lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'- addError-- -- alpine needs to be set explicitly, because- -- we cannot assume that "Linux UnknownLinux" runs on Alpine- -- (although it could be static)- when (Linux Alpine `notElem` pspecs) $- case t of- GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError- Cabal | v > [vver|2.4.1.0|]- , arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError- GHC | Latest `elem` tags || Recommended `elem` tags- , arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))- _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)-- checkUniqueTags tool = do- let allTags = _viTags =<< M.elems (availableToolVersions dls tool)- let nonUnique =- fmap fst- . filter (\(_, b) -> not b)- <$> ( mapM- (\case- [] -> throwM $ InternalError "empty inner list"- (t : ts) ->- pure $ (t, ) (not (isUniqueTag t) || null ts)- )- . group- . sort- $ allTags- )- case join nonUnique of- [] -> pure ()- xs -> do- lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)- addError- where- isUniqueTag Latest = True- isUniqueTag Recommended = True- isUniqueTag Old = False- isUniqueTag Prerelease = False- isUniqueTag (Base _) = False- isUniqueTag (UnknownTag _) = False-- checkGHCVerIsValid = do- let ghcVers = toListOf (ix GHC % to M.keys % folded) dls- forM_ ghcVers $ \v ->- case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of- [_] -> pure ()- _ -> do- lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"- addError-- -- a tool must have at least one of each mandatory tags- checkMandatoryTags tool = do- let allTags = _viTags =<< M.elems (availableToolVersions dls tool)- forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of- False -> do- lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)- addError- True -> pure ()-- -- all GHC versions must have a base tag- checkGHCHasBaseVersion = do- let allTags = M.toList $ availableToolVersions dls GHC- forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of- False -> do- lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver- addError- True -> pure ()-- isBase (Base _) = True- isBase _ = False--data TarballFilter = TarballFilter- { tfTool :: Either GlobalTool (Maybe Tool)- , tfVersion :: Regex- }--validateTarballs :: ( Monad m- , MonadReader env m- , HasLog env- , HasDirs env- , HasSettings env- , MonadThrow m- , MonadIO m- , MonadUnliftIO m- , MonadMask m- , Alternative m- , MonadFail m- )- => TarballFilter- -> GHCupDownloads- -> M.Map GlobalTool DownloadInfo- -> m ExitCode-validateTarballs (TarballFilter etool versionRegex) dls gt = do- ref <- liftIO $ newIORef 0-- -- download/verify all tarballs- let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool- let gdlis = nubOrd $ gt ^.. each- let allDls = either (const gdlis) (const dlis) etool- when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref- forM_ allDls (downloadAll ref)-- -- exit- e <- liftIO $ readIORef ref- if e > 0- then pure $ ExitFailure e- else do- logInfo "All good"- pure ExitSuccess-- where- downloadAll :: ( MonadUnliftIO m- , MonadIO m- , MonadReader env m- , HasLog env- , HasDirs env- , HasSettings env- , MonadCatch m- , MonadMask m- , MonadThrow m- )- => IORef Int- -> DownloadInfo- -> m ()- downloadAll ref dli = do- r <- runResourceT- . runE @'[DigestError- , GPGError- , DownloadFailed- , UnknownArchive- , ArchiveResult- ]- $ do- case etool of- Right (Just GHCup) -> do- tmpUnpack <- lift mkGhcupTmpDir- _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False- pure Nothing- Right _ -> do- p <- liftE $ downloadCached dli Nothing- fmap (Just . head . splitDirectories . head)- . liftE- . getArchiveFiles- $ p- Left ShimGen -> do- tmpUnpack <- lift mkGhcupTmpDir- _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False- pure Nothing- case r of- VRight (Just basePath) -> do- case _dlSubdir dli of- Just (RealDir prel) -> do- logInfo- $ " verifying subdir: " <> T.pack prel- when (basePath /= prel) $ do- logError $- "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath- runReaderT addError ref- Just (RegexDir regexString) -> do- logInfo $- "verifying subdir (regex): " <> T.pack regexString- let regex = makeRegexOpts- compIgnoreCase- execBlank- regexString- unless (match regex basePath) $ do- logError $- "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath- runReaderT addError ref- Nothing -> pure ()- VRight Nothing -> pure ()- VLeft e -> do- logError $- "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)- runReaderT addError ref
app/ghcup/BrickMain.hs view
@@ -10,6 +10,7 @@ import GHCup import GHCup.Download import GHCup.Errors+import GHCup.Types.Optics ( getDirs ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils import GHCup.Utils.Logger@@ -26,6 +27,9 @@ ) import Codec.Archive import Control.Exception.Safe+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif import Control.Monad.Reader import Control.Monad.Trans.Except import Control.Monad.Trans.Resource@@ -40,6 +44,8 @@ import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile )+import System.Directory ( canonicalizePath )+import System.FilePath import System.Exit import System.IO.Unsafe import Text.PrettyPrint.HughesPJClass ( prettyShow )@@ -48,6 +54,8 @@ import qualified Data.Text as T import qualified Graphics.Vty as Vty import qualified Data.Vector as V+import System.Environment (getExecutablePath)+import qualified System.Posix.Process as SPP hiddenTools :: [Tool]@@ -432,28 +440,43 @@ ] run (do+ ce <- liftIO $ fmap (either (const Nothing) Just) $+ try @_ @SomeException $ getExecutablePath >>= canonicalizePath+ dirs <- lift getDirs case lTool of GHC -> do let vi = getVersionInfo lVer GHC dls- liftE $ installGHCBin lVer Nothing False $> vi+ liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce) Cabal -> do let vi = getVersionInfo lVer Cabal dls- liftE $ installCabalBin lVer Nothing False $> vi+ liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce) GHCup -> do let vi = snd <$> getLatest dls GHCup- liftE $ upgradeGHCup Nothing False $> vi+ liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce) HLS -> do let vi = getVersionInfo lVer HLS dls- liftE $ installHLSBin lVer Nothing False $> vi+ liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce) Stack -> do let vi = getVersionInfo lVer Stack dls- liftE $ installStackBin lVer Nothing False $> vi+ liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce) ) >>= \case- VRight vi -> do- forM_ (_viPostInstall =<< vi) $ \msg ->- logInfo msg+ VRight (vi, Dirs{..}, Just ce) -> do+ forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg+ case lTool of+ GHCup -> do+ up <- liftIO $ fmap (either (const Nothing) Just)+ $ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)+ when ((normalise <$> up) == Just (normalise ce)) $+ -- TODO: track cli arguments of previous invocation+ liftIO $ SPP.executeFile ce False ["tui"] Nothing+ logInfo "Please restart 'ghcup' for the changes to take effect"+ _ -> pure () pure $ Right ()+ VRight (vi, _, _) -> do+ forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg+ logInfo "Please restart 'ghcup' for the changes to take effect"+ pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V NoUpdate) -> pure $ Right () VLeft e -> pure $ Left $ prettyShow e <> "\n"@@ -536,17 +559,7 @@ , fileOutter = \_ -> pure () , fancyColors = True }- newIORef $ AppState (Settings { cache = True- , noVerify = False- , keepDirs = Never- , downloader = Curl- , verbose = False- , urlSource = GHCupURL- , noNetwork = False- , gpgSetting = GPGNone- , noColor = False- , ..- })+ newIORef $ AppState defaultSettings dirs defaultKeyBindings (GHCupInfo mempty mempty mempty)@@ -605,4 +618,3 @@ flip runReaderT settings $ do lV <- listVersions Nothing Nothing pure $ BrickData (reverse lV)-
app/ghcup/GHCup/OptParse.hs view
@@ -67,6 +67,7 @@ -- global options optVerbose :: Maybe Bool , optCache :: Maybe Bool+ , optMetaCache :: Maybe Integer , optUrlSource :: Maybe URI , optNoVerify :: Maybe Bool , optKeepDirs :: Maybe KeepDirs@@ -105,6 +106,7 @@ Options <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)") <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")+ <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal)) <*> optional (option (eitherReader parseUri)
app/ghcup/GHCup/OptParse/Common.hs view
@@ -89,6 +89,18 @@ mv _ = "VERSION|TAG" +toolVersionOption :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion+toolVersionOption criteria tool =+ option (eitherReader toolVersionEither)+ ( sh tool+ <> completer (tagCompleter (fromMaybe GHC tool) [])+ <> foldMap (completer . versionCompleter criteria) tool)+ where+ sh (Just GHC) = long "ghc" <> metavar "GHC_VERSION|TAG"+ sh (Just HLS) = long "hls" <> metavar "HLS_VERSION|TAG"+ sh _ = long "version" <> metavar "VERSION|TAG"++ versionParser :: Parser GHCTargetVersion versionParser = option (eitherReader tVersionEither)@@ -196,8 +208,8 @@ ] -bindistParser :: String -> Either String URI-bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString+uriParser :: String -> Either String URI+uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString absolutePathParser :: FilePath -> Either String FilePath@@ -246,19 +258,7 @@ where t = T.toLower (T.pack s') -toolVersionParser :: Parser ToolVersion-toolVersionParser = verP' <|> toolP- where- verP' = ToolVersion <$> versionParser- toolP =- ToolTag- <$> option- (eitherReader tagEither)- (short 't' <> long "tag" <> metavar "TAG" <> help "The target tag") --- keepOnParser :: String -> Either String KeepDirs keepOnParser s' | t == T.pack "always" = Right Always | t == T.pack "errors" = Right Errors@@ -299,7 +299,7 @@ , fancyColors = False } let appState = LeanAppState- (Settings True False Never Curl False GHCupURL True GPGNone False)+ (defaultSettings { noNetwork = True }) dirs' defaultKeyBindings loggerConfig@@ -322,7 +322,7 @@ , fileOutter = mempty , fancyColors = False }- let settings = Settings True False Never Curl False GHCupURL True GPGNone False+ let settings = defaultSettings { noNetwork = True } let leanAppState = LeanAppState settings dirs'@@ -399,7 +399,7 @@ Right pvpIn -> lift (getLatestToolFor tool pvpIn dls) >>= \case Just (pvp_, vi') -> do- v' <- lift $ pvpToVersion pvp_+ v' <- lift $ pvpToVersion pvp_ "" when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') pure (GHCTargetVersion (_tvTarget v) v', Just vi') Nothing -> pure (v, vi)@@ -472,42 +472,22 @@ , MonadIO m , MonadFail m )- => m ()+ => m [(Tool, Version)] checkForUpdates = do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo lInstalled <- listVersions Nothing (Just ListInstalled) let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled - forM_ (getLatest dls GHCup) $ \(l, _) -> do- (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer- when (l > ghc_ver)- $ logWarn $- "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"-- forM_ (getLatest dls GHC) $ \(l, _) -> do- let mghc_ver = latestInstalled GHC- forM mghc_ver $ \ghc_ver ->- when (l > ghc_ver)- $ logWarn $- "New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"-- forM_ (getLatest dls Cabal) $ \(l, _) -> do- let mcabal_ver = latestInstalled Cabal- forM mcabal_ver $ \cabal_ver ->- when (l > cabal_ver)- $ logWarn $- "New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"+ ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do+ (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer+ if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing - forM_ (getLatest dls HLS) $ \(l, _) -> do- let mhls_ver = latestInstalled HLS- forM mhls_ver $ \hls_ver ->- when (l > hls_ver)- $ logWarn $- "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"+ otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->+ forMM (getLatest dls t) $ \(l, _) -> do+ let mver = latestInstalled t+ forMM mver $ \ver ->+ if (l > ver) then pure $ Just (t, l) else pure Nothing - forM_ (getLatest dls Stack) $ \(l, _) -> do- let mstack_ver = latestInstalled Stack- forM mstack_ver $ \stack_ver ->- when (l > stack_ver)- $ logWarn $- "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"+ pure $ catMaybes (ghcup:otherTools)+ where+ forMM a f = fmap join $ forM a f
app/ghcup/GHCup/OptParse/Compile.hs view
@@ -40,6 +40,7 @@ import System.Exit import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString hiding ( uriParser ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) import System.FilePath (isPathSeparator)@@ -68,7 +69,7 @@ , bootstrapGhc :: Either Version FilePath , jobs :: Maybe Int , buildConfig :: Maybe FilePath- , patchDir :: Maybe FilePath+ , patches :: Maybe (Either FilePath [URI]) , crossTarget :: Maybe Text , addConfArgs :: [Text] , setCompile :: Bool@@ -84,10 +85,11 @@ , setCompile :: Bool , ovewrwiteVer :: Maybe Version , isolateDir :: Maybe FilePath- , cabalProject :: Maybe FilePath- , cabalProjectLocal :: Maybe FilePath- , patchDir :: Maybe FilePath+ , cabalProject :: Maybe (Either FilePath URI)+ , cabalProjectLocal :: Maybe URI+ , patches :: Maybe (Either FilePath [URI]) , targetGHCs :: [ToolVersion]+ , cabalArgs :: [Text] } @@ -148,7 +150,10 @@ These need to be available in PATH prior to compilation. Examples:- ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|]+ # compile 1.4.0 for ghc 8.10.5 and 8.10.7+ ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7+ # compile from master for ghc 8.10.7, linking everything dynamically+ ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|] ghcCompileOpts :: Parser GHCCompileOptions@@ -195,13 +200,23 @@ "Absolute path to build config file" ) )- <*> optional- (option- str- (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help- "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"+ <*> (optional+ (+ (fmap Right $ many $ option+ (eitherReader uriParser)+ (long "patch" <> metavar "PATCH_URI" <> help+ "URI to a patch (https/http/file)"+ ) )+ <|>+ (fmap Left $ option+ str+ (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help+ "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"+ )+ ) )+ ) <*> optional (option str@@ -296,26 +311,37 @@ ) <*> optional (option- str+ ((fmap Right $ eitherReader uriParser) <|> (fmap Left str)) (long "cabal-project" <> metavar "CABAL_PROJECT" <> help- "If relative, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. If absolute, will copy the file over."+ "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme." ) ) <*> optional (option- (eitherReader absolutePathParser)+ (eitherReader uriParser) (long "cabal-project-local" <> metavar "CABAL_PROJECT_LOCAL" <> help- "Absolute path to a cabal.project.local to be used for the build. Will be copied over."+ "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over." ) )- <*> optional- (option- (eitherReader absolutePathParser)- (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help- "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"+ <*> (optional+ (+ (fmap Right $ many $ option+ (eitherReader uriParser)+ (long "patch" <> metavar "PATCH_URI" <> help+ "URI to a patch (https/http/file)"+ ) )+ <|>+ (fmap Left $ option+ str+ (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help+ "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"+ )+ ) )- <*> some (toolVersionArgument Nothing (Just GHC))+ )+ <*> some (toolVersionOption Nothing (Just GHC))+ <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)")) @@ -403,11 +429,11 @@ ) => CompileCommand -> Settings+ -> Dirs -> (forall eff a . ReaderT AppState m (VEither eff a) -> m (VEither eff a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode-compile compileCommand settings runAppState runLogger = do- VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)+compile compileCommand settings Dirs{..} runAppState runLogger = do case compileCommand of (CompileHLS HLSCompileOptions { .. }) -> do runCompileHLS runAppState (do@@ -430,7 +456,8 @@ isolateDir cabalProject cabalProjectLocal- patchDir+ patches+ cabalArgs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer HLS dls when setCompile $ void $ liftE $@@ -477,7 +504,7 @@ bootstrapGhc jobs buildConfig- patchDir+ patches addConfArgs buildFlavour hadrian
app/ghcup/GHCup/OptParse/Config.hs view
@@ -122,6 +122,7 @@ mergeConf :: UserSettings -> Settings -> Settings mergeConf UserSettings{..} Settings{..} = let cache' = fromMaybe cache uCache+ metaCache' = fromMaybe metaCache uMetaCache noVerify' = fromMaybe noVerify uNoVerify keepDirs' = fromMaybe keepDirs uKeepDirs downloader' = fromMaybe downloader uDownloader@@ -129,7 +130,7 @@ urlSource' = fromMaybe urlSource uUrlSource noNetwork' = fromMaybe noNetwork uNoNetwork gpgSetting' = fromMaybe gpgSetting uGPGSetting- in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor+ in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
app/ghcup/GHCup/OptParse/DInfo.hs view
@@ -51,7 +51,7 @@ runIO (do CapturedProcess{..} <- do dirs <- liftIO getAllDirs- let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False)+ let settings = AppState (defaultSettings { noNetwork = True }) dirs defaultKeyBindings flip runReaderT settings $ executeOut "git" ["describe"] Nothing
app/ghcup/GHCup/OptParse/Install.hs view
@@ -37,7 +37,7 @@ import Prelude hiding ( appendFile ) import System.Exit import Text.PrettyPrint.HughesPJClass ( prettyShow )-import URI.ByteString+import URI.ByteString hiding ( uriParser ) import qualified Data.Text as T @@ -187,7 +187,7 @@ <*> ( ( (,) <$> optional (option- (eitherReader bindistParser)+ (eitherReader uriParser) (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help "Install the specified version from this bindist" )
app/ghcup/Main.hs view
@@ -20,6 +20,7 @@ import GHCup.Errors import GHCup.Platform import GHCup.Types+import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils import GHCup.Utils.Logger import GHCup.Utils.Prelude@@ -39,6 +40,7 @@ import Data.Either import Data.Functor import Data.Maybe+import Data.Versions import GHC.IO.Encoding import Haskus.Utils.Variant.Excepts import Language.Haskell.TH@@ -55,6 +57,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as E+import qualified GHCup.Types as Types @@ -72,15 +75,16 @@ where mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) mergeConf Options{..} UserSettings{..} noColor =- let cache = fromMaybe (fromMaybe False uCache) optCache- noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify- verbose = fromMaybe (fromMaybe False uVerbose) optVerbose- keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs+ let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache+ metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache+ noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify+ verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose+ keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings- urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource- noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork- gpgSetting = fromMaybe (fromMaybe GPGNone uGPGSetting) optGpg+ urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource+ noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork+ gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg in (Settings {..}, keyBindings) #if defined(INTERNAL_DOWNLOADER) defaultDownloader = Internal@@ -189,7 +193,7 @@ ------------------------- - appState = do+ let appState = do pfreq <- ( runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest ) >>= \case@@ -225,8 +229,28 @@ #if defined(BRICK) Interactive -> pure () #endif+ -- check for new tools _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case- Nothing -> runReaderT checkForUpdates s'+ Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do+ newTools <- lift checkForUpdates + forM_ newTools $ \newTool@(t, l) -> do+ -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283+ alreadyInstalling' <- alreadyInstalling optCommand newTool+ when (not alreadyInstalling') $+ case t of+ GHCup -> runLogger $+ logWarn ("New GHCup version available: "+ <> prettyVer l+ <> ". To upgrade, run 'ghcup upgrade'")+ _ -> runLogger $+ logWarn ("New "+ <> T.pack (prettyShow t)+ <> " version available. "+ <> "To upgrade, run 'ghcup install "+ <> T.pack (prettyShow t)+ <> " "+ <> prettyVer l+ <> "'") Just _ -> pure () -- TODO: always run for windows@@ -268,7 +292,7 @@ List lo -> list lo no_color runAppState Rm rmCommand -> rm rmCommand runAppState runLogger DInfo -> dinfo runAppState runLogger- Compile compileCommand -> compile compileCommand settings runAppState runLogger+ Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger Config configCommand -> config configCommand settings keybindings runLogger Whereis whereisOptions whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger@@ -285,4 +309,55 @@ pure () + where+ alreadyInstalling :: ( HasLog env+ , MonadFail m+ , MonadReader env m+ , HasGHCupInfo env+ , HasDirs env+ , MonadThrow m+ , MonadIO m+ , MonadCatch m+ )+ => Command+ -> (Tool, Version)+ -> Excepts+ '[ TagNotFound+ , NextVerNotFound+ , NoToolVersionSet+ ] m Bool+ alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver+ alreadyInstalling (Install (Left (InstallGHC InstallOptions{..}))) (GHC, ver) = cmp' GHC instVer ver+ alreadyInstalling (Install (Left (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver+ alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver+ alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver+ alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))+ (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver+ alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))+ (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver+ alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))+ (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver+ alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))+ (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver+ alreadyInstalling _ _ = pure False + cmp' :: ( HasLog env+ , MonadFail m+ , MonadReader env m+ , HasGHCupInfo env+ , HasDirs env+ , MonadThrow m+ , MonadIO m+ , MonadCatch m+ )+ => Tool+ -> Maybe ToolVersion+ -> Version+ -> Excepts+ '[ TagNotFound+ , NextVerNotFound+ , NoToolVersionSet+ ] m Bool+ cmp' tool instVer ver = do+ (v, _) <- liftE $ fromVersion instVer tool+ pure (v == mkTVer ver)
data/config.yaml view
@@ -36,6 +36,10 @@ show-all-tools: KChar: 't' +# The caching for the metadata files containing download info, depending on last access time+# of the file. These usually are in '~/.ghcup/cache/ghcup-<ver>.yaml'.+meta-cache: 300 # in seconds+ # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation # check the 'URLSource' type in the code. url-source:
ghcup.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup-version: 0.1.17.3+version: 0.1.17.4 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020@@ -43,6 +43,11 @@ default: False manual: True +flag no-exe+ description: Don't build any executables + default: False+ manual: True+ library exposed-modules: GHCup@@ -91,7 +96,7 @@ build-depends: , aeson >=1.4 , async >=0.8 && <2.3- , base >=4.13 && <5+ , base >=4.12 && <5 , base16-bytestring >=0.1.1.6 && <1.1 , binary ^>=0.8.6.0 , bytestring ^>=0.10@@ -105,7 +110,7 @@ , disk-free-space ^>=0.1.0.1 , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5- , haskus-utils-variant >=3.0 && <3.2+ , haskus-utils-variant ^>=3.2.1 , libarchive ^>=3.0.3.0 , lzma-static ^>=5.2.5.3 , megaparsec >=8.0.0 && <9.1@@ -214,14 +219,15 @@ , aeson >=1.4 , aeson-pretty ^>=0.8.8 , async ^>=2.2.3- , base >=4.13 && <5+ , base >=4.12 && <5 , bytestring ^>=0.10 , cabal-plan ^>=0.7.2 , containers ^>=0.6 , deepseq ^>=1.4+ , directory ^>=1.3.6.0 , filepath ^>=1.4.2.1 , ghcup- , haskus-utils-variant >=3.0 && <3.2+ , haskus-utils-variant ^>=3.2.1 , libarchive ^>=3.0.3.0 , megaparsec >=8.0.0 && <9.1 , mtl ^>=2.2@@ -247,56 +253,15 @@ build-depends: , brick ^>=0.64 , transformers ^>=0.5+ , unix ^>=2.7 , vector ^>=0.12 , vty >=5.28.2 && <5.34 if os(windows) cpp-options: -DIS_WINDOWS -executable ghcup-gen- main-is: Main.hs- hs-source-dirs: app/ghcup-gen- other-modules: Validate- default-language: Haskell2010- default-extensions:- DeriveGeneric- LambdaCase- MultiWayIf- NamedFieldPuns- PackageImports- QuasiQuotes- RecordWildCards- ScopedTypeVariables- StrictData- TupleSections- TypeApplications- TypeFamilies- ViewPatterns-- ghc-options:- -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns- -fwarn-incomplete-record-updates -threaded-- build-depends:- , base >=4.13 && <5- , bytestring ^>=0.10- , containers ^>=0.6- , filepath ^>=1.4.2.1- , ghcup- , haskus-utils-variant >=3.0 && <3.2- , libarchive ^>=3.0.3.0- , mtl ^>=2.2- , optics ^>=0.4- , optparse-applicative >=0.15.1.0 && <0.17- , pretty ^>=1.1.3.1- , pretty-terminal ^>=0.1.0.0- , regex-posix ^>=0.96- , resourcet ^>=1.2.2- , safe-exceptions ^>=0.1- , text ^>=1.2.4.0- , transformers ^>=0.5- , versions >=4.0.1 && <5.1- , yaml-streamly ^>=0.12.0+ if flag(no-exe)+ buildable: False test-suite ghcup-test type: exitcode-stdio-1.0@@ -322,7 +287,7 @@ -fwarn-incomplete-record-updates build-depends:- , base >=4.13 && <5+ , base >=4.12 && <5 , bytestring ^>=0.10 , containers ^>=0.6 , generic-arbitrary ^>=0.1.0
lib/GHCup.hs view
@@ -62,7 +62,7 @@ import Data.Text ( Text ) import Data.Time.Clock import Data.Time.Format.ISO8601-import Data.Versions+import Data.Versions hiding ( patch ) import Distribution.Types.Version hiding ( Version ) import Distribution.Types.PackageId import Distribution.Types.PackageDescription@@ -84,6 +84,7 @@ import System.IO.Temp import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix+import URI.ByteString import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.List.NonEmpty as NE@@ -750,9 +751,10 @@ -> Maybe Int -> Maybe Version -> Maybe FilePath- -> Maybe FilePath- -> Maybe FilePath- -> Maybe FilePath+ -> Maybe (Either FilePath URI)+ -> Maybe URI+ -> Maybe (Either FilePath [URI]) -- ^ patches+ -> [Text] -- ^ additional args to cabal install -> Excepts '[ NoDownload , GPGError , DownloadFailed@@ -763,11 +765,12 @@ , BuildFailed , NotInstalled ] m Version-compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patchdir = do+compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo Dirs { .. } <- lift getDirs + (workdir, tver) <- case targetHLS of -- unpack from version tarball Left tver -> do@@ -834,48 +837,51 @@ liftE $ runBuildAction workdir Nothing- (reThrowAll @_ @'[PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do+ (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do let installDir = workdir </> "out" liftIO $ createDirRecursive' installDir -- apply patches- forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)+ liftE $ applyAnyPatch patches workdir -- set up project files cp <- case cabalProject of- Just cp+ Just (Left cp) | isAbsolute cp -> do copyFileE cp (workdir </> "cabal.project") pure "cabal.project" | otherwise -> pure (takeFileName cp)+ Just (Right uri) -> do+ tmpUnpack <- lift withGHCupTmpDir+ cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False+ copyFileE cp (workdir </> "cabal.project")+ pure "cabal.project" Nothing -> pure "cabal.project"- forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir </> cp <.> "local")-- let targets = ["exe:haskell-language-server", "exe:haskell-language-server-wrapper"]-+ forM_ cabalProjectLocal $ \uri -> do+ tmpUnpack <- lift withGHCupTmpDir+ cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False+ copyFileE cpl (workdir </> cp <.> "local") artifacts <- forM (sort ghcs) $ \ghc -> do let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)- liftIO $ createDirRecursive' ghcInstallDir+ liftIO $ createDirRecursive' installDir lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc liftE $ lEM @_ @'[ProcessError] $- execLogged "cabal" ( [ "v2-build"+ execLogged "cabal" ( [ "v2-install" , "-w" , "ghc-" <> T.unpack (prettyVer ghc)+ , "--install-method=copy" ] ++ maybe [] (\j -> ["--jobs=" <> show j]) jobs ++- [ "--project-file=" <> cp- ] ++ targets+ [ "--overwrite-policy=always"+ , "--disable-profiling"+ , "--disable-tests"+ , "--installdir=" <> ghcInstallDir+ , "--project-file=" <> cp+ ] ++ fmap T.unpack cabalArgs ++ [+ "exe:haskell-language-server"+ , "exe:haskell-language-server-wrapper"] ) (Just workdir) "cabal" Nothing- forM_ targets $ \target -> do- let cabal = "cabal"- args = ["list-bin", target]- CapturedProcess{..} <- lift $ executeOut cabal args (Just workdir) - case _exitCode of- ExitFailure i -> throwE (NonZeroExit i cabal args)- _ -> pure ()- let cbin = stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut- copyFileE cbin (ghcInstallDir </> takeFileName cbin) pure ghcInstallDir forM_ artifacts $ \artifact -> do@@ -1102,7 +1108,7 @@ pure $ Just (file <> "-" <> verS) -- create symlink- forM mTargetFile $ \targetFile -> do+ forM_ mTargetFile $ \targetFile -> do let fullF = binDir </> targetFile <> exeExt fileWithExt = file <> exeExt destL <- lift $ ghcLinkDestination fileWithExt ver@@ -1574,7 +1580,7 @@ currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult currentGHCup av =- let currentVer = fromJust $ pvpToVersion ghcUpVer+ let currentVer = fromJust $ pvpToVersion ghcUpVer "" listVer = Map.lookup currentVer av latestVer = fst <$> headOf (getTagged Latest) av recommendedVer = fst <$> headOf (getTagged Latest) av@@ -2090,7 +2096,7 @@ -> Either Version FilePath -- ^ version to bootstrap with -> Maybe Int -- ^ jobs -> Maybe FilePath -- ^ build config- -> Maybe FilePath -- ^ patch directory+ -> Maybe (Either FilePath [URI]) -- ^ patches -> [Text] -- ^ additional args to ./configure -> Maybe String -- ^ build flavour -> Bool@@ -2119,7 +2125,7 @@ ] m GHCTargetVersion-compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir+compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo@@ -2143,7 +2149,7 @@ workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)- forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)+ liftE $ applyAnyPatch patches workdir pure (workdir, tmpUnpack, tver) @@ -2151,7 +2157,7 @@ Right GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing- tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH] DownloadFailed $ do+ tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lEM $ git [ "init" ]@@ -2171,7 +2177,7 @@ lEM $ git [ "checkout", "FETCH_HEAD" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]- forM_ patchdir (\dir -> liftE $ applyPatches dir tmpUnpack)+ liftE $ applyAnyPatch patches tmpUnpack lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" CapturedProcess {..} <- lift $ makeOut@@ -2505,6 +2511,7 @@ execWithGhcEnv :: ( MonadReader env m , HasSettings env , HasDirs env+ , HasLog env , MonadIO m , MonadThrow m) => FilePath -- ^ thing to execute@@ -2576,7 +2583,7 @@ lift $ logInfo "Upgrading GHCup..." let latestVer = fromJust $ fst <$> getLatest dls GHCup- (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer+ (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate dli <- liftE $ getDownloadInfo GHCup latestVer tmp <- lift withGHCupTmpDir@@ -2845,3 +2852,25 @@ let p = tmpdir </> f logDebug $ "rm -rf " <> T.pack p rmPathForcibly p+++applyAnyPatch :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , HasSettings env+ , MonadUnliftIO m+ , MonadCatch m+ , MonadResource m+ , MonadThrow m+ , MonadMask m+ , MonadIO m)+ => Maybe (Either FilePath [URI])+ -> FilePath+ -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()+applyAnyPatch Nothing _ = pure ()+applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir+applyAnyPatch (Just (Right uris)) workdir = do+ tmpUnpack <- lift withGHCupTmpDir+ forM_ uris $ \uri -> do+ patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False+ liftE $ applyPatch patch workdir
lib/GHCup/Download.hs view
@@ -242,14 +242,18 @@ e <- liftIO $ doesFileExist json_file currentTime <- liftIO getCurrentTime Dirs { cacheDir } <- lift getDirs+ Settings { metaCache } <- lift getSettings -- for local files, let's short-circuit and ignore access time if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True | e -> do- accessTime <- liftIO $ getAccessTime json_file-+ accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file+ let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime+ let cacheInterval = fromInteger metaCache+ lift $ logDebug $ "last access was " <> T.pack (show sinceLastAccess) <> " ago, cache interval is " <> T.pack (show cacheInterval) -- access time won't work on most linuxes, but we can try regardless- if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->+ if | metaCache <= 0 -> dlWithMod currentTime json_file+ | (sinceLastAccess > cacheInterval) -> -- no access in last 5 minutes, re-check upstream mod time dlWithMod currentTime json_file | otherwise -> pure json_file
lib/GHCup/Platform.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -27,6 +28,9 @@ import GHCup.Utils.Prelude import GHCup.Utils.String.QQ +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif import Control.Applicative import Control.Exception.Safe import Control.Monad
lib/GHCup/Types.hs view
@@ -294,6 +294,7 @@ data UserSettings = UserSettings { uCache :: Maybe Bool+ , uMetaCache :: Maybe Integer , uNoVerify :: Maybe Bool , uVerbose :: Maybe Bool , uKeepDirs :: Maybe KeepDirs@@ -306,12 +307,13 @@ deriving (Show, GHC.Generic) defaultUserSettings :: UserSettings-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = UserSettings { uCache = Just cache+ , uMetaCache = Just metaCache , uNoVerify = Just noVerify , uVerbose = Just verbose , uKeepDirs = Just keepDirs@@ -335,6 +337,7 @@ } in UserSettings { uCache = Just cache+ , uMetaCache = Just metaCache , uNoVerify = Just noVerify , uVerbose = Just verbose , uKeepDirs = Just keepDirs@@ -410,6 +413,7 @@ data Settings = Settings { cache :: Bool+ , metaCache :: Integer , noVerify :: Bool , keepDirs :: KeepDirs , downloader :: Downloader@@ -420,6 +424,12 @@ , noColor :: Bool -- this also exists in LoggerConfig } deriving (Show, GHC.Generic)++defaultMetaCache :: Integer+defaultMetaCache = 300 -- 5 minutes++defaultSettings :: Settings+defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False instance NFData Settings
lib/GHCup/Utils.hs view
@@ -59,6 +59,7 @@ import Control.Monad.Trans.Resource hiding ( throwM ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )+import Data.Bifunctor ( first ) import Data.ByteString ( ByteString ) import Data.Either import Data.Foldable@@ -66,7 +67,7 @@ import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.Maybe import Data.Text ( Text )-import Data.Versions+import Data.Versions hiding ( patch ) import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Optics@@ -110,8 +111,8 @@ -- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow ) -- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False } -- >>> dirs' <- getAllDirs--- >>> let installedVersions = [ ([pver|8.10.7|], Nothing), ([pver|8.10.4|], Nothing), ([pver|8.8.4|], Nothing), ([pver|8.8.3|], Nothing) ]--- >>> let settings = Settings True False Never Curl False GHCupURL True GPGNone False+-- >>> 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 = Settings True 0 False Never Curl False GHCupURL True GPGNone False -- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc -- >>> cwd <- getCurrentDirectory -- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)@@ -631,34 +632,34 @@ ghcs <- rights <$> getInstalledGHCs -- we're permissive here... failed parse just means we have no match anyway let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do- pvp_ <- versionToPVP _tvVersion- pure (pvp_, _tvTarget)+ (pvp_, rest) <- versionToPVP _tvVersion+ pure (pvp_, rest, _tvTarget) getGHCForPVP' pvpIn ghcs' mt -- | Like 'getGHCForPVP', except with explicit input parameter. ----- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing--- "Just 8.10.7"+-- >>> getGHCForPVP' [pver|8|] installedVersions Nothing+-- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}}) -- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing -- "Just 8.8.4" -- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing -- "Just 8.10.4" getGHCForPVP' :: MonadThrow m => PVP- -> [(PVP, Maybe Text)] -- ^ installed GHCs+ -> [(PVP, Text, Maybe Text)] -- ^ installed GHCs -> Maybe Text -- ^ the target triple -> m (Maybe GHCTargetVersion) getGHCForPVP' pvpIn ghcs' mt = do let mResult = lastMay- . sortBy (\(x, _) (y, _) -> compare x y)+ . sortBy (\(x, _, _) (y, _, _) -> compare x y) . filter- (\(pvp_, target) ->+ (\(pvp_, _, target) -> target == mt && matchPVPrefix pvp_ pvpIn ) $ ghcs'- forM mResult $ \(pvp_, target) -> do- ver' <- pvpToVersion pvp_+ forM mResult $ \(pvp_, rest, target) -> do+ ver' <- pvpToVersion pvp_ rest pure (GHCTargetVersion target ver') @@ -679,7 +680,7 @@ getLatestToolFor tool pvpIn dls = do let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls- pure . headMay . filter (\(v, _) -> matchPVPrefix pvpIn v) $ ps+ pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps @@ -855,6 +856,7 @@ , MonadIO m , MonadReader env m , HasDirs env+ , HasLog env , HasSettings env ) => [String]@@ -890,15 +892,22 @@ execBlank ([s|.+\.(patch|diff)$|] :: ByteString) )- forM_ (sort patches) $ \patch' -> do- lift $ logInfo $ "Applying patch " <> T.pack patch'- fmap (either (const Nothing) Just)- (exec- "patch"- ["-p1", "-i", patch']- (Just ddir)- Nothing)- !? PatchFailed+ forM_ (sort patches) $ \patch' -> applyPatch patch' ddir+++applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)+ => FilePath -- ^ Patch+ -> FilePath -- ^ dir to apply patches in+ -> Excepts '[PatchFailed] m ()+applyPatch patch ddir = do+ lift $ logInfo $ "Applying patch " <> T.pack patch+ fmap (either (const Nothing) Just)+ (exec+ "patch"+ ["-p1", "-s", "-f", "-i", patch]+ (Just ddir)+ Nothing)+ !? PatchFailed -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
lib/GHCup/Utils/File/Posix.hs view
@@ -73,6 +73,7 @@ execLogged :: ( MonadReader env m , HasSettings env+ , HasLog env , HasDirs env , MonadIO m , MonadThrow m)@@ -85,6 +86,7 @@ execLogged exe args chdir lfile env = do Settings {..} <- getSettings Dirs {..} <- getDirs+ logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args let logfile = logsDir </> lfile <> ".log" liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) closeFd
lib/GHCup/Utils/File/Windows.hs view
@@ -18,6 +18,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import GHCup.Utils.Dirs import GHCup.Utils.File.Common+import GHCup.Utils.Logger import GHCup.Types import GHCup.Types.Optics @@ -40,6 +41,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map+import qualified Data.Text as T @@ -149,6 +151,7 @@ execLogged :: ( MonadReader env m , HasDirs env+ , HasLog env , HasSettings env , MonadIO m , MonadThrow m)@@ -160,6 +163,7 @@ -> m (Either ProcessError ()) execLogged exe args chdir lfile env = do Dirs {..} <- getDirs+ logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args let stdoutLogfile = logsDir </> lfile <> ".stdout.log" stderrLogfile = logsDir </> lfile <> ".stderr.log" cp <- createProcessWithMingwPath ((proc exe args)
lib/GHCup/Utils/Prelude.hs view
@@ -44,7 +44,7 @@ import Control.Monad.Reader import Data.Bifunctor import Data.ByteString ( ByteString )-import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd )+import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse ) import Data.Maybe import Data.Foldable import Data.List.NonEmpty ( NonEmpty( (:|) ))@@ -313,17 +313,45 @@ maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str' -pvpToVersion :: MonadThrow m => PVP -> m Version-pvpToVersion =- either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP+pvpToVersion :: MonadThrow m => PVP -> Text -> m Version+pvpToVersion pvp_ rest =+ either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_ -versionToPVP :: MonadThrow m => Version -> m PVP-versionToPVP v = either (\_ -> alternative v) pure . pvp . prettyVer $ v+-- | Convert a version to a PVP and unparsable rest.+--+-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v+versionToPVP :: MonadThrow m => Version -> m (PVP, Text)+versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"+versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v where alternative :: MonadThrow m => Version -> m PVP alternative v' = case NE.takeWhile isDigit (_vChunks v') of [] -> throwM $ ParseError "Couldn't convert Version to PVP" xs -> pure $ pvpFromList (unsafeDigit <$> xs)++ rest :: Version -> Text+ rest (Version _ cs pr me) =+ let chunks = NE.dropWhile isDigit cs+ ver = intersperse (T.pack ".") . chunksAsT $ chunks+ me' = maybe [] (\m -> [T.pack "+",m]) me+ pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)+ prefix = case (ver, pr', me') of+ (_:_, _, _) -> T.pack "."+ _ -> T.pack ""+ in prefix <> mconcat (ver <> pr' <> me')+ where+ chunksAsT :: Functor t => t VChunk -> t Text+ chunksAsT = fmap (foldMap f)+ where+ f :: VUnit -> Text+ f (Digits i) = T.pack $ show i+ f (Str s) = s++ foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b+ foldable d g f | null f = d+ | otherwise = g f++ isDigit :: VChunk -> Bool isDigit (Digits _ :| []) = True
lib/GHCup/Utils/Version/QQ.hs view
@@ -53,6 +53,9 @@ #if !MIN_VERSION_base(4,13,0) deriving instance Lift (NonEmpty Word)+deriving instance Lift (NonEmpty VChunk)+deriving instance Lift (NonEmpty MChunk)+deriving instance Lift (NonEmpty VUnit) #endif qq :: (Text -> Q Exp) -> QuasiQuoter
test/GHCup/Types/JSONSpec.hs view
@@ -3,7 +3,7 @@ module GHCup.Types.JSONSpec where import GHCup.ArbitraryTypes ()-import GHCup.Types+import GHCup.Types hiding ( defaultSettings ) import GHCup.Types.JSON () import Test.Aeson.GenericSpecs