From 5fcd687751f247a4d1bb8f9f9e75d8ada941ab91 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 26 Feb 2023 23:28:25 +0800 Subject: [PATCH] Firs draft of implementing revisions --- app/ghcup/BrickMain.hs | 9 ++++---- app/ghcup/GHCup/OptParse/Common.hs | 3 ++- app/ghcup/GHCup/OptParse/Compile.hs | 11 +++++----- app/ghcup/GHCup/OptParse/Install.hs | 10 +++++---- app/ghcup/GHCup/OptParse/Rm.hs | 4 ++-- app/ghcup/GHCup/OptParse/Upgrade.hs | 3 ++- ghcup.cabal | 1 + lib/GHCup/Download.hs | 3 ++- lib/GHCup/GHC.hs | 9 +++++--- lib/GHCup/HLS.hs | 3 ++- lib/GHCup/List.hs | 5 +++-- lib/GHCup/Types.hs | 33 ++++++++++++++++++++++++++++- lib/GHCup/Types/JSON.hs | 13 +++++++++--- lib/GHCup/Types/Optics.hs | 1 + lib/GHCup/Utils.hs | 3 +++ 15 files changed, 83 insertions(+), 28 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index b23350ed..eb08d743 100644 --- a/app/ghcup/BrickMain.hs +++ b/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) diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index 4d0e5f3e..7b9223f4 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/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) diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index f9f114be..23b7d4c8 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/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 diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 9e54cbe2..ca10edcc 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/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 diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index fa756f7d..2e0982e5 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/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 diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs index 8849700b..d7898f6b 100644 --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/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 diff --git a/ghcup.cabal b/ghcup.cabal index b134430d..0cea99e8 100644 --- a/ghcup.cabal +++ b/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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 4e9bd31a..3fc06da0 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -289,7 +289,8 @@ getDownloadInfo t v = do let distro_preview f g = let platformVersionSpec = - preview (ix t % ix v % viArch % ix a % ix (f p)) dls + -- TODO + preview (ix t % ix v % viDownload % ix 0 % viArch % ix a % ix (f p)) dls mv' = g mv in fmap snd . find diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index aefc1c7d..af86df4a 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -124,7 +124,8 @@ testGHCVer ver addMakeArgs = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo dlInfo <- - preview (ix GHC % ix ver % viTestDL % _Just) dls + -- TODO + preview (ix GHC % ix ver % viDownload % ix 0 % viTestDL % _Just) dls ?? NoDownload liftE $ testGHCBindist dlInfo ver addMakeArgs @@ -257,7 +258,8 @@ fetchGHCSrc :: ( MonadFail m fetchGHCSrc v mfp = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo dlInfo <- - preview (ix GHC % ix v % viSourceDL % _Just) dls + -- TODO + preview (ix GHC % ix v % viDownload % ix 0 % viSourceDL % _Just) dls ?? NoDownload liftE $ downloadCached' dlInfo Nothing mfp @@ -804,7 +806,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr -- download source tarball dlInfo <- - preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls + -- TODO + preview (ix GHC % ix (tver ^. tvVersion) % viDownload % ix 0 % viSourceDL % _Just) dls ?? NoDownload dl <- liftE $ downloadCached dlInfo Nothing diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 083f558c..d47d1332 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -368,7 +368,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda -- download source tarball dlInfo <- - preview (ix HLS % ix tver % viSourceDL % _Just) dls + -- TODO + preview (ix HLS % ix tver % viDownload % ix 0 % viSourceDL % _Just) dls ?? NoDownload dl <- liftE $ downloadCached dlInfo Nothing diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs index 91ba3818..538a2b61 100644 --- a/lib/GHCup/List.hs +++ b/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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 06705a65..52aebb8a 100644 --- a/lib/GHCup/Types.hs +++ b/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,23 @@ 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 tag. These are currently attached to a version of a tool. diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 53b2fc3d..3954b36e 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/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 diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index f6887b20..76dab1b9 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -37,6 +37,7 @@ makeLenses ''PlatformResult makeLenses ''DownloadInfo makeLenses ''Tag makeLenses ''VersionInfo +makeLenses ''VersionDownload makeLenses ''GHCTargetVersion diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 4a78b62a..266d7070 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -781,6 +781,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 +