From 2c57def8f10dfa62d65799f5725259ab272a5463 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 2 Nov 2021 01:22:06 +0100 Subject: [PATCH] Fix parsing of atypical ghc versions --- app/ghcup/GHCup/OptParse/Common.hs | 2 +- lib/GHCup.hs | 4 +-- lib/GHCup/Utils.hs | 23 +++++++++-------- lib/GHCup/Utils/Prelude.hs | 40 +++++++++++++++++++++++++----- 4 files changed, 49 insertions(+), 20 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index 896f82f..2d8abd2 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -399,7 +399,7 @@ fromVersion' (SetToolVersion v) tool = do 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) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 3e20f30..015815c 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1574,7 +1574,7 @@ listVersions lt' criteria = do 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 @@ -2576,7 +2576,7 @@ upgradeGHCup mtarget force' = do 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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 4a09ae5..dab1789 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -59,6 +59,7 @@ import Control.Monad.Reader 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 @@ -110,7 +111,7 @@ import qualified Data.List.NonEmpty as NE -- >>> 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 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 @@ -631,34 +632,34 @@ 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) + (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 :: MonadThrow m 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 diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 080bfa0..a452115 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -44,7 +44,7 @@ import Control.Monad.IO.Class 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,18 +313,46 @@ removeLensFieldLabel str' = 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 isDigit _ = False