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
18 changed files with 21835 additions and 21360 deletions
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