Merge branch 'fix-ghc-version-parser'

This commit is contained in:
Julian Ospald 2021-11-02 10:56:21 +01:00
commit 6697e804ee
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 49 additions and 20 deletions

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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