Skip to content

Commit e0222b4

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

File tree

18 files changed

+22116
-21641
lines changed

18 files changed

+22116
-21641
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

0 commit comments

Comments
 (0)