diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs
index 896f82fc8f86ffd80342d569ab7232a05a3b3fc4..2d8abd2949eed6c75514f330d49aa34daa8164f1 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 3e20f30aa7c76d52f971921659aac8d3bffd5397..015815c2de3a2c6af235d2f0489c685d03dc751a 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 4a09ae5d95e8e2b8f2d082375f46185eb8bfa7f8..dab1789ae5949506f555b78fe966c9351b918f04 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 080bfa0a0cdc7ac9048f8e06808b31ad6defdcd4..a4521154916ac2643e822e790bb878378cef56ea 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