ghcup-0.2.3.0: lib-tui/GHCup/Brick/Actions.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Brick.Actions where
import GHCup.CabalConfig
import GHCup.Command.Install
import GHCup.Command.List
import GHCup.Command.Rm
import GHCup.Command.Set
import GHCup.Command.Upgrade
import GHCup.Download
import GHCup.Errors
import GHCup.Input.Prompts
import GHCup.Prelude
import GHCup.Prelude.Process
import GHCup.Query.GHCupDirs
import GHCup.Query.Metadata
import GHCup.System.Directory
import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types.Optics ( HasLog, getDirs, getPlatformReq )
import qualified GHCup.Command.Compile.GHC as GHC
import qualified GHCup.Command.Compile.HLS as HLS
import qualified GHCup.Input.Parsers as Utils
import GHCup.Brick.BrickState
import GHCup.Brick.Common
( BrickData (..), BrickSettings (..), Mode (..), Name (..) )
import GHCup.Brick.Widgets.Menu ( MenuKeyBindings (..) )
import GHCup.Brick.Widgets.Navigation ( BrickInternalState )
import qualified GHCup.Brick.Common as Common
import qualified GHCup.Brick.Widgets.Menus.AdvancedInstall as AdvancedInstall
import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
import qualified Brick
import qualified Brick.Widgets.List as L
import Control.Applicative
import Control.Exception.Safe
import Control.Monad ( forM, forM_, when )
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Function ( (&) )
import Data.Functor
import qualified Data.Map.Strict as M
import Data.IORef
( IORef, modifyIORef, newIORef, readIORef )
import Data.List
import Data.Maybe
import Data.Variant.Excepts
import Data.Versions hiding ( Lens' )
import Prelude hiding ( appendFile )
import System.Exit
import System.IO.Unsafe
import System.Process ( system )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Vector as V
import qualified Graphics.Vty as Vty
import System.Environment ( getExecutablePath )
#if !IS_WINDOWS
import qualified System.Posix.Process as SPP
#endif
import System.FilePath
import Control.Concurrent ( threadDelay )
import Optics ( to, (^.) )
import Optics.Getter ( view )
import Optics.Operators ( (.~) )
import Optics.Optic ( (%) )
import Optics.State ( use )
import Optics.State.Operators ( (.=), (%=) )
{- Core Logic.
This module defines the IO actions we can execute within the Brick App:
- Install
- Set
- UnInstall
- Launch the Changelog
-}
-- | Update app data and list internal state based on new evidence.
-- This synchronises @BrickInternalState@ with @BrickData@
-- and @BrickSettings@.
updateList :: BrickData -> BrickState -> BrickState
updateList appD bst =
let newInternalState = constructList appD (bst ^. appSettings) (Just (bst ^. appState))
in bst
& appState .~ newInternalState
& appData .~ appD
& mode .~ Navigation
constructList :: BrickData
-> BrickSettings
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD settings =
replaceLR (filterVisible (_showAllVersions settings))
(_lr appD)
-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0
selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState
selectBy tool predicate internal_state =
L.listModify
(\(t, (td, vlr)) -> (t, (td, maybe vlr (`L.listMoveToElement` vlr) . V.find predicate $ L.listElements vlr)))
(L.listFindBy (\(t, _) -> tool == t) internal_state)
-- | Select the latest GHC tool
selectLatest :: BrickInternalState -> BrickInternalState
selectLatest = selectBy ghc (elem Latest . lTag)
-- | Replace the @appState@ or construct it based on a filter function
-- and a new @[ListResult]@ evidence.
-- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool)
-> ToolListResult
-> Maybe BrickInternalState
-> BrickInternalState
replaceLR filterF list_result s =
let oldElem = s >>= L.listSelectedElement -- Maybe (Int, e)
in case oldElem of
Just (_, (tool, (toolDesc, elr))) -> do
case L.listSelectedElement elr of
Just (_, lr) ->
selectBy tool (\lr' -> lVer lr == lVer lr' && lCross lr == lCross lr') newList
Nothing -> selectBy tool (elem Latest . lTag) newList
Nothing ->
let bis' = foldl' (\bis tool -> selectBy tool (elem Latest . lTag) bis) newList (M.keys list_result)
in L.listFindBy (\(t, _) -> ghc == t) bis'
where
newList :: BrickInternalState
newList =
L.list
AllTools
(V.fromList $ fmap (\(tool, (td, filter filterF -> lr)) -> (tool, (td, L.list (Singular tool) (V.fromList lr) 1))) $ M.toList list_result) 1
filterVisible :: Bool -> ListResult -> Bool
filterVisible v e | lInstalled e = True
| v
, Nightly `notElem` lTag e = True
| not v
, Old `notElem` lTag e
, Nightly `notElem` lTag e = True
| otherwise = (Old `notElem` lTag e) &&
(Nightly `notElem` lTag e)
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (Ord n, Eq n)
=> ( (Int, Tool, Maybe ToolDescription, ListResult) -> ReaderT AppState IO (Either String a))
-> Brick.EventM n BrickState ()
withIOAction action = do
as <- Brick.get
case L.listSelectedElement (view appState as) of
Nothing -> pure ()
Just (curr_ix, (tool, (td, vlr))) -> case L.listSelectedElement vlr of
Just (curr_ix', lr) ->
Brick.suspendAndResume $ do
settings <- readIORef settings'
flip runReaderT settings $ action (curr_ix', tool, td, lr) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err)
Right _ -> liftIO $ putStrLn "Success"
getAppData Nothing >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
Nothing -> pure ()
withIOActionRecommended :: (Ord n, Eq n)
=> ( (Int, Tool, Maybe ToolDescription, ListResult) -> ReaderT AppState IO (Either String a))
-> Brick.EventM n BrickState ()
withIOActionRecommended action = do
as <- Brick.get
case L.listSelectedElement (view appState as) of
Nothing -> pure ()
Just (curr_ix, (tool, (td, vlr))) -> do
let mlr = V.find (\ListResult{..} -> Recommended `elem` lTag) $ L.listElements vlr
case mlr of
Just lr ->
Brick.suspendAndResume $ do
settings <- readIORef settings'
flip runReaderT settings $ action (curr_ix, tool, td, lr) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err)
Right _ -> liftIO $ putStrLn "Success"
getAppData Nothing >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
Nothing -> pure ()
installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> AdvancedInstall.InstallOptions
-> (Int, Tool, Maybe ToolDescription, ListResult)
-> m (Either String ())
installWithOptions opts (_ix, lTool, td, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let
misolated = opts ^. AdvancedInstall.isolateDirL
shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvancedInstall.isolateDirL)
shouldForce = opts ^. AdvancedInstall.forceInstallL
shouldSet = opts ^. AdvancedInstall.instSetL
extraArgs = opts ^. AdvancedInstall.addConfArgsL
installTargets = opts ^. AdvancedInstall.installTargetsL
v = fromMaybe (TargetVersionReq (TargetVersion lCross lVer) (Just (fst lRev))) (opts ^. AdvancedInstall.instVersionL)
let run =
runResourceT
. runE
@'[ AlreadyInstalled
, ArchiveResult
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, DirNotEmpty
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
, ProcessError
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
, InstallSetError
, URIParseError
, NoInstallInfo
, MalformedInstallInfo
, InvalidBuildConfig
]
withNoVerify :: (MonadReader AppState m) => m a -> m a
withNoVerify = local (\s -> s { settings = (settings s) { noVerify = True}})
run (do
ce <- liftIO $ fmap (either (const Nothing) Just) $
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
dirs <- lift getDirs
case lTool of
Tool "ghcup" -> do
let vm = getLatest dls lTool >>= \t -> getVersionMetadata t lTool dls
forM_ (_vmPreInstall =<< vm) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ upgradeGHCup Nothing False False $> (vm, dirs, ce)
_ -> do
let vm = getLatest dls lTool >>= \t -> getVersionMetadata t lTool dls
forM_ (_vmPreInstall =<< vm) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
case opts ^. AdvancedInstall.instBindistL of
Nothing -> do
liftE $
runBothE'
(installTool lTool v shouldIsolate shouldForce (T.unpack <$> extraArgs) (words . T.unpack <$> installTargets))
(when (shouldSet && isNothing misolated) (liftE $ void $ setToolVersion lTool (_tvqTargetVer v)))
pure (vm, dirs, ce)
Just uri -> do
liftE $
runBothE'
(do
rev <- liftE $ maybe (fmap fst $ getDownloadInfoE' lTool v) pure (_tvqRev v)
withNoVerify $ installBindist
lTool
td
(DownloadInfo ((decUTF8Safe . serializeURIRef') uri) (Just $ RegexDir "ghc-.*") "" Nothing Nothing Nothing Nothing)
(TargetVersionRev (_tvqTargetVer v) rev)
shouldIsolate
shouldForce
(T.unpack <$> extraArgs)
(words . T.unpack <$> installTargets)
)
(when (shouldSet && isNothing misolated) (liftE $ void $ setToolVersion lTool (_tvqTargetVer v)))
pure (vm, dirs, ce)
)
>>= \case
VRight (vm, Dirs{..}, Just ce) -> do
forM_ (_vmPostInstall =<< vm) $ \msg -> logInfo msg
case lTool of
Tool "ghcup" -> do
#if !IS_WINDOWS
up <- liftIO $ fmap (either (const Nothing) Just)
$ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
when ((normalise <$> up) == Just (normalise ce)) $
-- TODO: track cli arguments of previous invocation
liftIO $ SPP.executeFile ce False ["tui"] Nothing
#else
logInfo "Please restart 'ghcup' for the changes to take effect"
#endif
_ -> pure ()
pure $ Right ()
VRight (vm, _, _) -> do
forM_ (_vmPostInstall =<< vm) $ \msg -> logInfo msg
logInfo "Please restart 'ghcup' for the changes to take effect"
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left $ prettyHFError e <> "\n"
<> "Also check the logs in ~/.ghcup/logs or $XDG_STATE_HOME/ghcup/logs"
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ())
install' = installWithOptions (AdvancedInstall.InstallOptions Nothing False Nothing Nothing False [] Nothing)
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> (Int, Tool, Maybe ToolDescription, ListResult)
-> m (Either String ())
set' input@(_, lTool, _, ListResult {..}) = do
settings <- liftIO $ readIORef settings'
let run =
flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, ArchiveResult
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, DirNotEmpty
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
, ProcessError
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
, URIParseError
]
run (do
case lTool of
Tool "ghcup" -> do
promptAnswer <- getUserPromptResponse
"Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/n]: "
PromptYes
case promptAnswer of
PromptYes -> do
void $ liftE $ upgradeGHCup Nothing False False
PromptNo -> pure ()
_ -> liftE $ setToolVersion lTool (TargetVersion lCross lVer) $> ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> case e of
(V (NotInstalled tool _)) -> do
promptAnswer <- getUserPromptResponse userPrompt PromptYes
case promptAnswer of
PromptYes -> do
res <- install' input
case res of
(Left err) -> pure $ Left err
(Right _) -> do
logInfo "Setting now..."
set' input
PromptNo -> pure $ Left (prettyHFError e)
where
userPrompt = L.toStrict . B.toLazyText . B.fromString $
"This Version of "
<> show tool
<> " you are trying to set is not installed.\n"
<> "Would you like to install it first? [Y/n]: "
_ -> pure $ Left (prettyHFError e)
logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => TargetVersion -> m ()
logGHCPostRm ghcVer = do
cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store")
getStoreDir
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> (Int, Tool, Maybe ToolDescription, ListResult)
-> m (Either String ())
del' (_, lTool, _, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run = runE @'[NotInstalled, UninstallFailed, ParseError, MalformedInstallInfo]
run (do
let vi = getVersionMetadata crossVer lTool dls
case lTool of
Tool "ghcup" -> pure Nothing
_ -> liftE $ rmToolVersion lTool crossVer $> vi
)
>>= \case
VRight vi -> do
when (lTool == ghc) $ logGHCPostRm crossVer
logInfo $ "Successfully removed " <> T.pack (prettyShow lTool) <> " " <> (if lTool == ghc then tVerToText crossVer else prettyVer lVer)
forM_ (_vmPostRemove =<< vi) $ \msg ->
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyHFError e)
where
crossVer = TargetVersion lCross lVer
changelog' :: (MonadReader AppState m, MonadIO m)
=> (Int, Tool, Maybe ToolDescription, ListResult)
-> m (Either String ())
changelog' (_, lTool, _, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case getChangeLog dls lTool (mkTVer lVer) of
Nothing -> pure $ Left $
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
Just uri -> do
case _rPlatform pfreq of
Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
OpenBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Windows -> do
let args = "start \"\" " ++ T.unpack (decUTF8Safe $ serializeURIRef' uri)
c <- liftIO $ system args
case c of
(ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args]
ExitSuccess -> pure $ Right ()
>>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyHFError e
compileGHC :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> CompileGHC.CompileGHCOptions -> (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ())
compileGHC compopts (_, Tool "ghc", _, lr@ListResult{..}) = do
appstate <- ask
let run =
runResourceT
. runE @'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
, UninstallFailed
, MergeFileTreeError
, URIParseError
, ParseError
, FileAlreadyExistsError
, NoInstallInfo
, MalformedInstallInfo
]
compileResult <- run (do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
ghcVer <- case compopts ^. CompileGHC.gitRef of
Just ref -> pure (GHC.GitDist (GitBranch ref Nothing))
Nothing -> do
-- Compile the version user is pointing to in the tui
let vi = getVersionMetadata (mkTVer lVer) ghc dls
forM_ (_vmPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
forM_ (_vmPreCompile =<< vi) $ \msg -> do
logInfo msg
logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
pure (GHC.SourceDist lVer)
targetVer <- liftE $ GHC.compileGHC
ghcVer
(compopts ^. CompileGHC.crossTarget)
(compopts ^. CompileGHC.overwriteVer)
(compopts ^. CompileGHC.bootstrapGhc)
(compopts ^. CompileGHC.hadrianGhc)
(compopts ^. CompileGHC.jobs)
(compopts ^. CompileGHC.buildConfig)
(compopts ^. CompileGHC.patches)
(fmap T.unpack $ compopts ^. CompileGHC.addConfArgs)
(compopts ^. CompileGHC.buildFlavour)
(compopts ^. CompileGHC.buildSystem)
(maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir)
(fmap (words . T.unpack) $ compopts ^. CompileGHC.installTargets)
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
let vi2 = getVersionMetadata targetVer ghc dls2
when
(compopts ^. CompileGHC.setCompile)
(liftE . void $ setToolVersion ghc targetVer)
pure (vi2, targetVer)
)
case compileResult of
VRight (vi, tv) -> do
logInfo "GHC successfully compiled and installed"
forM_ (_vmPostInstall =<< vi) $ \msg -> logInfo msg
liftIO $ putStr (T.unpack $ tVerToText tv)
pure $ Right ()
VLeft (V (AlreadyInstalled _ v)) -> do
pure $ Left $
"GHC ver " <> prettyShow v <> " already installed, remove it first to reinstall"
VLeft (V (DirNotEmpty fp)) -> do
pure $ Left $
"Install directory " <> fp <> " is not empty."
VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $
case keepDirs (appstate & settings) of
Never -> prettyHFError err
_ -> prettyHFError err <> "\n"
<> "Check the logs at " <> fromGHCupPath (appstate & dirs & logsDir)
<> " and the build directory "
<> tmpdir <> " for more clues." <> "\n"
<> "Make sure to clean up " <> tmpdir <> " afterwards."
VLeft e -> do
pure $ Left $ prettyHFError e
-- This is the case when the tool is not GHC... which should be impossible but,
-- it exhausts pattern matches
compileGHC _ (_, _, _, _) = pure (Right ())
compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> CompileHLS.CompileHLSOptions -> (Int, Tool, Maybe ToolDescription, ListResult) -> m (Either String ())
compileHLS compopts (_, Tool "hls", _, lr@ListResult{..}) = do
appstate <- ask
let run =
runResourceT
. runE @'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
, NotInstalled
, DirNotEmpty
, ArchiveResult
, UninstallFailed
, MergeFileTreeError
, URIParseError
, ParseError
]
compileResult <- run (do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
hlsVer <- case compopts ^. CompileHLS.gitRef of
Just ref -> pure (HLS.GitDist (GitBranch ref Nothing))
Nothing -> do
-- Compile the version user is pointing to in the tui
let vi = getVersionMetadata (mkTVer lVer) hls dls
forM_ (_vmPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
forM_ (_vmPreCompile =<< vi) $ \msg -> do
logInfo msg
logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
pure (HLS.SourceDist lVer)
ghcs' <-
liftE $ forM (compopts ^. CompileHLS.targetGHCs)
(\ghc' -> Utils.resolveVersion (Just ghc') GStrict ghc)
ghcs <- forM ghcs' $ \TargetVersionReq{..} -> do
when (isJust $ _tvTarget _tvqTargetVer) $ fail "Cannot compile HLS for a cross GHC"
pure (_tvVersion _tvqTargetVer)
targetVer <- liftE $ HLS.compileHLS
hlsVer
ghcs
(compopts ^. CompileHLS.jobs)
(compopts ^. CompileHLS.overwriteVer)
(maybe GHCupInternal IsolateDir $ compopts ^. CompileHLS.isolateDir)
(compopts ^. CompileHLS.cabalProject)
(compopts ^. CompileHLS.cabalProjectLocal)
(compopts ^. CompileHLS.updateCabal)
(compopts ^. CompileHLS.patches)
(compopts ^. CompileHLS.cabalArgs)
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
let vi2 = getVersionMetadata (mkTVer targetVer) ghc dls2
when
(compopts ^. CompileHLS.setCompile)
(liftE . void $ setToolVersion hls (mkTVer targetVer))
pure (vi2, targetVer)
)
case compileResult of
VRight (vi, tv) -> do
logInfo "HLS successfully compiled and installed"
forM_ (_vmPostInstall =<< vi) $ \msg -> logInfo msg
liftIO $ putStr (T.unpack $ prettyVer tv)
pure $ Right ()
VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $
case keepDirs (appstate & settings) of
Never -> prettyHFError err
_ -> prettyHFError err <> "\n"
<> "Check the logs at " <> fromGHCupPath (appstate & dirs & logsDir)
<> " and the build directory "
<> tmpdir <> " for more clues." <> "\n"
<> "Make sure to clean up " <> tmpdir <> " afterwards."
VLeft e -> do
pure $ Left $ prettyHFError e
-- This is the case when the tool is not HLS... which should be impossible but,
-- it exhaustes pattern matches
compileHLS _ (_, _, _, _) = pure (Right ())
settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebugLvl = Nothing
, consoleOutter = \_ -> pure ()
, fileOutter = \_ -> pure ()
, fancyColors = True
}
newIORef $ AppState defaultSettings
dirs
defaultKeyBindings
(GHCupInfo mempty (GHCupDownloads mempty) Nothing)
(PlatformRequest A_64 Darwin Nothing)
loggerConfig
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
r <-
flip runReaderT settings
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError, UnsupportedMetadataFormat]
$ do
pfreq <- lift getPlatformReq
liftE $ getDownloadsF pfreq
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyHFError e)
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
r' <- lift $ flip runReaderT settings $ runE $ do
lV <- listVersions Nothing [] ShowUpdates False True (Nothing, Nothing)
pure $ BrickData lV
ExceptT $ pure $ either (Left . prettyHFError) Right $ veitherToEither r'
--
keyHandlersToolList :: KeyBindings
-> [ ( KeyCombination
, Maybe (BrickSettings -> String)
, Brick.EventM Name BrickState ()
)
]
keyHandlersToolList KeyBindings {..} =
[ (bQuit, Just $ const "Quit" , Brick.halt)
, (bInstall, Just $ const "Install and set recommended version",
withIOActionRecommended $ installWithOptions (AdvancedInstall.InstallOptions Nothing True Nothing Nothing False [] Nothing))
, ( bShowAllVersions
, Just $ \BrickSettings {..} ->
if _showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler' (not . _showAllVersions)
)
, (KeyCombination (Vty.KChar 'h') [], Just $ const "help", mode .= KeyInfo)
, (KeyCombination Vty.KEnter [], Just $ const "Show tool details", mode .= Common.ToolInfo )
, (KeyCombination KLeft [], Nothing, versionFocus .= False)
, (KeyCombination KRight [], Nothing, versionFocus .= True)
, (KeyCombination (Vty.KChar '\t') [], Nothing, versionFocus %= not)
]
keyHandlersVersionList :: KeyBindings
-> [ ( KeyCombination
, Maybe (BrickSettings -> String)
, Brick.EventM Name BrickState ()
)
]
keyHandlersVersionList KeyBindings {..} =
[ (bQuit, Just $ const "Quit" , Brick.halt)
, (bInstall, Just $ const "Install" , withIOAction install')
, (bUninstall, Just $ const "Uninstall", withIOAction del')
, (bSet, Just $ const "Set" , withIOAction set')
, (bChangelog, Just $ const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions
, Just $ \BrickSettings {..} ->
if _showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler' (not . _showAllVersions)
)
, (KeyCombination (Vty.KChar 'h') [], Just $ const "Help", mode .= KeyInfo)
, (KeyCombination Vty.KEnter [], Just $ const "Advanced options", createMenuforTool )
, (KeyCombination KLeft [], Nothing, versionFocus .= False)
, (KeyCombination KRight [], Nothing, versionFocus .= True)
, (KeyCombination (Vty.KChar '\t') [], Nothing, versionFocus %= not)
]
where
createMenuforTool = do
e <- use (appState % to L.listSelectedElement)
case e of
Nothing -> pure ()
Just (_, (t, (td, vlr))) -> case L.listSelectedElement vlr of
Just (_, lr) -> do
-- Create new ContextMenu, but maintain the state of Install/Compile
-- menus. This is especially useful in case the user made a typo and
-- would like to retry the action.
contextMenu .= ContextMenu.create (t, (td, lr))
(MenuKeyBindings { mKbUp = bUp, mKbDown = bDown, mKbQuit = bQuit})
-- Set mode to context
mode .= ContextPanel
Nothing -> pure ()
pure ()
hideShowHandler' :: (BrickSettings -> Bool) -> Brick.EventM Name BrickState ()
hideShowHandler' f = do
app_settings <- use appSettings
let
vers = f app_settings
newAppSettings = app_settings & Common.showAllVersions .~ vers
ad <- use appData
current_app_state <- use appState
appSettings .= newAppSettings
appState .= constructList ad newAppSettings (Just current_app_state)