Skip to content

Commit 9fbce0c

Browse files
hasufellhasufell
committed
First draft of implementing revisions
1 parent 784942c commit 9fbce0c

File tree

16 files changed

+87
-28
lines changed

16 files changed

+87
-28
lines changed

‎app/ghcup/BrickMain.hs

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ module BrickMain where
1111
import GHCup
1212
import GHCup.Download
1313
import GHCup.Errors
14-
import GHCup.Types.Optics ( getDirs )
1514
import GHCup.Types hiding ( LeanAppState(..) )
1615
import GHCup.Utils
1716
import GHCup.OptParse.Common (logGHCPostRm)
@@ -20,6 +19,7 @@ import GHCup.Prelude.File
2019
import GHCup.Prelude.Logger
2120
import GHCup.Prelude.Process
2221
import GHCup.Prompts
22+
import GHCup.Types.Optics hiding ( getGHCupInfo )
2323

2424
import Brick
2525
import Brick.Widgets.Border
@@ -53,6 +53,7 @@ import System.Exit
5353
import System.IO.Unsafe
5454
import Text.PrettyPrint.HughesPJClass ( prettyShow )
5555
import URI.ByteString
56+
import Optics ( view )
5657

5758
import qualified Data.Text as T
5859
import qualified Data.Text.Lazy.Builder as B
@@ -477,7 +478,7 @@ install' _ (_, ListResult {..}) = do
477478
)
478479
>>= \case
479480
VRight (vi, Dirs{..}, Just ce) -> do
480-
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
481+
forM_ (view viPostInstall =<< vi) $ \msg -> logInfo msg
481482
case lTool of
482483
GHCup -> do
483484
up <- liftIO $ fmap (either (const Nothing) Just)
@@ -489,7 +490,7 @@ install' _ (_, ListResult {..}) = do
489490
_ -> pure ()
490491
pure $ Right ()
491492
VRight (vi, _, _) -> do
492-
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
493+
forM_ (view viPostInstall =<< vi) $ \msg -> logInfo msg
493494
logInfo "Please restart 'ghcup' for the changes to take effect"
494495
pure $ Right ()
495496
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
@@ -564,7 +565,7 @@ del' _ (_, ListResult {..}) = do
564565
>>= \case
565566
VRight vi -> do
566567
logGHCPostRm (mkTVer lVer)
567-
forM_ (_viPostRemove =<< vi) $ \msg ->
568+
forM_ (view viPostRemove =<< vi) $ \msg ->
568569
logInfo msg
569570
pure $ Right ()
570571
VLeft e -> pure $ Left (prettyHFError e)

‎app/ghcup/GHCup/OptParse/Common.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ import System.Process ( readProcess )
5757
import System.FilePath
5858
import Text.HTML.TagSoup hiding ( Tag )
5959
import URI.ByteString
60+
import Optics ( view )
6061

6162
import qualified Data.ByteString.UTF8 as UTF8
6263
import qualified Data.Map.Strict as M
@@ -451,7 +452,7 @@ tagCompleter tool add = listIOCompleter $ do
451452
case mGhcUpInfo of
452453
VRight ghcupInfo -> do
453454
let allTags = filter (/= Old)
454-
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
455+
$ (view viTags) =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
455456
pure $ nub $ (add ++) $ fmap tagToString allTags
456457
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
457458

‎app/ghcup/GHCup/OptParse/Compile.hs

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -16,11 +16,11 @@ import qualified GHCup.GHC as GHC
1616
import qualified GHCup.HLS as HLS
1717
import GHCup.Errors
1818
import GHCup.Types
19-
import GHCup.Types.Optics
2019
import GHCup.Utils
2120
import GHCup.Prelude.Logger
2221
import GHCup.Prelude.String.QQ
2322
import GHCup.OptParse.Common
23+
import GHCup.Types.Optics
2424

2525
#if !MIN_VERSION_base(4,13,0)
2626
import Control.Monad.Fail ( MonadFail )
@@ -36,6 +36,7 @@ import Data.Versions ( Version, prettyVer, version, p
3636
import qualified Data.Versions as V
3737
import Data.Text ( Text )
3838
import Haskus.Utils.Variant.Excepts
39+
import Optics
3940
import Options.Applicative hiding ( style )
4041
import Options.Applicative.Help.Pretty ( text )
4142
import Prelude hiding ( appendFile )
@@ -511,7 +512,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
511512
HLS.SourceDist targetVer -> do
512513
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
513514
let vi = getVersionInfo targetVer HLS dls
514-
forM_ (_viPreCompile =<< vi) $ \msg -> do
515+
forM_ (view viPreCompile =<< vi) $ \msg -> do
515516
lift $ logInfo msg
516517
lift $ logInfo
517518
"...waiting for 5 seconds, you can still abort..."
@@ -539,7 +540,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
539540
VRight (vi, tv) -> do
540541
runLogger $ logInfo
541542
"HLS successfully compiled and installed"
542-
forM_ (_viPostInstall =<< vi) $ \msg ->
543+
forM_ (view viPostInstall =<< vi) $ \msg ->
543544
runLogger $ logInfo msg
544545
liftIO $ putStr (T.unpack $ prettyVer tv)
545546
pure ExitSuccess
@@ -563,7 +564,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
563564
GHC.SourceDist targetVer -> do
564565
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
565566
let vi = getVersionInfo targetVer GHC dls
566-
forM_ (_viPreCompile =<< vi) $ \msg -> do
567+
forM_ (view viPreCompile =<< vi) $ \msg -> do
567568
lift $ logInfo msg
568569
lift $ logInfo
569570
"...waiting for 5 seconds, you can still abort..."
@@ -593,7 +594,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
593594
VRight (vi, tv) -> do
594595
runLogger $ logInfo
595596
"GHC successfully compiled and installed"
596-
forM_ (_viPostInstall =<< vi) $ \msg ->
597+
forM_ (view viPostInstall =<< vi) $ \msg ->
597598
runLogger $ logInfo msg
598599
liftIO $ putStr (T.unpack $ tVerToText tv)
599600
pure ExitSuccess

‎app/ghcup/GHCup/OptParse/Install.hs

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import GHCup.Utils.Dirs
2323
import GHCup.Prelude
2424
import GHCup.Prelude.Logger
2525
import GHCup.Prelude.String.QQ
26+
import GHCup.Types.Optics
2627

2728
import Codec.Archive
2829
#if !MIN_VERSION_base(4,13,0)
@@ -36,6 +37,7 @@ import Data.Maybe
3637
import Haskus.Utils.Variant.Excepts
3738
import Options.Applicative hiding ( style )
3839
import Options.Applicative.Help.Pretty ( text )
40+
import Optics
3941
import Prelude hiding ( appendFile )
4042
import System.Exit
4143
import URI.ByteString hiding ( uriParser )
@@ -345,7 +347,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
345347
>>= \case
346348
VRight vi -> do
347349
runLogger $ logInfo "GHC installation successful"
348-
forM_ (_viPostInstall =<< vi) $ \msg ->
350+
forM_ (view viPostInstall =<< vi) $ \msg ->
349351
runLogger $ logInfo msg
350352
pure ExitSuccess
351353

@@ -413,7 +415,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
413415
>>= \case
414416
VRight vi -> do
415417
runLogger $ logInfo "Cabal installation successful"
416-
forM_ (_viPostInstall =<< vi) $ \msg ->
418+
forM_ (view viPostInstall =<< vi) $ \msg ->
417419
runLogger $ logInfo msg
418420
pure ExitSuccess
419421
VLeft e@(V (AlreadyInstalled _ _)) -> do
@@ -463,7 +465,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
463465
>>= \case
464466
VRight vi -> do
465467
runLogger $ logInfo "HLS installation successful"
466-
forM_ (_viPostInstall =<< vi) $ \msg ->
468+
forM_ (view viPostInstall =<< vi) $ \msg ->
467469
runLogger $ logInfo msg
468470
pure ExitSuccess
469471
VLeft e@(V (AlreadyInstalled _ _)) -> do
@@ -512,7 +514,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
512514
>>= \case
513515
VRight vi -> do
514516
runLogger $ logInfo "Stack installation successful"
515-
forM_ (_viPostInstall =<< vi) $ \msg ->
517+
forM_ (view viPostInstall =<< vi) $ \msg ->
516518
runLogger $ logInfo msg
517519
pure ExitSuccess
518520
VLeft e@(V (AlreadyInstalled _ _)) -> do

‎app/ghcup/GHCup/OptParse/Rm.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@
33
{-# LANGUAGE TypeApplications #-}
44
{-# LANGUAGE FlexibleContexts #-}
55
{-# LANGUAGE OverloadedStrings #-}
6-
{-# LANGUAGE TemplateHaskell #-}
76
{-# LANGUAGE QuasiQuotes #-}
87
{-# LANGUAGE DuplicateRecordFields #-}
98
{-# LANGUAGE RankNTypes #-}
@@ -34,6 +33,7 @@ import Haskus.Utils.Variant.Excepts
3433
import Options.Applicative hiding ( style )
3534
import Prelude hiding ( appendFile )
3635
import System.Exit
36+
import Optics
3737

3838
import qualified Data.Text as T
3939
import Control.Exception.Safe (MonadMask)
@@ -227,5 +227,5 @@ rm rmCommand runAppState runLogger = case rmCommand of
227227
pure $ ExitFailure 15
228228

229229
postRmLog vi =
230-
forM_ (_viPostRemove =<< vi) $ \msg ->
230+
forM_ (view viPostRemove =<< vi) $ \msg ->
231231
runLogger $ logInfo msg

‎app/ghcup/GHCup/OptParse/Upgrade.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import Haskus.Utils.Variant.Excepts
2828
import Options.Applicative hiding ( style )
2929
import Prelude hiding ( appendFile )
3030
import System.Exit
31+
import Optics ( view )
3132

3233
import qualified Data.Text as T
3334
import Control.Exception.Safe (MonadMask)
@@ -144,7 +145,7 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
144145
let vi = fromJust $ snd <$> getLatest dls GHCup
145146
runLogger $ logInfo $
146147
"Successfully upgraded GHCup to version " <> pretty_v
147-
forM_ (_viPostInstall vi) $ \msg ->
148+
forM_ (view viPostInstall vi) $ \msg ->
148149
runLogger $ logInfo msg
149150
pure ExitSuccess
150151
VLeft (V NoUpdate) -> do

‎ghcup.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -258,6 +258,7 @@ executable ghcup
258258
, libarchive ^>=3.0.3.0
259259
, megaparsec >=8.0.0 && <9.3
260260
, mtl ^>=2.2
261+
, optics ^>=0.4
261262
, optparse-applicative >=0.15.1.0 && <0.18
262263
, pretty ^>=1.1.3.1
263264
, pretty-terminal ^>=0.1.0.0

‎lib/GHCup/Download.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -289,7 +289,8 @@ getDownloadInfo t v = do
289289

290290
let distro_preview f g =
291291
let platformVersionSpec =
292-
preview (ix t % ix v % viArch % ix a % ix (f p)) dls
292+
-- TODO
293+
preview (ix t % ix v % viDownload % ix 0 % viArch % ix a % ix (f p)) dls
293294
mv' = g mv
294295
in fmap snd
295296
. find

‎lib/GHCup/GHC.hs

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -124,7 +124,8 @@ testGHCVer ver addMakeArgs = do
124124
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
125125

126126
dlInfo <-
127-
preview (ix GHC % ix ver % viTestDL % _Just) dls
127+
-- TODO
128+
preview (ix GHC % ix ver % viDownload % ix 0 % viTestDL % _Just) dls
128129
?? NoDownload
129130

130131
liftE $ testGHCBindist dlInfo ver addMakeArgs
@@ -257,7 +258,8 @@ fetchGHCSrc :: ( MonadFail m
257258
fetchGHCSrc v mfp = do
258259
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
259260
dlInfo <-
260-
preview (ix GHC % ix v % viSourceDL % _Just) dls
261+
-- TODO
262+
preview (ix GHC % ix v % viDownload % ix 0 % viSourceDL % _Just) dls
261263
?? NoDownload
262264
liftE $ downloadCached' dlInfo Nothing mfp
263265

@@ -804,7 +806,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
804806

805807
-- download source tarball
806808
dlInfo <-
807-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
809+
-- TODO
810+
preview (ix GHC % ix (tver ^. tvVersion) % viDownload % ix 0 % viSourceDL % _Just) dls
808811
?? NoDownload
809812
dl <- liftE $ downloadCached dlInfo Nothing
810813

‎lib/GHCup/HLS.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -368,7 +368,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
368368

369369
-- download source tarball
370370
dlInfo <-
371-
preview (ix HLS % ix tver % viSourceDL % _Just) dls
371+
-- TODO
372+
preview (ix HLS % ix tver % viDownload % ix 0 % viSourceDL % _Just) dls
372373
?? NoDownload
373374
dl <- liftE $ downloadCached dlInfo Nothing
374375

‎lib/GHCup/List.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -308,7 +308,7 @@ listVersions lt' criteria = do
308308
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
309309
in if | Map.member currentVer av -> Nothing
310310
| otherwise -> Just $ ListResult { lVer = currentVer
311-
, lTag = maybe (if isOld then [Old] else []) _viTags listVer
311+
, lTag = maybe (if isOld then [Old] else []) (view viTags) listVer
312312
, lCross = Nothing
313313
, lTool = GHCup
314314
, fromSrc = False
@@ -337,7 +337,8 @@ listVersions lt' criteria = do
337337
-> [Either FilePath Version]
338338
-> (Version, VersionInfo)
339339
-> m ListResult
340-
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
340+
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, vi) = do
341+
let tags = view viTags vi
341342
case t of
342343
GHC -> do
343344
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v

‎lib/GHCup/Types.hs

Lines changed: 32 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,8 @@ import Graphics.Vty ( Key(..) )
4444
import qualified Data.ByteString.Lazy as BL
4545
import qualified Data.Text as T
4646
import qualified GHC.Generics as GHC
47+
import qualified Data.Map.Strict as M
48+
4749

4850

4951
#if !defined(BRICK)
@@ -135,6 +137,19 @@ instance NFData GlobalTool
135137
-- | All necessary information of a tool version, including
136138
-- source download and per-architecture downloads.
137139
data VersionInfo = VersionInfo
140+
{ _viTags :: [Tag] -- ^ version specific tag
141+
, _viChangeLog :: Maybe URI
142+
, _viDownload :: Map Int VersionDownload
143+
-- informative messages
144+
, _viPostInstall :: Maybe Text
145+
, _viPostRemove :: Maybe Text
146+
, _viPreCompile :: Maybe Text
147+
}
148+
deriving (Eq, GHC.Generic, Show)
149+
150+
instance NFData VersionInfo
151+
152+
data VersionInfoLegacy = VersionInfoLegacy
138153
{ _viTags :: [Tag] -- ^ version specific tag
139154
, _viChangeLog :: Maybe URI
140155
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
@@ -147,7 +162,23 @@ data VersionInfo = VersionInfo
147162
}
148163
deriving (Eq, GHC.Generic, Show)
149164

150-
instance NFData VersionInfo
165+
data VersionDownload = VersionDownload
166+
{ _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
167+
, _viTestDL :: Maybe DownloadInfo -- ^ test tarball
168+
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
169+
170+
}
171+
deriving (Eq, GHC.Generic, Show)
172+
173+
instance NFData VersionDownload
174+
175+
fromVersionInfoLegacy :: VersionInfoLegacy -> VersionInfo
176+
fromVersionInfoLegacy VersionInfoLegacy{..} =
177+
VersionInfo {_viDownload = M.singleton 0 $ VersionDownload { _viSourceDL = _viSourceDL
178+
, _viTestDL = _viTestDL
179+
, _viArch = _viArch
180+
}
181+
, ..}
151182

152183

153184
-- | A tag. These are currently attached to a version of a tool.

‎lib/GHCup/Types/JSON.hs

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -320,11 +320,18 @@ instance FromJSONKey (Maybe VersionRange) where
320320
Right x -> pure $ Just x
321321
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
322322

323-
324-
325323
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
326324
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
327-
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
325+
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfoLegacy
326+
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionDownload
327+
328+
instance FromJSON VersionInfo where
329+
parseJSON v = parseLegacy v <|> parseNew v
330+
where
331+
parseLegacy = fmap fromVersionInfoLegacy . parseJSON @VersionInfoLegacy
332+
parseNew = genericParseJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel }
333+
334+
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
328335
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
329336
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
330337
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key

‎lib/GHCup/Types/Optics.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ makeLenses ''PlatformResult
3737
makeLenses ''DownloadInfo
3838
makeLenses ''Tag
3939
makeLenses ''VersionInfo
40+
makeLenses ''VersionDownload
4041

4142
makeLenses ''GHCTargetVersion
4243

‎lib/GHCup/Utils.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -781,6 +781,9 @@ getLatestToolFor tool pvpIn dls = do
781781
let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
782782
pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps
783783

784+
-- type ToolVersionSpec = Map Version ToolRevisionSpec
785+
-- type ToolRevisionSpec = Map Int VersionInfo
786+
784787

785788

786789

‎test/GHCup/ArbitraryTypes.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -147,6 +147,10 @@ instance Arbitrary Architecture where
147147
arbitrary = genericArbitrary
148148
shrink = genericShrink
149149

150+
instance Arbitrary VersionDownload where
151+
arbitrary = genericArbitrary
152+
shrink = genericShrink
153+
150154
instance Arbitrary VersionInfo where
151155
arbitrary = genericArbitrary
152156
shrink = genericShrink

0 commit comments

Comments
 (0)