From 9497e310ca61ab350092539a29fa0964e06358e9 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 25 Sep 2021 15:13:44 +0200 Subject: [PATCH] Improve cli interface with partial versions Fixes #243 --- app/ghcup/Main.hs | 13 ++-- lib/GHCup.hs | 11 ++-- lib/GHCup/Utils.hs | 124 ++++++++++++++++++++++++++++++------- lib/GHCup/Utils/Prelude.hs | 29 +++++++-- 4 files changed, 139 insertions(+), 38 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c99ca6f..659d873 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3ed9f35..0788b76 100644 --- a/lib/GHCup.hs +++ b/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) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 4b11bab..57160c1 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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 + diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index ee06c0d..a70758f 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -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.