615 lines
22 KiB
Haskell
615 lines
22 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
|
|
module AnsiMain where
|
|
|
|
import GHCup
|
|
import GHCup.Download
|
|
import GHCup.Errors
|
|
import GHCup.Prelude ( decUTF8Safe )
|
|
import GHCup.Prelude.File
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Prelude.Process
|
|
import GHCup.Prompts
|
|
import GHCup.Types hiding ( LeanAppState(..) )
|
|
import GHCup.Types.Optics ( getDirs )
|
|
import GHCup.Utils
|
|
|
|
import Data.List (sort, intersperse)
|
|
import Data.Versions (prettyPVP, prettyVer)
|
|
import Codec.Archive
|
|
import Control.Monad.IO.Class
|
|
-- import System.Console.ANSI
|
|
import System.Console.ANSI
|
|
import Terminal.Game
|
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
|
|
|
import Control.Exception.Safe
|
|
import Control.Monad ( when, forM_ )
|
|
import Control.Monad.ST
|
|
import Control.Monad.Reader ( ReaderT(runReaderT), MonadReader, ask, lift )
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Resource
|
|
import Data.Functor
|
|
import Data.STRef
|
|
import Data.IORef
|
|
import Data.Maybe ( fromMaybe, catMaybes )
|
|
import qualified Data.Text as Tx
|
|
import qualified Data.Tuple as T
|
|
import qualified Data.Vector as V
|
|
import GHC.IO ( unsafePerformIO )
|
|
import Haskus.Utils.Variant.Excepts
|
|
import System.Exit
|
|
import System.Environment (getExecutablePath)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy.Builder as B
|
|
import qualified Data.Text.Lazy as L
|
|
import System.FilePath
|
|
import URI.ByteString (serializeURIRef')
|
|
|
|
|
|
|
|
data Direction = Up
|
|
| Down
|
|
deriving (Show, Eq)
|
|
|
|
data BrickData = BrickData
|
|
{ lr :: [ListResult]
|
|
}
|
|
deriving Show
|
|
|
|
data BrickSettings = BrickSettings
|
|
{ showAllVersions :: Bool
|
|
, showAllTools :: Bool
|
|
}
|
|
deriving Show
|
|
|
|
data BrickInternalState = BrickInternalState
|
|
{ clr :: V.Vector ListResult
|
|
, ix :: Int
|
|
}
|
|
deriving Show
|
|
|
|
data BrickState = BrickState
|
|
{ appData :: BrickData
|
|
, appSettings :: BrickSettings
|
|
, appState :: BrickInternalState
|
|
, appKeys :: KeyBindings
|
|
, appQuit :: Bool
|
|
, appRestart :: Bool
|
|
, appMoreInput :: Maybe String
|
|
}
|
|
deriving Show
|
|
|
|
|
|
startGame :: BrickState -> IO BrickState
|
|
startGame g = do
|
|
g'@BrickState { appRestart } <- errorPress $ playGameT liftIO (ghcupGame g)
|
|
if appRestart
|
|
then do
|
|
putStrLn "Press enter to continue"
|
|
_ <- getLine
|
|
startGame $ g' { appRestart = False }
|
|
else pure g'
|
|
|
|
ansiMain :: AppState -> IO ()
|
|
ansiMain s = do
|
|
writeIORef settings' s
|
|
|
|
eAppData <- getAppData (Just $ ghcupInfo s)
|
|
case eAppData of
|
|
Right ad -> do
|
|
let g = BrickState ad
|
|
defaultAppSettings
|
|
(constructList ad defaultAppSettings Nothing)
|
|
(keyBindings (s :: AppState))
|
|
False
|
|
False
|
|
Nothing
|
|
|
|
|
|
sizeCheck
|
|
void $ startGame g
|
|
cleanAndExit
|
|
Left e -> do
|
|
flip runReaderT s $ logError $ "Error building app state: " <> Tx.pack
|
|
(show e)
|
|
exitWith $ ExitFailure 2
|
|
|
|
|
|
where
|
|
sizeCheck :: IO ()
|
|
sizeCheck = let (w, h) = T.swap . snd $ boundaries in assertTermDims w h
|
|
|
|
|
|
ghcupGame :: BrickState -> Game BrickState
|
|
ghcupGame bs = Game 13
|
|
bs -- ticks per second
|
|
(\ge s e -> logicFun ge s e) -- logic function
|
|
(\r s -> centerFull r $ drawFun s r) -- draw function
|
|
(\s -> appQuit s || appRestart s) -- quit function
|
|
|
|
|
|
drawFun :: BrickState -> GEnv -> Plane
|
|
drawFun (BrickState {..}) GEnv{..} =
|
|
let focus pl = maybe pl
|
|
(\ix -> V.update pl (V.singleton (ix + 1, fmap invert $ pl V.! (ix + 1))))
|
|
mix
|
|
rows = V.fromList [header, [box (mw - 2) 1 '=']] V.++ renderItems
|
|
cols = V.foldr (\xs ys -> zipWith (:) xs ys) (repeat []) $ V.filter ((==5) . length) rows
|
|
padded = focus $ V.map (\xs -> zipWith padTo xs lengths) rows
|
|
lengths :: [Int]
|
|
lengths = fmap (maximum . fmap (fst . planeSize)) cols
|
|
in blankPlane mw mh
|
|
& (1, 1) % box 1 1 'X' -- '┌'
|
|
& (2, 1) % box 1 (mh - 3) '|' -- '│'
|
|
& (1, 2) % box (mw - 2) 1 '=' -- '─'
|
|
& (2, mw) % box 1 (mh - 3) '|' -- '│'
|
|
& (1, mw) % box 1 1 'X' -- '┐'
|
|
& (mh-1, 2) % box (mw - 2) 1 '=' -- '─'
|
|
& (mh-1, 1) % box 1 1 'X' -- '└'
|
|
& (mh-1, mw) % box 1 1 'X' -- '┘'
|
|
& (2, 2) % box (mw - 2) (mh - 3) ' ' -- ' '
|
|
& (2, 2) % vcat (hcat <$> V.toList padded)
|
|
& (mh, 1) % footer
|
|
& (1, mw `div` 2 - 2) % stringPlane "GHCup"
|
|
where
|
|
|
|
padTo :: Plane -> Int -> Plane
|
|
padTo plane x =
|
|
let lstr = fst $ planeSize plane
|
|
add' = x - lstr + 1
|
|
in if add' < 0 then plane else plane ||| stringPlane (replicate add' ' ')
|
|
mh :: Height
|
|
mw :: Width
|
|
(mh, mw) = T.swap eTermDims
|
|
footer = hcat
|
|
. intersperse (stringPlane " ")
|
|
. fmap stringPlane
|
|
$ ["q:Quit", "i:Install", "u:Uninstall", "s:Set", "c:Changelog", "a:all versions", "↑:Up", "↓:Down"]
|
|
header = fmap stringPlane [" ", "Tool", "Version", "Tags", "Notes"]
|
|
(renderItems, mix) = drawListElements renderItem appState
|
|
renderItem _ _ listResult@ListResult{..} =
|
|
let marks = if
|
|
| lSet -> color Green Vivid $ stringPlane "IS"
|
|
| lInstalled -> color Green Vivid $ stringPlane "I "
|
|
| otherwise -> color Red Vivid $ stringPlane "X "
|
|
ver = case lCross of
|
|
Nothing -> stringPlane . Tx.unpack . prettyVer $ lVer
|
|
Just c -> stringPlane . Tx.unpack $ (c <> "-" <> prettyVer lVer)
|
|
tool = printTool lTool
|
|
tag = let l = catMaybes . fmap printTag $ sort lTag
|
|
in if null l then blankPlane 1 1 else foldr1 (\x y -> x ||| stringPlane "," ||| y) l
|
|
notes = let n = printNotes listResult
|
|
in if null n
|
|
then blankPlane 1 1
|
|
else foldr1 (\x y -> x ||| stringPlane "," ||| y) n
|
|
|
|
in [marks ||| space, tool, ver, tag, notes]
|
|
|
|
printTag Recommended = Just $ color Green Dull $ stringPlane "recommended"
|
|
printTag Latest = Just $ color Yellow Dull $ stringPlane "latest"
|
|
printTag Prerelease = Just $ color Red Dull $ stringPlane "prerelease"
|
|
printTag (Base pvp'') = Just $ stringPlane ("base-" ++ T.unpack (prettyPVP pvp''))
|
|
printTag Old = Nothing
|
|
printTag (UnknownTag t) = Just $ stringPlane t
|
|
|
|
printTool Cabal = stringPlane "cabal"
|
|
printTool GHC = stringPlane "GHC"
|
|
printTool GHCup = stringPlane "GHCup"
|
|
printTool HLS = stringPlane "HLS"
|
|
printTool Stack = stringPlane "Stack"
|
|
|
|
printNotes ListResult {..} =
|
|
(if hlsPowered then [color Green Dull $ stringPlane "hls-powered"] else mempty
|
|
)
|
|
++ (if fromSrc then [color Blue Dull $ stringPlane "compiled"] else mempty)
|
|
++ (if lStray then [color Blue Dull $ stringPlane "stray"] else mempty)
|
|
|
|
space = stringPlane " "
|
|
|
|
-- | Draws the list elements.
|
|
--
|
|
-- Evaluates the underlying container up to, and a bit beyond, the
|
|
-- selected element. The exact amount depends on available height
|
|
-- for drawing and 'listItemHeight'. At most, it will evaluate up to
|
|
-- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the
|
|
-- available height.
|
|
drawListElements :: (Int -> Bool -> ListResult -> [Plane])
|
|
-> BrickInternalState
|
|
-> (V.Vector [Plane], Maybe Int)
|
|
drawListElements drawElem is@(BrickInternalState clr _) =
|
|
let es = clr
|
|
listSelected = fmap fst $ listSelectedElement' is
|
|
|
|
(drawnElements, selIx) = runST $ do
|
|
ref <- newSTRef (Nothing :: Maybe Int)
|
|
vec <- newSTRef (mempty :: V.Vector [Plane])
|
|
elem' <- newSTRef 0
|
|
void $ flip V.imapM es $ \i' e -> do
|
|
let isSelected = Just i' == listSelected
|
|
elemWidget = drawElem i' isSelected e
|
|
case es V.!? (i' - 1) of
|
|
Just e' | lTool e' /= lTool e -> do
|
|
modifySTRef elem' (+2)
|
|
i <- readSTRef elem'
|
|
when isSelected $ writeSTRef ref (Just i)
|
|
modifySTRef vec (`V.snoc` [hBorder])
|
|
modifySTRef vec (`V.snoc` elemWidget)
|
|
pure ()
|
|
_ -> do
|
|
modifySTRef elem' (+1)
|
|
i <- readSTRef elem'
|
|
when isSelected $ writeSTRef ref (Just i)
|
|
modifySTRef vec (`V.snoc` elemWidget)
|
|
pure ()
|
|
i <- readSTRef ref
|
|
arr <- readSTRef vec
|
|
pure (arr, i)
|
|
in (makeVisible drawnElements (mh - 5) selIx, selIx)
|
|
where
|
|
makeVisible :: V.Vector [Plane] -> Height -> Maybe Int -> V.Vector [Plane]
|
|
makeVisible listElements drawableHeight (Just ix) =
|
|
let listHeight = V.length listElements
|
|
in if | listHeight <= 0 -> listElements
|
|
| listHeight > drawableHeight ->
|
|
if | ix <= drawableHeight -> makeVisible (V.init listElements) drawableHeight (Just ix)
|
|
| otherwise -> makeVisible (V.tail listElements) drawableHeight (Just (ix - 1))
|
|
| otherwise -> listElements
|
|
makeVisible listElements _ Nothing = listElements
|
|
|
|
hBorder = box (mw - 2) 1 '='
|
|
|
|
|
|
logicFun :: GEnv -> BrickState -> Event -> IO BrickState
|
|
logicFun _ gs (KeyPress 'q') = pure gs { appQuit = True }
|
|
logicFun _ gs Tick = pure gs
|
|
logicFun _ gs@BrickState{appMoreInput = Nothing} (KeyPress '\ESC') = pure gs { appMoreInput = Just "\ESC" }
|
|
logicFun _ gs@BrickState{appMoreInput = Just "\ESC"} (KeyPress '[') = pure gs { appMoreInput = Just "\ESC[" }
|
|
logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'A')
|
|
= pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up }
|
|
logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'B')
|
|
= pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Down }
|
|
logicFun _ gs@BrickState{appMoreInput = Just _} _ = pure gs { appMoreInput = Nothing }
|
|
logicFun _ gs (KeyPress 'i') = do
|
|
bs <- withIOAction install' gs
|
|
pure bs { appRestart = True }
|
|
logicFun _ gs (KeyPress 'u') = do
|
|
bs <- withIOAction del' gs
|
|
pure bs { appRestart = True }
|
|
logicFun _ gs (KeyPress 's') = do
|
|
bs <- withIOAction set' gs
|
|
pure bs { appRestart = True }
|
|
logicFun _ gs (KeyPress 'c') = do
|
|
bs <- withIOAction changelog' gs
|
|
pure bs { appRestart = True }
|
|
logicFun _ gs (KeyPress 'a') = pure $ hideShowHandler (not . showAllVersions) showAllTools gs
|
|
where
|
|
hideShowHandler :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> BrickState -> BrickState
|
|
hideShowHandler f p BrickState{..} =
|
|
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
|
|
newInternalState = constructList appData newAppSettings (Just appState)
|
|
in BrickState appData newAppSettings newInternalState appKeys appQuit appRestart appMoreInput
|
|
logicFun _ gs (KeyPress c) = pure $ (unsafePerformIO $ writeFile "key" $ show c) `seq` gs
|
|
|
|
withIOAction :: (BrickState
|
|
-> (Int, ListResult)
|
|
-> ReaderT AppState IO (Either String a))
|
|
-> BrickState
|
|
-> IO BrickState
|
|
withIOAction action as = case listSelectedElement' (appState as) of
|
|
Nothing -> pure as
|
|
Just (ix, e) -> do
|
|
clearScreen
|
|
|
|
settings <- readIORef settings'
|
|
flip runReaderT settings $ action as (ix, e) >>= \case
|
|
Left err -> liftIO $ putStrLn ("Error: " <> err)
|
|
Right _ -> liftIO $ putStrLn "Success"
|
|
getAppData Nothing >>= \case
|
|
Right data' -> do
|
|
pure (updateList data' as)
|
|
Left err -> throwIO $ userError err
|
|
|
|
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
|
|
moveCursor steps ais@BrickInternalState{..} direction =
|
|
let newIx = if direction == Down then ix + steps else ix - steps
|
|
in case clr V.!? newIx of
|
|
Just _ -> BrickInternalState { ix = newIx, .. }
|
|
Nothing -> ais
|
|
|
|
defaultAppSettings :: BrickSettings
|
|
defaultAppSettings =
|
|
BrickSettings { showAllVersions = False, showAllTools = False }
|
|
|
|
-- | Update app data and list internal state based on new evidence.
|
|
-- This synchronises @BrickInternalState@ with @BrickData@
|
|
-- and @BrickSettings@.
|
|
updateList :: BrickData -> BrickState -> BrickState
|
|
updateList appD BrickState{..} =
|
|
let newInternalState = constructList appD appSettings (Just appState)
|
|
in BrickState { appState = newInternalState
|
|
, appData = appD
|
|
, appSettings = appSettings
|
|
, appKeys = appKeys
|
|
, appQuit = appQuit
|
|
, appRestart = appRestart
|
|
, appMoreInput = appMoreInput
|
|
}
|
|
|
|
constructList
|
|
:: BrickData
|
|
-> BrickSettings
|
|
-> Maybe BrickInternalState
|
|
-> BrickInternalState
|
|
constructList appD appSettings = replaceLR
|
|
(filterVisible (showAllVersions appSettings) (showAllTools appSettings))
|
|
(lr appD)
|
|
|
|
|
|
-- | 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)
|
|
-> [ListResult]
|
|
-> Maybe BrickInternalState
|
|
-> BrickInternalState
|
|
replaceLR filterF lr s =
|
|
let oldElem = s >>= listSelectedElement'
|
|
newVec = V.fromList . filter filterF $ lr
|
|
newSelected =
|
|
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
|
|
Just ix -> ix
|
|
Nothing -> selectLatest newVec
|
|
in BrickInternalState newVec newSelected
|
|
where
|
|
toolEqual e1 e2 =
|
|
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
|
|
|
|
|
|
filterVisible :: Bool -> Bool -> ListResult -> Bool
|
|
filterVisible v t e
|
|
| lInstalled e = True
|
|
| v, not t, lTool e `notElem` hiddenTools = True
|
|
| not v, t, Old `notElem` lTag e = True
|
|
| v, t = True
|
|
| otherwise = (Old `notElem` lTag e) && (lTool e `notElem` hiddenTools)
|
|
|
|
|
|
hiddenTools :: [Tool]
|
|
hiddenTools = []
|
|
|
|
|
|
selectLatest :: V.Vector ListResult -> Int
|
|
selectLatest = fromMaybe 0
|
|
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
|
|
|
|
|
|
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
|
|
listSelectedElement' BrickInternalState {..} = fmap (ix, ) $ clr V.!? ix
|
|
|
|
|
|
boundaries :: (Coords, Coords)
|
|
boundaries = ((1, 1), (24, 80))
|
|
|
|
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
|
|
=> BrickState
|
|
-> (Int, ListResult)
|
|
-> m (Either String ())
|
|
install' _ (_, ListResult {..}) = do
|
|
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
|
|
|
let run =
|
|
runResourceT
|
|
. runE
|
|
@'[ AlreadyInstalled
|
|
, ArchiveResult
|
|
, UnknownArchive
|
|
, FileDoesNotExistError
|
|
, CopyError
|
|
, NoDownload
|
|
, NotInstalled
|
|
, BuildFailed
|
|
, TagNotFound
|
|
, DigestError
|
|
, GPGError
|
|
, DownloadFailed
|
|
, DirNotEmpty
|
|
, NoUpdate
|
|
, TarDirDoesNotExist
|
|
, FileAlreadyExistsError
|
|
, ProcessError
|
|
, ToolShadowed
|
|
, UninstallFailed
|
|
, MergeFileTreeError
|
|
]
|
|
|
|
run (do
|
|
ce <- liftIO $ fmap (either (const Nothing) Just) $
|
|
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
|
|
dirs <- lift getDirs
|
|
case lTool of
|
|
GHC -> do
|
|
let vi = getVersionInfo lVer GHC dls
|
|
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
|
|
Cabal -> do
|
|
let vi = getVersionInfo lVer Cabal dls
|
|
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
|
|
GHCup -> do
|
|
let vi = snd <$> getLatest dls GHCup
|
|
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
|
|
HLS -> do
|
|
let vi = getVersionInfo lVer HLS dls
|
|
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
|
|
Stack -> do
|
|
let vi = getVersionInfo lVer Stack dls
|
|
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
|
|
)
|
|
>>= \case
|
|
VRight (vi, Dirs{..}, Just ce) -> do
|
|
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
|
|
case lTool of
|
|
GHCup -> do
|
|
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
|
|
void $ liftIO $ exec ce ["tui"] Nothing Nothing
|
|
logInfo "Please restart 'ghcup' for the changes to take effect"
|
|
_ -> pure ()
|
|
pure $ Right ()
|
|
VRight (vi, _, _) -> do
|
|
forM_ (_viPostInstall =<< vi) $ \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 $ prettyShow e <> "\n"
|
|
<> "Also check the logs in ~/.ghcup/logs"
|
|
|
|
|
|
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
|
|
=> BrickState
|
|
-> (Int, ListResult)
|
|
-> m (Either String ())
|
|
set' bs input@(_, ListResult {..}) = do
|
|
settings <- liftIO $ readIORef settings'
|
|
|
|
let run =
|
|
flip runReaderT settings
|
|
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
|
|
|
|
run (do
|
|
case lTool of
|
|
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
|
|
Cabal -> liftE $ setCabal lVer $> ()
|
|
HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
|
|
Stack -> liftE $ setStack lVer $> ()
|
|
GHCup -> pure ()
|
|
)
|
|
>>= \case
|
|
VRight _ -> pure $ Right ()
|
|
VLeft e -> case e of
|
|
(V (NotInstalled tool _)) -> do
|
|
promptAnswer <- getUserPromptResponse userPrompt
|
|
case promptAnswer of
|
|
PromptYes -> do
|
|
res <- install' bs input
|
|
case res of
|
|
(Left err) -> pure $ Left err
|
|
(Right _) -> do
|
|
logInfo "Setting now..."
|
|
set' bs input
|
|
|
|
PromptNo -> pure $ Left (prettyShow 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 (prettyShow e)
|
|
|
|
|
|
|
|
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
|
|
=> BrickState
|
|
-> (Int, ListResult)
|
|
-> m (Either String ())
|
|
del' _ (_, ListResult {..}) = do
|
|
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
|
|
|
let run = runE @'[NotInstalled, UninstallFailed]
|
|
|
|
run (do
|
|
let vi = getVersionInfo lVer lTool dls
|
|
case lTool of
|
|
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
|
|
Cabal -> liftE $ rmCabalVer lVer $> vi
|
|
HLS -> liftE $ rmHLSVer lVer $> vi
|
|
Stack -> liftE $ rmStackVer lVer $> vi
|
|
GHCup -> pure Nothing
|
|
)
|
|
>>= \case
|
|
VRight vi -> do
|
|
forM_ (_viPostRemove =<< vi) $ \msg ->
|
|
logInfo msg
|
|
pure $ Right ()
|
|
VLeft e -> pure $ Left (prettyShow e)
|
|
|
|
|
|
changelog' :: (MonadReader AppState m, MonadIO m)
|
|
=> BrickState
|
|
-> (Int, ListResult)
|
|
-> m (Either String ())
|
|
changelog' _ (_, ListResult {..}) = do
|
|
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
|
case getChangeLog dls lTool (Left lVer) of
|
|
Nothing -> pure $ Left $
|
|
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
|
|
Just uri -> do
|
|
let cmd = case _rPlatform pfreq of
|
|
Darwin -> "open"
|
|
Linux _ -> "xdg-open"
|
|
FreeBSD -> "xdg-open"
|
|
Windows -> "start"
|
|
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
|
|
Right _ -> pure $ Right ()
|
|
Left e -> pure $ Left $ prettyShow e
|
|
|
|
|
|
settings' :: IORef AppState
|
|
{-# NOINLINE settings' #-}
|
|
settings' = unsafePerformIO $ do
|
|
dirs <- getAllDirs
|
|
let loggerConfig = LoggerConfig { lcPrintDebug = False
|
|
, consoleOutter = \_ -> pure ()
|
|
, fileOutter = \_ -> pure ()
|
|
, fancyColors = True
|
|
}
|
|
newIORef $ AppState defaultSettings
|
|
dirs
|
|
defaultKeyBindings
|
|
(GHCupInfo mempty mempty mempty)
|
|
(PlatformRequest A_64 Darwin Nothing)
|
|
loggerConfig
|
|
|
|
|
|
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'
|
|
|
|
flip runReaderT settings $ do
|
|
lV <- listVersions Nothing Nothing
|
|
pure $ BrickData (reverse lV)
|
|
|
|
|
|
getGHCupInfo :: IO (Either String GHCupInfo)
|
|
getGHCupInfo = do
|
|
settings <- readIORef settings'
|
|
|
|
r <-
|
|
flip runReaderT settings
|
|
. runE
|
|
@'[ DigestError
|
|
, GPGError
|
|
, JSONError
|
|
, DownloadFailed
|
|
, FileDoesNotExistError
|
|
]
|
|
$ liftE getDownloadsF
|
|
|
|
case r of
|
|
VRight a -> pure $ Right a
|
|
VLeft e -> pure $ Left (prettyShow e)
|
|
|
|
|