WIP

app/ghcup/BrickMain.hs

@@ -11,7 +11,6 @@ module BrickMain where
 import           GHCup
 import           GHCup.Download
 import           GHCup.Errors
-import           GHCup.Types.Optics ( getDirs )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
 import           GHCup.OptParse.Common (logGHCPostRm)
@@ -20,6 +19,7 @@ import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.Process
 import           GHCup.Prompts
+import           GHCup.Types.Optics hiding ( getGHCupInfo )
 
 import           Brick
 import           Brick.Widgets.Border
@@ -53,6 +53,7 @@ import           System.Exit
 import           System.IO.Unsafe
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString
+import           Optics ( view )
 
 import qualified Data.Text                     as T
 import qualified Data.Text.Lazy.Builder        as B
@@ -477,7 +478,7 @@ install' _ (_, ListResult {..}) = do
     )
     >>= \case
           VRight (vi, Dirs{..}, Just ce) -> do
-            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+            forM_ (view viPostInstall =<< vi) $ \msg -> logInfo msg
             case lTool of
               GHCup -> do
                 up <- liftIO $ fmap (either (const Nothing) Just)
@@ -489,7 +490,7 @@ install' _ (_, ListResult {..}) = do
               _ -> pure ()
             pure $ Right ()
           VRight (vi, _, _) -> do
-            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
+            forM_ (view viPostInstall =<< vi) $ \msg -> logInfo msg
             logInfo "Please restart 'ghcup' for the changes to take effect"
             pure $ Right ()
           VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
@@ -564,7 +565,7 @@ del' _ (_, ListResult {..}) = do
     >>= \case
           VRight vi -> do
             logGHCPostRm (mkTVer lVer)
-            forM_ (_viPostRemove =<< vi) $ \msg ->
+            forM_ (view viPostRemove =<< vi) $ \msg ->
               logInfo msg
             pure $ Right ()
           VLeft  e -> pure $ Left (prettyHFError e)

app/ghcup/GHCup/OptParse/Common.hs

@@ -57,6 +57,7 @@ import           System.Process                  ( readProcess )
 import           System.FilePath
 import           Text.HTML.TagSoup       hiding ( Tag )
 import           URI.ByteString
+import           Optics ( view )
 
 import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Map.Strict               as M
@@ -451,7 +452,7 @@ tagCompleter tool add = listIOCompleter $ do
   case mGhcUpInfo of
     VRight ghcupInfo -> do
       let allTags = filter (/= Old)
-            $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
+            $ (view viTags) =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
       pure $ nub $ (add ++) $ fmap tagToString allTags
     VLeft _ -> pure  (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
 

app/ghcup/GHCup/OptParse/Compile.hs

@@ -16,11 +16,11 @@ import qualified GHCup.GHC as GHC
 import qualified GHCup.HLS as HLS
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Types.Optics
 import           GHCup.Utils
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
 import           GHCup.OptParse.Common
+import           GHCup.Types.Optics
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -36,6 +36,7 @@ import           Data.Versions                  ( Version, prettyVer, version, p
 import qualified Data.Versions as V
 import           Data.Text                      ( Text )
 import           Haskus.Utils.Variant.Excepts
+import           Optics
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
@@ -511,7 +512,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
           HLS.SourceDist targetVer -> do
             GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
             let vi = getVersionInfo targetVer HLS dls
-            forM_ (_viPreCompile =<< vi) $ \msg -> do
+            forM_ (view viPreCompile =<< vi) $ \msg -> do
               lift $ logInfo msg
               lift $ logInfo
                 "...waiting for 5 seconds, you can still abort..."
@@ -539,7 +540,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
               VRight (vi, tv) -> do
                 runLogger $ logInfo
                   "HLS successfully compiled and installed"
-                forM_ (_viPostInstall =<< vi) $ \msg ->
+                forM_ (view viPostInstall =<< vi) $ \msg ->
                   runLogger $ logInfo msg
                 liftIO $ putStr (T.unpack $ prettyVer tv)
                 pure ExitSuccess
@@ -563,7 +564,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
           GHC.SourceDist targetVer -> do
             GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
             let vi = getVersionInfo targetVer GHC dls
-            forM_ (_viPreCompile =<< vi) $ \msg -> do
+            forM_ (view viPreCompile =<< vi) $ \msg -> do
               lift $ logInfo msg
               lift $ logInfo
                 "...waiting for 5 seconds, you can still abort..."
@@ -593,7 +594,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
               VRight (vi, tv) -> do
                 runLogger $ logInfo
                   "GHC successfully compiled and installed"
-                forM_ (_viPostInstall =<< vi) $ \msg ->
+                forM_ (view viPostInstall =<< vi) $ \msg ->
                   runLogger $ logInfo msg
                 liftIO $ putStr (T.unpack $ tVerToText tv)
                 pure ExitSuccess

app/ghcup/GHCup/OptParse/Install.hs

@@ -23,6 +23,7 @@ import           GHCup.Utils.Dirs
 import           GHCup.Prelude
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
+import           GHCup.Types.Optics
 
 import           Codec.Archive
 #if !MIN_VERSION_base(4,13,0)
@@ -36,6 +37,7 @@ import           Data.Maybe
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
+import           Optics
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
 import           URI.ByteString          hiding ( uriParser )
@@ -345,7 +347,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
         >>= \case
               VRight vi -> do
                 runLogger $ logInfo "GHC installation successful"
-                forM_ (_viPostInstall =<< vi) $ \msg ->
+                forM_ (view viPostInstall =<< vi) $ \msg ->
                   runLogger $ logInfo msg
                 pure ExitSuccess
 
@@ -413,7 +415,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
       >>= \case
             VRight vi -> do
               runLogger $ logInfo "Cabal installation successful"
-              forM_ (_viPostInstall =<< vi) $ \msg ->
+              forM_ (view viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
             VLeft e@(V (AlreadyInstalled _ _)) -> do
@@ -463,7 +465,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
       >>= \case
             VRight vi -> do
               runLogger $ logInfo "HLS installation successful"
-              forM_ (_viPostInstall =<< vi) $ \msg ->
+              forM_ (view viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
             VLeft e@(V (AlreadyInstalled _ _)) -> do
@@ -512,7 +514,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
       >>= \case
             VRight vi -> do
               runLogger $ logInfo "Stack installation successful"
-              forM_ (_viPostInstall =<< vi) $ \msg ->
+              forM_ (view viPostInstall =<< vi) $ \msg ->
                 runLogger $ logInfo msg
               pure ExitSuccess
             VLeft e@(V (AlreadyInstalled _ _)) -> do

app/ghcup/GHCup/OptParse/Rm.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
@@ -34,6 +33,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Optics
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -227,5 +227,5 @@ rm rmCommand runAppState runLogger = case rmCommand of
               pure $ ExitFailure 15
 
   postRmLog vi =
-    forM_ (_viPostRemove =<< vi) $ \msg ->
+    forM_ (view viPostRemove =<< vi) $ \msg ->
       runLogger $ logInfo msg

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -28,6 +28,7 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
+import           Optics ( view )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -144,7 +145,7 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
         let vi = fromJust $ snd <$> getLatest dls GHCup
         runLogger $ logInfo $
           "Successfully upgraded GHCup to version " <> pretty_v
-        forM_ (_viPostInstall vi) $ \msg ->
+        forM_ (view viPostInstall vi) $ \msg ->
           runLogger $ logInfo msg
         pure ExitSuccess
       VLeft (V NoUpdate) -> do

cabal.project

@@ -9,7 +9,7 @@ constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
 package libarchive
-  flags: -system-libarchive
+  flags: +system-libarchive
 
 package aeson-pretty
   flags: +lib-only

ghcup.cabal

@@ -258,6 +258,7 @@ executable ghcup
     , libarchive             ^>=3.0.3.0
     , megaparsec             >=8.0.0    && <9.3
     , mtl                    ^>=2.2
+    , optics                ^>=0.4
     , optparse-applicative   >=0.15.1.0 && <0.18
     , pretty                 ^>=1.1.3.1
     , pretty-terminal        ^>=0.1.0.0

lib/GHCup/Cabal.hs

@@ -177,7 +177,7 @@ installCabalBin :: ( MonadMask m
                    , MonadUnliftIO m
                    , MonadFail m
                    )
-                => Version
+                => VersionRev
                 -> InstallDir
                 -> Bool           -- force install
                 -> Excepts
@@ -198,7 +198,7 @@ installCabalBin :: ( MonadMask m
                      ()
 installCabalBin ver installDir forceInstall = do
   dlinfo <- liftE $ getDownloadInfo Cabal ver
-  installCabalBindist dlinfo ver installDir forceInstall
+  installCabalBindist dlinfo (vVersion ver) installDir forceInstall
 
 
     -----------------

lib/GHCup/Download.hs

@@ -277,19 +277,19 @@ getDownloadInfo :: ( MonadReader env m
                    , HasGHCupInfo env
                    )
                 => Tool
-                -> Version
+                -> VersionRev
                 -- ^ tool version
                 -> Excepts
                      '[NoDownload]
                      m
                      DownloadInfo
-getDownloadInfo t v = do
+getDownloadInfo t (VersionRev v vr) = do
   (PlatformRequest a p mv) <- lift getPlatformReq
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
 
   let distro_preview f g =
         let platformVersionSpec =
-              preview (ix t % ix v % viArch % ix a % ix (f p)) dls
+              preview (ix t % ix v % viDownload % ix vr % viArch % ix a % ix (f p)) dls
             mv' = g mv
         in  fmap snd
               .   find

lib/GHCup/GHC.hs

@@ -78,6 +78,7 @@ import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
+import qualified Data.Map.Strict               as M
 
 
 data GHCVer v = SourceDist v
@@ -105,7 +106,7 @@ testGHCVer :: ( MonadFail m
               , MonadIO m
               , MonadUnliftIO m
               )
-           => Version
+           => VersionRev
            -> [T.Text]
            -> Excepts
                 '[ DigestError
@@ -120,11 +121,11 @@ testGHCVer :: ( MonadFail m
                  ]
                 m
                 ()
-testGHCVer ver addMakeArgs = do
+testGHCVer (VersionRev ver vr) addMakeArgs = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
 
   dlInfo <-
-    preview (ix GHC % ix ver % viTestDL % _Just) dls
+    preview (ix GHC % ix ver % viDownload % to M.toAscList % maybe _last ix vr % to snd % viTestDL % _Just) dls
       ?? NoDownload
 
   liftE $ testGHCBindist dlInfo ver addMakeArgs
@@ -243,7 +244,7 @@ fetchGHCSrc :: ( MonadFail m
                , MonadIO m
                , MonadUnliftIO m
                )
-            => Version
+            => VersionRev
             -> Maybe FilePath
             -> Excepts
                  '[ DigestError
@@ -254,10 +255,10 @@ fetchGHCSrc :: ( MonadFail m
                   ]
                  m
                  FilePath
-fetchGHCSrc v mfp = do
+fetchGHCSrc (VersionRev v vr) mfp = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   dlInfo <-
-    preview (ix GHC % ix v % viSourceDL % _Just) dls
+    preview (ix GHC % ix v % viDownload % to M.toAscList % maybe _last ix vr % to snd % viSourceDL % _Just) dls
       ?? NoDownload
   liftE $ downloadCached' dlInfo Nothing mfp
 
@@ -804,7 +805,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
 
         -- download source tarball
         dlInfo <-
-          preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
+          preview (ix GHC % ix (tver ^. tvVersion) % viDownload % _last % viSourceDL % _Just) dls
             ?? NoDownload
         dl <- liftE $ downloadCached dlInfo Nothing
 

lib/GHCup/HLS.hs

@@ -368,7 +368,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 
       -- download source tarball
       dlInfo <-
-        preview (ix HLS % ix tver % viSourceDL % _Just) dls
+        preview (ix HLS % ix tver % viDownload % _last % viSourceDL % _Just) dls
           ?? NoDownload
       dl <- liftE $ downloadCached dlInfo Nothing
 

lib/GHCup/List.hs

@@ -308,7 +308,7 @@ listVersions lt' criteria = do
         isOld  = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
     in if | Map.member currentVer av -> Nothing
           | otherwise -> Just $ ListResult { lVer    = currentVer
-                                           , lTag    = maybe (if isOld then [Old] else []) _viTags listVer
+                                           , lTag    = maybe (if isOld then [Old] else []) (view viTags) listVer
                                            , lCross  = Nothing
                                            , lTool   = GHCup
                                            , fromSrc = False
@@ -337,7 +337,8 @@ listVersions lt' criteria = do
                -> [Either FilePath Version]
                -> (Version, VersionInfo)
                -> m ListResult
-  toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
+  toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, vi) = do
+    let tags = view viTags vi
     case t of
       GHC -> do
         lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v

lib/GHCup/Prelude/MegaParsec.hs

@@ -28,6 +28,8 @@ import           System.FilePath
 import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
 import qualified Text.Megaparsec               as MP
+import Data.Char (digitToInt)
+import Data.Data (Proxy(..))
 
 
 choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
@@ -86,7 +88,33 @@ ghcTargetVerP =
     <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
         <|> ((\ _ x -> x) Nothing <$> mempty)
         )
-    <*> (version' <* MP.eof)
+    <*> version'
+ where
+  verP' :: MP.Parsec Void Text Text
+  verP' = do
+    v <- version'
+    let startsWithDigists =
+          and
+            . take 3
+            . concatMap
+              (map
+                (\case
+                  (Digits _) -> True
+                  (Str    _) -> False
+                ) . NE.toList)
+            . NE.toList
+            $ _vChunks v
+    if startsWithDigists && isNothing (_vEpoch v)
+      then pure $ prettyVer v
+      else fail "Oh"
+
+ghcTargetVerRevP :: MP.Parsec Void Text GHCTargetVersionRev
+ghcTargetVerRevP =
+  (\x y -> GHCTargetVersionRev x y)
+    <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
+        <|> ((\ _ x -> x) Nothing <$> mempty)
+        )
+    <*> versionRevP
  where
   verP' :: MP.Parsec Void Text Text
   verP' = do
@@ -122,3 +150,44 @@ verP suffix = do
 
 pathSep :: MP.Parsec Void Text Char
 pathSep = MP.oneOf pathSeparators
+
+versionRevP :: MP.Parsec Void Text VersionRev
+versionRevP = MP.label "versionRev" $
+  MP.try (parseUntil (MP.try (MP.chunk "-r")) >>= versionWithRev) <|> ((`VersionRev` 0) <$> version')
+ where
+  versionWithRev ver = do
+    rest <- MP.getInput
+    MP.setInput ver
+    v <- version'
+    MP.setInput rest
+    _ <- MP.chunk "-r"
+    rev <- parseInt
+    pure $ VersionRev v rev
+
+  digit = MP.oneOf ['0'..'9'] MP.<?> "digit"
+  parseInt :: MP.Parsec Void Text Int
+  parseInt = MP.label "parseInt" $ do
+    i <- MP.tokensToChunk (Proxy :: Proxy Text) <$> some digit
+    pure $ numberValue 10 $ T.unpack i
+
+  numberValue :: Int -> String -> Int
+  numberValue base = foldl (\ x -> ((fromIntegral base * x) +) . fromIntegral . digitToInt) 0
+
+userVersionRevP :: MP.Parsec Void Text UserVersionRev
+userVersionRevP = MP.label "userVersionRev" $
+  ((\(VersionRev v r) -> UserVersionRev v (Just r)) <$> MP.try versionRevP) <|> ((`UserVersionRev` Nothing) <$> version')
+
+
+-- | Read a @VersionRev@ from a String.
+--
+-- - 3.3.2    -> VersionRev { vVersion = 3.3.3, vRev = 0 }
+-- - 2.3.4-r3 -> VersionRev { vVersion = 2.3.4, vRev = 3 }
+versionRev :: Text -> Either (MP.ParseErrorBundle Text Void) VersionRev
+versionRev = MP.parse versionRevP ""
+
+-- | Read a @UserVersionRev@ from a String.
+--
+-- - 3.3.2    -> UserVersionRev { vVersion = 3.3.3, vRev = Nothing }
+-- - 2.3.4-r3 -> UserVersionRev { vVersion = 2.3.4, vRev = Just 3 }
+userVersionRev :: Text -> Either (MP.ParseErrorBundle Text Void) UserVersionRev
+userVersionRev = MP.parse userVersionRevP ""

lib/GHCup/Types.hs

@@ -44,6 +44,8 @@ import           Graphics.Vty                   ( Key(..) )
 import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Text                     as T
 import qualified GHC.Generics                  as GHC
+import qualified Data.Map.Strict               as M
+
 
 
 #if !defined(BRICK)
@@ -135,6 +137,19 @@ instance NFData GlobalTool
 -- | All necessary information of a tool version, including
 -- source download and per-architecture downloads.
 data VersionInfo = VersionInfo
+  { _viTags        :: [Tag]              -- ^ version specific tag
+  , _viChangeLog   :: Maybe URI
+  , _viDownload    :: Map Int VersionDownload
+  -- informative messages
+  , _viPostInstall :: Maybe Text
+  , _viPostRemove  :: Maybe Text
+  , _viPreCompile  :: Maybe Text
+  }
+  deriving (Eq, GHC.Generic, Show)
+
+instance NFData VersionInfo
+
+data VersionInfoLegacy = VersionInfoLegacy
   { _viTags        :: [Tag]              -- ^ version specific tag
   , _viChangeLog   :: Maybe URI
   , _viSourceDL    :: Maybe DownloadInfo -- ^ source tarball
@@ -147,7 +162,47 @@ data VersionInfo = VersionInfo
   }
   deriving (Eq, GHC.Generic, Show)
 
-instance NFData VersionInfo
+data VersionDownload = VersionDownload
+  { _viSourceDL    :: Maybe DownloadInfo -- ^ source tarball
+  , _viTestDL      :: Maybe DownloadInfo -- ^ test tarball
+  , _viArch        :: ArchitectureSpec   -- ^ descend for binary downloads per arch
+
+  }
+  deriving (Eq, GHC.Generic, Show)
+
+instance NFData VersionDownload
+
+fromVersionInfoLegacy :: VersionInfoLegacy -> VersionInfo
+fromVersionInfoLegacy VersionInfoLegacy{..} =
+  VersionInfo {_viDownload = M.singleton 0 $ VersionDownload { _viSourceDL = _viSourceDL
+                                                             , _viTestDL = _viTestDL
+                                                             , _viArch = _viArch
+                                                             }
+              , ..}
+
+
+-- | A version with a revision, denoting bindist 'versions' that are purely distribution specific.
+--
+-- The revision starts at 0.
+data VersionRev = VersionRev { vVersion :: Version, vRev :: Int }
+  deriving (Ord, Eq, GHC.Generic, Show)
+
+showVersionRev :: VersionRev -> Text
+showVersionRev (VersionRev v 0) = prettyVer v
+showVersionRev (VersionRev v r) = prettyVer v <> "-r" <> T.pack (show r)
+
+-- | Similar to @VersionRev@, except that revision is optional. The absence of a revision has
+-- a particular meaning:
+--
+-- * for install/prefetch: we want the latest available revision
+-- * for compile: it depends
+-- * for rm/set/unset/whereis/changelog: we want the revision that is installed (there can be only one)
+--
+-- Translating @UserVersionRev@ to @VersionRev@ requires context of the GHCup metadata,
+-- installed versions and the to be executed command.
+data UserVersionRev = UserVersionRev { uvVersion :: Version, uvRev :: Maybe Int }
+  deriving (Ord, Eq, GHC.Generic, Show)
+
 
 
 -- | A tag. These are currently attached to a version of a tool.
@@ -586,12 +641,6 @@ data GHCTargetVersion = GHCTargetVersion
   }
   deriving (Ord, Eq, Show)
 
-data GitBranch = GitBranch
-  { ref  :: String
-  , repo :: Maybe String
-  }
-  deriving (Ord, Eq, Show)
-
 mkTVer :: Version -> GHCTargetVersion
 mkTVer = GHCTargetVersion Nothing
 
@@ -599,10 +648,30 @@ tVerToText :: GHCTargetVersion -> Text
 tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
 tVerToText (GHCTargetVersion Nothing  v') = prettyVer v'
 
+-- | A GHC identified by the target platform triple
+-- and the version.
+data GHCTargetVersionRev = GHCTargetVersionRev
+  { _tvTargetRev  :: Maybe Text
+  , _tvVersionRev :: VersionRev
+  }
+  deriving (Ord, Eq, Show)
+
+mkTVerRev :: VersionRev -> GHCTargetVersionRev
+mkTVerRev = GHCTargetVersionRev Nothing
+
+tVerRevToText :: GHCTargetVersionRev -> Text
+tVerRevToText (GHCTargetVersionRev (Just t) v') = t <> "-" <> showVersionRev v'
+tVerRevToText (GHCTargetVersionRev Nothing  v') = showVersionRev v'
+
 -- | Assembles a path of the form: <target-triple>-<version>
 instance Pretty GHCTargetVersion where
   pPrint = text . T.unpack . tVerToText
 
+data GitBranch = GitBranch
+  { ref  :: String
+  , repo :: Maybe String
+  }
+  deriving (Ord, Eq, Show)
 
 -- | A comparator and a version.
 data VersionCmp = VR_gt Versioning

lib/GHCup/Types/JSON.hs

@@ -320,11 +320,18 @@ instance FromJSONKey (Maybe VersionRange)  where
       Right x -> pure $ Just x
       Left  e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
 
-
-
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfoLegacy
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionDownload
+
+instance FromJSON VersionInfo where
+  parseJSON v = parseLegacy v <|> parseNew v
+   where
+    parseLegacy = fmap fromVersionInfoLegacy . parseJSON @VersionInfoLegacy
+    parseNew = genericParseJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel }
+
+deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
 deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key

lib/GHCup/Types/Optics.hs

@@ -37,6 +37,7 @@ makeLenses ''PlatformResult
 makeLenses ''DownloadInfo
 makeLenses ''Tag
 makeLenses ''VersionInfo
+makeLenses ''VersionDownload
 
 makeLenses ''GHCTargetVersion
 

lib/GHCup/Utils.hs

@@ -160,7 +160,7 @@ rmMinorGHCSymlinks :: ( MonadReader env m
 rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do
   Dirs {..}  <- lift getDirs
 
-  files                         <- liftE $ ghcToolFiles tv
+  files <- liftE $ ghcToolFiles tv
   forM_ files $ \f -> do
     let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
     let fullF = binDir </> f_xyz
@@ -181,7 +181,7 @@ rmPlainGHC :: ( MonadReader env m
            -> Excepts '[NotInstalled] m ()
 rmPlainGHC target = do
   Dirs {..}  <- lift getDirs
-  mtv                           <- lift $ ghcSet target
+  mtv <- lift $ ghcSet target
   forM_ mtv $ \tv -> do
     files <- liftE $ ghcToolFiles tv
     forM_ files $ \f -> do
@@ -228,7 +228,7 @@ rmMinorHLSSymlinks :: ( MonadReader env m
                       , MonadFail m
                       , MonadMask m
                       )
-                   => Version
+                   => VersionRev
                    -> Excepts '[NotInstalled] m ()
 rmMinorHLSSymlinks ver = do
   Dirs {..}  <- lift getDirs
@@ -281,7 +281,7 @@ rmPlainHLS = do
     -----------------------------------
 
 
--- | Whether the given GHC versin is installed.
+-- | Whether the given GHC version is installed.
 ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
 ghcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
@@ -299,7 +299,7 @@ ghcSrcInstalled ver = do
 ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
        => Maybe Text   -- ^ the target of the GHC version, if any
                        --  (e.g. armv7-unknown-linux-gnueabihf)
-       -> m (Maybe GHCTargetVersion)
+       -> m (Maybe GHCTargetVersionRev)
 ghcSet mtarget = do
   Dirs {..}  <- getDirs
   let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
@@ -311,7 +311,7 @@ ghcSet mtarget = do
     link <- liftIO $ getLinkTarget ghcBin
     Just <$> ghcLinkVersion link
  where
-  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
+  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersionRev
   ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
    where
     parser =
@@ -321,7 +321,7 @@ ghcSet mtarget = do
            r    <- parseUntil1 pathSep
            rest <- MP.getInput
            MP.setInput r
-           x <- ghcTargetVerP
+           x <- ghcTargetVerRevP
            MP.setInput rest
            pure x
          )
@@ -347,13 +347,13 @@ getInstalledCabals :: ( MonadReader env m
                       , MonadIO m
                       , MonadCatch m
                       )
-                   => m [Either FilePath Version]
+                   => m [Either FilePath VersionRev]
 getInstalledCabals = do
   Dirs {..} <- getDirs
   bins   <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
-  vs <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
+  vs <- forM bins $ \f -> case versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of
     Just (Right r) -> pure $ Right r
     Just (Left  _) -> pure $ Left f
     Nothing        -> pure $ Left f
@@ -361,14 +361,14 @@ getInstalledCabals = do
 
 
 -- | Whether the given cabal version is installed.
-cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
+cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
 cabalInstalled ver = do
   vers <- fmap rights getInstalledCabals
   pure $ elem ver vers
 
 
 -- Return the currently set cabal version, if any.
-cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
+cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe VersionRev)
 cabalSet = do
   Dirs {..}  <- getDirs
   let cabalbin = binDir </> "cabal" <> exeExt
@@ -395,7 +395,7 @@ cabalSet = do
   -- We try to be extra permissive with link destination parsing,
   -- because of:
   --   https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
-  linkVersion :: MonadThrow m => FilePath -> m Version
+  linkVersion :: MonadThrow m => FilePath -> m VersionRev
   linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt
 
   parser
@@ -403,7 +403,7 @@ cabalSet = do
     <|> MP.try (stripRelativePath *> cabalParse)
     <|> cabalParse
   -- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
-  cabalParse = MP.chunk "cabal-" *> version'
+  cabalParse = MP.chunk "cabal-" *> versionRevP
   -- parses any path component ending with path separator,
   -- e.g. "foo/"
   stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
@@ -420,7 +420,7 @@ cabalSet = do
 -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
 -- as well as @~\/.ghcup\/hls\/<\hlsver\>@
 getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
-                 => m [Either FilePath Version]
+                 => m [Either FilePath VersionRev]
 getInstalledHLSs = do
   Dirs {..}  <- getDirs
   bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -431,7 +431,7 @@ getInstalledHLSs = do
     )
   legacy <- forM bins $ \f ->
     case
-          version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
+          versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
       of
         Just (Right r) -> pure $ Right r
         Just (Left  _) -> pure $ Left f
@@ -448,7 +448,7 @@ getInstalledHLSs = do
 -- | Get all installed stacks, by matching on
 -- @~\/.ghcup\/bin/stack-<\stackver\>@.
 getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
-                   => m [Either FilePath Version]
+                   => m [Either FilePath VersionRev]
 getInstalledStacks = do
   Dirs {..}  <- getDirs
   bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -458,7 +458,7 @@ getInstalledStacks = do
                    ([s|^stack-.*$|] :: ByteString)
     )
   forM bins $ \f ->
-    case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
+    case versionRev . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of
         Just (Right r) -> pure $ Right r
         Just (Left  _) -> pure $ Left f
         Nothing        -> pure $ Left f
@@ -509,13 +509,13 @@ stackSet = do
     stripRelativePath = MP.many (MP.try stripPathComponet)
 
 -- | Whether the given Stack version is installed.
-stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
+stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
 stackInstalled ver = do
   vers <- fmap rights getInstalledStacks
   pure $ elem ver vers
 
 -- | Whether the given HLS version is installed.
-hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
+hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => VersionRev -> m Bool
 hlsInstalled ver = do
   vers <- fmap rights getInstalledHLSs
   pure $ elem ver vers
@@ -527,7 +527,7 @@ isLegacyHLS ver = do
 
 
 -- Return the currently set hls version, if any.
-hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
+hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe VersionRev)
 hlsSet = do
   Dirs {..}  <- getDirs
   let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
@@ -540,7 +540,7 @@ hlsSet = do
         link <- liftIO $ getLinkTarget hlsBin
         Just <$> linkVersion link
  where
-  linkVersion :: MonadThrow m => FilePath -> m Version
+  linkVersion :: MonadThrow m => FilePath -> m VersionRev
   linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
    where
     parser
@@ -548,7 +548,7 @@ hlsSet = do
       <|> MP.try (stripRelativePath *> cabalParse)
       <|> cabalParse
     -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0"
-    cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version'
+    cabalParse = MP.chunk "haskell-language-server-wrapper-" *> versionRevP
     -- parses any path component ending with path separator,
     -- e.g. "foo/"
     stripPathComponet = parseUntil1 pathSep *> MP.some pathSep
@@ -567,7 +567,7 @@ hlsGHCVersions :: ( MonadReader env m
                   , MonadThrow m
                   , MonadCatch m
                   )
-               => m [Version]
+               => m [VersionRev]
 hlsGHCVersions = do
   h <- hlsSet
   fromMaybe [] <$> forM h hlsGHCVersions'
@@ -579,12 +579,12 @@ hlsGHCVersions' :: ( MonadReader env m
                    , MonadThrow m
                    , MonadCatch m
                    )
-                => Version
-                -> m [Version]
+                => VersionRev
+                -> m [VersionRev]
 hlsGHCVersions' v' = do
   bins <- hlsServerBinaries v' Nothing
   let vers = fmap
-        (version
+        (versionRev
           . T.pack
           . fromJust
           . stripPrefix "haskell-language-server-"
@@ -597,10 +597,10 @@ hlsGHCVersions' v' = do
 
 -- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
 hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
-                  => Version
+                  => VersionRev
                   -> Maybe Version   -- ^ optional GHC version
                   -> m [FilePath]
-hlsServerBinaries ver mghcVer = do
+hlsServerBinaries (VersionRev ver rv) mghcVer = do
   Dirs {..}  <- getDirs
   liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
@@ -611,6 +611,7 @@ hlsServerBinaries ver mghcVer = do
         <> maybe [s|.*|] escapeVerRex mghcVer
         <> [s|~|]
         <> escapeVerRex ver
+        <> E.encodeUtf8 (T.pack ("-r" <> show rv))
         <> E.encodeUtf8 (T.pack exeExt)
         <> [s|$|] :: ByteString
       )
@@ -657,16 +658,20 @@ hlsInternalServerLibs ver ghcVer = do
 
 -- | Get the wrapper binary for an hls version, if any.
 hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
-                 => Version
+                 => VersionRev
                  -> m (Maybe FilePath)
-hlsWrapperBinary ver = do
+hlsWrapperBinary (VersionRev ver rv) = do
   Dirs {..}  <- getDirs
   wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts
       compExtended
       execBlank
-      ([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
+      ([s|^haskell-language-server-wrapper-|]
+      <> escapeVerRex ver
+      <> E.encodeUtf8 (T.pack ("-r" <> show rv))
+      <> E.encodeUtf8 (T.pack exeExt)
+      <> [s|$|] :: ByteString
       )
     )
   case wrapper of
@@ -677,7 +682,7 @@ hlsWrapperBinary ver = do
 
 
 -- | Get all binaries for an hls version, if any.
-hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
+hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => VersionRev -> m [FilePath]
 hlsAllBinaries ver = do
   hls     <- hlsServerBinaries ver Nothing
   wrapper <- hlsWrapperBinary ver
@@ -781,6 +786,9 @@ getLatestToolFor tool pvpIn dls = do
   let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
   pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps
 
+-- type ToolVersionSpec = Map Version ToolRevisionSpec
+-- type ToolRevisionSpec = Map Int VersionInfo
+
 
 
 
@@ -927,7 +935,7 @@ ghcInternalBinDir ver = do
 --
 --   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
 ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
-             => GHCTargetVersion
+             => GHCTargetVersionRev
              -> Excepts '[NotInstalled] m [FilePath]
 ghcToolFiles ver = do
   bindir <- ghcInternalBinDir ver
@@ -1285,7 +1293,7 @@ warnAboutHlsCompatibility :: ( MonadReader env m
                           => m ()
 warnAboutHlsCompatibility = do
   supportedGHC <- hlsGHCVersions
-  currentGHC   <- fmap _tvVersion <$> ghcSet Nothing
+  currentGHC   <- fmap _tvVersionRev <$> ghcSet Nothing
   currentHLS   <- hlsSet
 
   case (currentGHC, currentHLS) of

lib/GHCup/Utils/Dirs.hs

@@ -417,9 +417,9 @@ parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
 parseGHCupGHCDir (T.pack -> fp) =
   throwEither $ MP.parse ghcTargetVerP "" fp
 
-parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
+parseGHCupHLSDir :: MonadThrow m => FilePath -> m VersionRev
 parseGHCupHLSDir (T.pack -> fp) =
-  throwEither $ MP.parse version' "" fp
+  throwEither $ versionRev fp
 
 -- TODO: inlined from GHCup.Prelude
 throwEither :: (Exception a, MonadThrow m) => Either a b -> m b

test/GHCup/ArbitraryTypes.hs

@@ -147,6 +147,10 @@ instance Arbitrary Architecture where
   arbitrary = genericArbitrary
   shrink    = genericShrink
 
+instance Arbitrary VersionDownload where
+  arbitrary = genericArbitrary
+  shrink    = genericShrink
+
 instance Arbitrary VersionInfo where
   arbitrary = genericArbitrary
   shrink    = genericShrink