Merge branch 'issue-243'
This commit is contained in:
commit
4f82e80dad
GPG Key ID:
3786C5262ECB4A3F
@ -49,7 +49,6 @@ import Data.Char
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.List ( intercalate, nub, sort, sortBy )
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.Maybe
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions hiding ( str )
|
||||
@ -2749,13 +2748,15 @@ fromVersion' SetRecommended tool = do
|
||||
fromVersion' (SetToolVersion v) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
let vi = getVersionInfo (_tvVersion v) tool dls
|
||||
case pvp $ prettyVer (_tvVersion v) of
|
||||
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
|
||||
Left _ -> pure (v, vi)
|
||||
Right (PVP (major' :|[minor'])) ->
|
||||
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
|
||||
Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
|
||||
Right pvpIn ->
|
||||
lift (getLatestToolFor tool pvpIn dls) >>= \case
|
||||
Just (pvp_, vi') -> do
|
||||
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)
|
||||
Right _ -> pure (v, vi)
|
||||
fromVersion' (SetToolTag Latest) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
|
||||
|
||||
11
lib/GHCup.hs
11
lib/GHCup.hs
@ -59,6 +59,7 @@ import Data.ByteString ( ByteString )
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.List.NonEmpty ( NonEmpty((:|)) )
|
||||
import Data.String ( fromString )
|
||||
import Data.Text ( Text )
|
||||
import Data.Time.Clock
|
||||
@ -1573,7 +1574,7 @@ listVersions lt' criteria = do
|
||||
|
||||
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
|
||||
currentGHCup av =
|
||||
let currentVer = pvpToVersion ghcUpVer
|
||||
let currentVer = fromJust $ pvpToVersion ghcUpVer
|
||||
listVer = Map.lookup currentVer av
|
||||
latestVer = fst <$> headOf (getTagged Latest) av
|
||||
recommendedVer = fst <$> headOf (getTagged Latest) av
|
||||
@ -1731,7 +1732,7 @@ rmGHCVer ver = do
|
||||
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
|
||||
$ fmap Just
|
||||
$ getMajorMinorV (_tvVersion ver)
|
||||
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
|
||||
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
|
||||
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
|
||||
Dirs {..} <- lift getDirs
|
||||
@ -2539,6 +2540,7 @@ upgradeGHCup :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
@ -2563,7 +2565,8 @@ upgradeGHCup mtarget force' = do
|
||||
|
||||
lift $ logInfo "Upgrading GHCup..."
|
||||
let latestVer = fromJust $ fst <$> getLatest dls GHCup
|
||||
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
||||
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer
|
||||
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
|
||||
dli <- liftE $ getDownloadInfo GHCup latestVer
|
||||
tmp <- lift withGHCupTmpDir
|
||||
let fn = "ghcup" <> exeExt
|
||||
@ -2626,7 +2629,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
|
||||
handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
|
||||
$ fmap Just
|
||||
$ getMajorMinorV _tvVersion
|
||||
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
|
||||
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
|
||||
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
|
||||
|
||||
|
||||
@ -86,8 +86,37 @@ import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
|
||||
|
||||
-- $setup
|
||||
-- >>> :set -XOverloadedStrings
|
||||
-- >>> :set -XDataKinds
|
||||
-- >>> :set -XTypeApplications
|
||||
-- >>> :set -XQuasiQuotes
|
||||
-- >>> import System.Directory
|
||||
-- >>> import URI.ByteString
|
||||
-- >>> import qualified Data.Text as T
|
||||
-- >>> import GHCup.Utils.Prelude
|
||||
-- >>> import GHCup.Download
|
||||
-- >>> import GHCup.Version
|
||||
-- >>> import GHCup.Errors
|
||||
-- >>> import GHCup.Types
|
||||
-- >>> import GHCup.Types.Optics
|
||||
-- >>> import Optics
|
||||
-- >>> import GHCup.Utils.Version.QQ
|
||||
-- >>> import qualified Data.Text.Encoding as E
|
||||
-- >>> import Control.Monad.Reader
|
||||
-- >>> import Haskus.Utils.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|], 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 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)
|
||||
-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] $ liftE $ getBase ref
|
||||
|
||||
|
||||
|
||||
@ -559,34 +588,83 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
|
||||
Just (x, y) -> x == major' && y == minor'
|
||||
Nothing -> False
|
||||
|
||||
-- | Match PVP prefix.
|
||||
--
|
||||
-- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
|
||||
-- True
|
||||
-- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
|
||||
-- True
|
||||
-- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
|
||||
-- False
|
||||
-- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
|
||||
-- True
|
||||
matchPVPrefix :: PVP -> PVP -> Bool
|
||||
matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> Maybe Text -- ^ the target triple
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
getGHCForMajor major' minor' mt = do
|
||||
toL :: PVP -> [Int]
|
||||
toL (PVP inner) = fmap fromIntegral $ NE.toList inner
|
||||
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
|
||||
-- PVP version.
|
||||
getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
|
||||
=> PVP
|
||||
-> Maybe Text -- ^ the target triple
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
getGHCForPVP pvpIn mt = do
|
||||
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)
|
||||
|
||||
pure
|
||||
. lastMay
|
||||
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
|
||||
. filter
|
||||
(\GHCTargetVersion {..} ->
|
||||
_tvTarget == mt && matchMajor _tvVersion major' minor'
|
||||
)
|
||||
$ ghcs
|
||||
getGHCForPVP' pvpIn ghcs' mt
|
||||
|
||||
-- | Like 'getGHCForPVP', except with explicit input parameter.
|
||||
--
|
||||
-- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing
|
||||
-- "Just 8.10.7"
|
||||
-- >>> 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
|
||||
-> Maybe Text -- ^ the target triple
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
getGHCForPVP' pvpIn ghcs' mt = do
|
||||
let mResult = lastMay
|
||||
. sortBy (\(x, _) (y, _) -> compare x y)
|
||||
. filter
|
||||
(\(pvp_, target) ->
|
||||
target == mt && matchPVPrefix pvp_ pvpIn
|
||||
)
|
||||
$ ghcs'
|
||||
forM mResult $ \(pvp_, target) -> do
|
||||
ver' <- pvpToVersion pvp_
|
||||
pure (GHCTargetVersion target ver')
|
||||
|
||||
|
||||
-- | Get the latest available ghc for X.Y major version.
|
||||
getLatestGHCFor :: Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> GHCupDownloads
|
||||
-> Maybe (Version, VersionInfo)
|
||||
getLatestGHCFor major' minor' dls =
|
||||
preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
|
||||
-- | Get the latest available ghc for the given PVP version, which
|
||||
-- may only contain parts.
|
||||
--
|
||||
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8|] r
|
||||
-- Just (PVP {_pComponents = 8 :| [10,7]})
|
||||
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8|] r
|
||||
-- Just (PVP {_pComponents = 8 :| [8,4]})
|
||||
-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8.4|] r
|
||||
-- Just (PVP {_pComponents = 8 :| [8,4]})
|
||||
getLatestToolFor :: MonadThrow m
|
||||
=> Tool
|
||||
-> PVP
|
||||
-> GHCupDownloads
|
||||
-> m (Maybe (PVP, VersionInfo))
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -22,6 +22,7 @@ module GHCup.Utils.Prelude where
|
||||
#if defined(IS_WINDOWS)
|
||||
import GHCup.Types
|
||||
#endif
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import {-# SOURCE #-} GHCup.Utils.Logger
|
||||
|
||||
@ -35,10 +36,11 @@ import Data.ByteString ( ByteString )
|
||||
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf )
|
||||
import Data.Maybe
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import Data.Word8 hiding ( isDigit )
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
||||
@ -59,6 +61,7 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import qualified Data.List.Split as Split
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Encoding.Error as E
|
||||
@ -296,12 +299,28 @@ removeLensFieldLabel str' =
|
||||
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
|
||||
|
||||
|
||||
pvpToVersion :: PVP -> Version
|
||||
pvpToVersion :: MonadThrow m => PVP -> m Version
|
||||
pvpToVersion =
|
||||
either (\_ -> error "Couldn't convert PVP to Version") id
|
||||
. version
|
||||
. prettyPVP
|
||||
either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP
|
||||
|
||||
versionToPVP :: MonadThrow m => Version -> m PVP
|
||||
versionToPVP v = either (\_ -> alternative v) pure . 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)
|
||||
|
||||
isDigit :: VChunk -> Bool
|
||||
isDigit (Digits _ :| []) = True
|
||||
isDigit _ = False
|
||||
|
||||
unsafeDigit :: VChunk -> Int
|
||||
unsafeDigit (Digits x :| []) = fromIntegral x
|
||||
unsafeDigit _ = error "unsafeDigit: wrong input"
|
||||
|
||||
pvpFromList :: [Int] -> PVP
|
||||
pvpFromList = PVP . NE.fromList . fmap fromIntegral
|
||||
|
||||
-- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
|
||||
-- the Unicode replacement character U+FFFD.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user