ghcup-hs/app/ghcup/BrickMain.hs

675 lines
25 KiB
Haskell
Raw Permalink Normal View History

{-# LANGUAGE CPP #-}
2020-07-06 20:39:16 +00:00
{-# LANGUAGE DataKinds #-}
2020-10-11 19:07:13 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
2021-05-14 21:09:45 +00:00
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
2020-07-06 20:39:16 +00:00
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics ( getDirs )
2021-07-18 21:29:09 +00:00
import GHCup.Types hiding ( LeanAppState(..) )
2020-07-06 20:39:16 +00:00
import GHCup.Utils
2022-12-20 13:28:49 +00:00
import GHCup.OptParse.Common (logGHCPostRm)
2022-05-21 20:54:18 +00:00
import GHCup.Prelude ( decUTF8Safe )
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Prompts
2020-07-06 20:39:16 +00:00
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
2020-10-11 19:07:13 +00:00
import Brick.Widgets.List ( listSelectedFocusedAttr
, listSelectedAttr
, listAttr
)
2020-07-06 20:39:16 +00:00
import Codec.Archive
import Control.Exception.Safe
2021-11-02 18:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-07-06 20:39:16 +00:00
import Control.Monad.Reader
2021-05-14 21:09:45 +00:00
import Control.Monad.Trans.Except
2020-07-06 20:39:16 +00:00
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
import Data.List
import Data.Maybe
import Data.IORef
2020-10-11 19:07:13 +00:00
import Data.Vector ( Vector
, (!?)
)
import Data.Versions
2020-07-06 20:39:16 +00:00
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.FilePath
2020-07-06 20:39:16 +00:00
import System.Exit
import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-07-06 20:39:16 +00:00
import URI.ByteString
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy as L
2020-07-06 20:39:16 +00:00
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
import System.Environment (getExecutablePath)
import qualified System.Posix.Process as SPP
2020-07-06 20:39:16 +00:00
2020-10-11 19:07:13 +00:00
2021-05-14 21:09:45 +00:00
hiddenTools :: [Tool]
2021-07-23 14:13:07 +00:00
hiddenTools = []
2021-05-14 21:09:45 +00:00
2020-10-11 19:07:13 +00:00
2020-10-23 23:06:53 +00:00
data BrickData = BrickData
2020-10-11 19:07:13 +00:00
{ lr :: [ListResult]
}
deriving Show
2020-10-23 23:06:53 +00:00
data BrickSettings = BrickSettings
{ showAllVersions :: Bool
, showAllTools :: Bool
2020-10-11 19:07:13 +00:00
}
deriving Show
2020-10-23 23:06:53 +00:00
data BrickInternalState = BrickInternalState
2020-10-11 19:07:13 +00:00
{ clr :: Vector ListResult
, ix :: Int
}
deriving Show
2020-07-06 20:39:16 +00:00
2020-10-23 23:06:53 +00:00
data BrickState = BrickState
{ appData :: BrickData
, appSettings :: BrickSettings
, appState :: BrickInternalState
, appKeys :: KeyBindings
2020-10-11 19:07:13 +00:00
}
deriving Show
2020-07-06 20:39:16 +00:00
keyHandlers :: KeyBindings
-> [ ( KeyCombination
2020-10-23 23:06:53 +00:00
, BrickSettings -> String
, BrickState -> EventM String BrickState ()
)
]
keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , \_ -> halt)
, (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
2021-05-14 22:31:36 +00:00
, ( bShowAllVersions
2021-03-11 16:03:51 +00:00
, \BrickSettings {..} ->
2021-05-14 22:31:36 +00:00
if showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler (not . showAllVersions) showAllTools
)
, ( bShowAllTools
, \BrickSettings {..} ->
if showAllTools then "Don't show all tools" else "Show all tools"
, hideShowHandler showAllVersions (not . showAllTools)
)
, (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
, (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
2020-07-06 20:39:16 +00:00
]
2020-10-11 19:07:13 +00:00
where
2021-05-14 22:31:36 +00:00
hideShowHandler f p BrickState{..} =
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
2020-10-11 19:07:13 +00:00
newInternalState = constructList appData newAppSettings (Just appState)
in put (BrickState appData newAppSettings newInternalState appKeys)
showKey :: Vty.Key -> String
showKey (Vty.KChar c) = [c]
2021-03-11 16:03:51 +00:00
showKey Vty.KUp = ""
showKey Vty.KDown = ""
showKey key = tail (show key)
2020-07-06 20:39:16 +00:00
showMod :: Vty.Modifier -> String
showMod = tail . show
2020-07-06 20:39:16 +00:00
ui :: AttrMap -> BrickState -> Widget String
2021-03-11 16:03:51 +00:00
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
= padBottom Max
( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
(center (header <=> hBorder <=> renderList' appState))
2020-07-06 20:39:16 +00:00
)
2020-09-20 21:06:35 +00:00
<=> footer
2020-07-06 20:39:16 +00:00
where
2020-09-20 21:06:35 +00:00
footer =
withAttr (attrName "help")
2020-09-20 21:06:35 +00:00
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
2021-03-11 16:03:51 +00:00
$ keyHandlers appKeys
2020-09-20 21:06:35 +00:00
header =
2021-03-11 16:03:51 +00:00
minHSize 2 emptyWidget
<+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
<+> minHSize 15 (str "Version")
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes")
renderList' bis@BrickInternalState{..} =
2023-07-07 09:36:25 +00:00
let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr
minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr
in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
2020-07-06 20:39:16 +00:00
let marks = if
| lSet -> (withAttr (attrName "set") $ str "✔✔")
| lInstalled -> (withAttr (attrName "installed") $ str "")
| otherwise -> (withAttr (attrName "not-installed") $ str "")
2020-07-06 20:39:16 +00:00
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim
2021-03-11 16:03:51 +00:00
| lNoBindist && not lInstalled
&& not b -- TODO: overloading dim and active ignores active
-- so we hack around it here
= updateAttrMap (const dimAttrs) . withAttr (attrName "no-bindist")
| otherwise = id
2020-10-11 19:44:11 +00:00
hooray
| elem Latest lTag' && not lInstalled =
withAttr (attrName "hooray")
2020-10-11 19:44:11 +00:00
| otherwise = id
active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr (attrName "active") else id
2020-10-11 19:44:11 +00:00
in hooray $ active $ dim
( marks
2021-03-11 16:03:51 +00:00
<+> padLeft (Pad 2)
( minHSize 6
(printTool lTool)
2020-09-20 21:06:35 +00:00
)
2023-07-07 09:36:25 +00:00
<+> minHSize minVerSize (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag'
in padLeft (Pad 1) $ minHSize minTagSize $ if null l
2020-10-11 19:07:13 +00:00
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) l
)
2021-03-11 16:03:51 +00:00
<+> padLeft (Pad 5)
( let notes = printNotes listResult
in if null notes
then emptyWidget
2021-03-11 16:03:51 +00:00
else foldr1 (\x y -> x <+> str "," <+> y) notes
)
2021-03-11 16:03:51 +00:00
<+> vLimit 1 (fill ' ')
)
2020-07-06 20:39:16 +00:00
printTag Recommended = Just $ withAttr (attrName "recommended") $ str "recommended"
printTag Latest = Just $ withAttr (attrName "latest") $ str "latest"
printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease"
printTag Nightly = Just $ withAttr (attrName "nightly") $ str "nightly"
2020-10-11 19:07:13 +00:00
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing
printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease"
printTag LatestNightly = Just $ withAttr (attrName "latest-nightly") $ str "latest-nightly"
2020-10-11 19:07:13 +00:00
printTag (UnknownTag t) = Just $ str t
printTool Cabal = str "cabal"
printTool GHC = str "GHC"
printTool GHCup = str "GHCup"
printTool HLS = str "HLS"
2021-05-14 22:31:36 +00:00
printTool Stack = str "Stack"
2020-07-06 20:39:16 +00:00
2020-09-20 21:06:35 +00:00
printNotes ListResult {..} =
(if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty
2020-09-20 21:06:35 +00:00
)
++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)
++ (case lReleaseDay of
Nothing -> mempty
Just d -> [withAttr (attrName "day") $ str (show d)])
2020-09-20 21:06:35 +00:00
2020-10-11 19:07:13 +00:00
-- | 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 -> Widget String)
-> Bool
2020-10-23 23:06:53 +00:00
-> BrickInternalState
2020-10-11 19:07:13 +00:00
-> Widget String
2020-10-23 23:06:53 +00:00
drawListElements drawElem foc is@(BrickInternalState clr _) =
2020-10-11 21:37:27 +00:00
Widget Greedy Greedy $
2020-10-11 19:07:13 +00:00
let
2020-10-11 21:37:27 +00:00
es = clr
2020-10-11 19:07:13 +00:00
listSelected = fmap fst $ listSelectedElement' is
drawnElements = flip V.imap es $ \i' e ->
2020-10-11 21:37:27 +00:00
let addSeparator w = case es !? (i' - 1) of
2020-10-11 19:07:13 +00:00
Just e' | lTool e' /= lTool e ->
hBorder <=> w
_ -> w
2020-10-11 21:37:27 +00:00
isSelected = Just i' == listSelected
elemWidget = drawElem i' isSelected e
2020-10-11 19:07:13 +00:00
selItemAttr = if foc
then withDefAttr listSelectedFocusedAttr
else withDefAttr listSelectedAttr
makeVisible' = if isSelected then visible . selItemAttr else id
in addSeparator $ makeVisible' elemWidget
2020-10-11 19:07:13 +00:00
2020-10-11 21:37:27 +00:00
in render
2020-10-11 19:07:13 +00:00
$ viewport "GHCup" Vertical
$ vBox
$ V.toList drawnElements
2020-07-06 20:39:16 +00:00
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: AttrMap -> AttrMap -> App BrickState e String
app attrs dimAttrs =
App { appDraw = \st -> [ui dimAttrs st]
, appHandleEvent = \be -> get >>= \s -> eventHandler s be
, appStartEvent = return ()
, appAttrMap = const attrs
, appChooseCursor = showFirstCursor
}
defaultAttributes :: Bool -> AttrMap
defaultAttributes no_color = attrMap
Vty.defAttr
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue)
, (attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "set" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "installed" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow)
, (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "nightly" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "day" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
]
where
withForeColor | no_color = const
| otherwise = Vty.withForeColor
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor
withStyle = Vty.withStyle
dimAttributes :: Bool -> AttrMap
dimAttributes no_color = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ??
, (attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
where
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor
eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState ()
2021-03-11 16:03:51 +00:00
eventHandler st@BrickState{..} ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of
(MouseDown _ Vty.BScrollUp _ _) ->
put (BrickState { appState = moveCursor 1 appState Up, .. })
(MouseDown _ Vty.BScrollDown _ _) ->
put (BrickState { appState = moveCursor 1 appState Down, .. })
(VtyEvent (Vty.EvResize _ _)) -> put st
(VtyEvent (Vty.EvKey Vty.KUp [])) ->
put BrickState{ appState = moveCursor 1 appState Up, .. }
(VtyEvent (Vty.EvKey Vty.KDown [])) ->
put BrickState{ appState = moveCursor 1 appState Down, .. }
(VtyEvent (Vty.EvKey key mods)) ->
case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
Nothing -> put st
Just (_, _, handler) -> handler st
_ -> put st
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
2021-03-11 16:03:51 +00:00
moveCursor steps ais@BrickInternalState{..} direction =
let newIx = if direction == Down then ix + steps else ix - steps
2020-10-11 19:07:13 +00:00
in case clr !? newIx of
2020-10-23 23:06:53 +00:00
Just _ -> BrickInternalState { ix = newIx, .. }
2020-10-11 19:07:13 +00:00
Nothing -> ais
2020-07-06 20:39:16 +00:00
-- | 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
=> (BrickState
2021-05-14 21:09:45 +00:00
-> (Int, ListResult)
-> ReaderT AppState IO (Either String a))
2020-10-23 23:06:53 +00:00
-> BrickState
-> EventM n BrickState ()
2020-10-11 19:07:13 +00:00
withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> put as
2021-05-14 21:09:45 +00:00
Just (ix, e) -> do
suspendAndResume $ do
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
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
2020-07-06 20:39:16 +00:00
2020-10-11 19:07:13 +00:00
-- | Update app data and list internal state based on new evidence.
2020-10-23 23:06:53 +00:00
-- This synchronises @BrickInternalState@ with @BrickData@
-- and @BrickSettings@.
updateList :: BrickData -> BrickState -> BrickState
2021-03-11 16:03:51 +00:00
updateList appD BrickState{..} =
2020-10-11 19:07:13 +00:00
let newInternalState = constructList appD appSettings (Just appState)
2020-10-23 23:06:53 +00:00
in BrickState { appState = newInternalState
, appData = appD
, appSettings = appSettings
, appKeys = appKeys
}
2020-10-11 19:07:13 +00:00
2020-10-23 23:06:53 +00:00
constructList :: BrickData
-> BrickSettings
-> Maybe BrickInternalState
-> BrickInternalState
2021-03-11 16:03:51 +00:00
constructList appD appSettings =
2021-05-14 21:09:45 +00:00
replaceLR (filterVisible (showAllVersions appSettings)
(showAllTools appSettings))
(lr appD)
2020-10-11 19:07:13 +00:00
2020-10-23 23:06:53 +00:00
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
2021-03-11 16:03:51 +00:00
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
2020-10-11 19:07:13 +00:00
selectLatest :: Vector ListResult -> Int
2021-10-15 20:24:23 +00:00
selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
2020-10-11 19:07:13 +00:00
-- | 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]
2020-10-23 23:06:53 +00:00
-> Maybe BrickInternalState
-> BrickInternalState
2020-10-11 19:07:13 +00:00
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
2020-10-23 23:06:53 +00:00
in BrickInternalState newVec newSelected
2020-10-11 19:07:13 +00:00
where
toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
2021-05-14 21:09:45 +00:00
filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True
| v
, not t
, Nightly `notElem` lTag e
2021-10-15 20:24:23 +00:00
, lTool e `notElem` hiddenTools = True
2021-05-14 21:09:45 +00:00
| not v
, t
, Old `notElem` lTag e
, Nightly `notElem` lTag e = True
2021-05-14 21:09:45 +00:00
| v
, Nightly `notElem` lTag e
2021-05-14 21:09:45 +00:00
, t = True
| otherwise = (Old `notElem` lTag e) &&
(Nightly `notElem` lTag e) &&
2021-10-15 20:24:23 +00:00
(lTool e `notElem` hiddenTools)
2021-05-14 21:09:45 +00:00
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
2020-10-11 19:07:13 +00:00
let run =
2021-08-30 20:41:58 +00:00
runResourceT
2020-10-11 19:07:13 +00:00
. runE
@'[ AlreadyInstalled
, ArchiveResult
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
2021-09-18 17:45:32 +00:00
, GPGError
2020-10-11 19:07:13 +00:00
, DownloadFailed
2021-08-11 10:24:51 +00:00
, DirNotEmpty
2020-10-11 19:07:13 +00:00
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
2021-10-10 18:02:15 +00:00
, ProcessError
2022-05-23 14:48:29 +00:00
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
2020-10-11 19:07:13 +00:00
]
2020-07-06 20:39:16 +00:00
2021-03-11 16:03:51 +00:00
run (do
ce <- liftIO $ fmap (either (const Nothing) Just) $
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
dirs <- lift getDirs
2020-07-06 20:39:16 +00:00
case lTool of
GHC -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross 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
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
2021-05-14 22:31:36 +00:00
Stack -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
2020-07-06 20:39:16 +00:00
)
>>= \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
liftIO $ SPP.executeFile ce False ["tui"] 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 ()
2020-07-06 20:39:16 +00:00
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left $ prettyHFError e <> "\n"
2021-08-25 16:54:58 +00:00
<> "Also check the logs in ~/.ghcup/logs"
2020-07-06 20:39:16 +00:00
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'
2020-07-06 20:39:16 +00:00
let run =
2021-08-30 20:41:58 +00:00
flip runReaderT settings
2020-10-11 19:07:13 +00:00
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
2020-07-06 20:39:16 +00:00
2021-03-11 16:03:51 +00:00
run (do
2020-07-06 20:39:16 +00:00
case lTool of
2022-02-09 17:57:59 +00:00
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
2020-07-06 20:39:16 +00:00
Cabal -> liftE $ setCabal lVer $> ()
2022-02-09 17:57:59 +00:00
HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
2021-05-14 22:31:36 +00:00
Stack -> liftE $ setStack lVer $> ()
2020-07-06 20:39:16 +00:00
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 (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)
2020-07-06 20:39:16 +00:00
2021-05-14 21:09:45 +00:00
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
2020-07-06 20:39:16 +00:00
let run = runE @'[NotInstalled, UninstallFailed]
2020-07-06 20:39:16 +00:00
2021-03-11 16:03:51 +00:00
run (do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls
2020-07-06 20:39:16 +00:00
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi
HLS -> liftE $ rmHLSVer lVer $> vi
2021-05-14 22:31:36 +00:00
Stack -> liftE $ rmStackVer lVer $> vi
GHCup -> pure Nothing
2020-07-06 20:39:16 +00:00
)
>>= \case
VRight vi -> do
when (lTool == GHC) $ logGHCPostRm (mkTVer lVer)
2021-10-15 20:24:23 +00:00
forM_ (_viPostRemove =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyHFError e)
2020-07-06 20:39:16 +00:00
2021-05-14 21:09:45 +00:00
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 (ToolVersion lVer) of
2021-08-25 16:54:58 +00:00
Nothing -> pure $ Left $
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
2020-07-06 20:39:16 +00:00
Just uri -> do
2020-07-13 21:10:17 +00:00
let cmd = case _rPlatform pfreq of
2020-10-11 19:07:13 +00:00
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
2021-05-14 21:09:45 +00:00
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
2020-07-06 20:39:16 +00:00
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyHFError e
2020-07-06 20:39:16 +00:00
2020-10-23 23:06:53 +00:00
settings' :: IORef AppState
2020-07-06 20:39:16 +00:00
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
2021-07-18 21:29:09 +00:00
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, consoleOutter = \_ -> pure ()
, fileOutter = \_ -> pure ()
, fancyColors = True
2021-08-30 20:41:58 +00:00
}
newIORef $ AppState defaultSettings
2020-10-23 23:06:53 +00:00
dirs
defaultKeyBindings
2021-05-14 21:09:45 +00:00
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
2021-08-30 20:41:58 +00:00
loggerConfig
2020-10-23 23:06:53 +00:00
2020-07-06 20:39:16 +00:00
2020-10-23 23:06:53 +00:00
brickMain :: AppState
2020-10-11 19:07:13 +00:00
-> IO ()
2021-08-30 20:41:58 +00:00
brickMain s = do
2020-07-06 20:39:16 +00:00
writeIORef settings' s
2021-07-18 21:29:09 +00:00
eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of
2020-10-11 19:07:13 +00:00
Right ad ->
defaultMain
(app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s)))
2020-10-23 23:06:53 +00:00
(BrickState ad
2020-10-11 19:07:13 +00:00
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
2021-07-18 21:29:09 +00:00
(keyBindings (s :: AppState))
2020-10-11 19:07:13 +00:00
)
$> ()
Left e -> do
2021-08-30 20:41:58 +00:00
flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
2020-07-06 20:39:16 +00:00
exitWith $ ExitFailure 2
2020-10-23 23:06:53 +00:00
defaultAppSettings :: BrickSettings
2021-05-14 22:31:36 +00:00
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
2021-05-14 21:09:45 +00:00
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
2020-07-06 20:39:16 +00:00
settings <- readIORef settings'
r <-
2021-08-30 20:41:58 +00:00
flip runReaderT settings
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
2021-10-15 20:24:23 +00:00
$ liftE getDownloadsF
2020-07-06 20:39:16 +00:00
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyHFError e)
2021-05-14 21:09:45 +00:00
getAppData :: Maybe GHCupInfo
2020-10-23 23:06:53 +00:00
-> IO (Either String BrickData)
2021-05-14 21:09:45 +00:00
getAppData mgi = runExceptT $ do
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
2021-08-30 20:41:58 +00:00
flip runReaderT settings $ do
lV <- listVersions Nothing [] False True (Nothing, Nothing)
2021-05-14 21:09:45 +00:00
pure $ BrickData (reverse lV)