First draft of implementing revisions

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