hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

First draft of implementing revisions

Browse Source
This commit is contained in:
Julian Ospald 2023-02-26 23:28:25 +08:00
parent 784942ca58
commit e0222b4007
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
18 changed files with 21835 additions and 21360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
app/ghcup/BrickMain.hs
View File

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

3
app/ghcup/GHCup/OptParse/Common.hs
View File

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

11
app/ghcup/GHCup/OptParse/Compile.hs
View File

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

10
app/ghcup/GHCup/OptParse/Install.hs
View File

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

4
app/ghcup/GHCup/OptParse/Rm.hs
View File

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

3
app/ghcup/GHCup/OptParse/Upgrade.hs
View File

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

1
ghcup.cabal
View File

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

3
lib/GHCup/Download.hs
View File

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

9
lib/GHCup/GHC.hs
View File

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

3
lib/GHCup/HLS.hs
View File

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

5
lib/GHCup/List.hs
View File

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

33
lib/GHCup/Types.hs
View File

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

13
lib/GHCup/Types/JSON.hs
View File

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

1
lib/GHCup/Types/Optics.hs
View File

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

3
lib/GHCup/Utils.hs
View File

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

4
test/GHCup/ArbitraryTypes.hs
View File

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

21064
test/golden/unix/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff

22016
test/golden/windows/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff