ghcup-hs/app/ghcup/BrickMain.hs

395 lines
13 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2020-07-06 20:39:16 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List
#if !defined(TAR)
2020-07-06 20:39:16 +00:00
import Codec.Archive
#endif
2020-07-06 20:39:16 +00:00
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Exit
import System.IO.Unsafe
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
2020-07-13 16:27:21 +00:00
, pfreq :: PlatformRequest
2020-07-06 20:39:16 +00:00
}
type LR = GenericList String Vector ListResult
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
keyHandlers =
[ ('q', "Quit" , halt)
, ('i', "Install" , withIOAction install')
, ('u', "Uninstall", withIOAction del')
, ('s', "Set" , withIOAction set')
, ('c', "ChangeLog", withIOAction changelog')
]
ui :: AppState -> Widget String
ui AppState {..} =
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
2020-09-20 21:06:35 +00:00
$ (center $ (header <=> hBorder <=> renderList renderItem True lr))
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 "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
header =
(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")
renderItem b listResult@(ListResult {..}) =
2020-07-06 20:39:16 +00:00
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
| otherwise -> (withAttr "not-installed" $ str "")
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim = if lNoBindist
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
else id
2020-09-20 21:06:35 +00:00
active = if b then withAttr "active" else id
in dim
( marks
2020-09-20 21:06:35 +00:00
<+> (( padLeft (Pad 2)
$ active
$ minHSize 6
$ (str (fmap toLower . show $ lTool))
)
2020-07-06 20:39:16 +00:00
)
2020-09-20 21:06:35 +00:00
<+> (minHSize 15 $ active $ (str ver))
<+> (padLeft (Pad 1) $ minHSize 25 $ if null lTag
then emptyWidget
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
<+> ( padLeft (Pad 5)
$ let notes = printNotes listResult
in if null notes
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
)
)
2020-07-06 20:39:16 +00:00
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
2020-07-28 18:55:00 +00:00
printTag Prerelease = withAttr "prerelease" $ str "prerelease"
2020-07-06 20:39:16 +00:00
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
2020-09-20 21:06:35 +00:00
printNotes ListResult {..} =
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
)
++ (if fromSrc then [withAttr "compiled" $ str "compiled"] else mempty)
++ (if lStray then [withAttr "stray" $ str "stray"] else mempty)
2020-07-06 20:39:16 +00:00
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const defaultAttributes
2020-07-06 20:39:16 +00:00
, appChooseCursor = neverShowCursor
}
defaultAttributes :: AttrMap
defaultAttributes = attrMap
Vty.defAttr
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("hls-powered" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
2020-07-28 18:55:00 +00:00
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
2020-09-20 21:06:35 +00:00
, ("compiled" , Vty.defAttr `Vty.withForeColor` Vty.blue)
, ("stray" , Vty.defAttr `Vty.withForeColor` Vty.blue)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
]
dimAttributes :: AttrMap
dimAttributes = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
2020-07-06 20:39:16 +00:00
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
2020-07-13 16:27:21 +00:00
continue (AppState (listMoveUp lr) dls pfreq)
2020-07-06 20:39:16 +00:00
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
2020-07-13 16:27:21 +00:00
continue (AppState (listMoveDown lr) dls pfreq)
2020-07-06 20:39:16 +00:00
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st _ = continue st
-- | 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 :: (AppState -> (Int, ListResult) -> IO (Either String a))
-> AppState
-> EventM n (Next AppState)
withIOAction action as = case listSelectedElement (lr as) of
Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do
2020-07-28 19:53:54 +00:00
action as (ix, e) >>= \case
Left err -> putStrLn $ ("Error: " <> err)
Right _ -> putStrLn "Success"
apps <- (fmap . fmap)
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
$ getAppState Nothing (pfreq as)
case apps of
Right nas -> do
putStrLn "Press enter to continue"
_ <- getLine
pure nas
Left err -> throwIO $ userError err
2020-07-06 20:39:16 +00:00
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
install' AppState {..} (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let
run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
2020-08-06 11:28:20 +00:00
, NoUpdate
, TarDirDoesNotExist
]
2020-07-06 20:39:16 +00:00
(run $ do
case lTool of
2020-07-13 16:27:21 +00:00
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
HLS -> liftE $ installHLSBin dls lVer pfreq $> ()
2020-07-06 20:39:16 +00:00
)
>>= \case
VRight _ -> pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|]
VLeft (V NoDownload) ->
pure $ Left [i|No available version for #{prettyVer lVer}|]
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}
Also check the logs in ~/.ghcup/logs|]
set' :: AppState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
(run $ do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
2020-07-06 20:39:16 +00:00
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
del' :: AppState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
HLS -> liftE $ rmHLSVer lVer $> ()
2020-07-06 20:39:16 +00:00
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState {..} (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
2020-07-13 21:10:17 +00:00
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
2020-07-06 20:39:16 +00:00
Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|]
uri' :: IORef (Maybe URI)
{-# NOINLINE uri' #-}
uri' = unsafePerformIO (newIORef Nothing)
2020-07-06 20:39:16 +00:00
settings' :: IORef Settings
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getDirs
newIORef Settings { cache = True
2020-07-06 20:39:16 +00:00
, noVerify = False
, keepDirs = Never
, downloader = Curl
2020-07-13 09:52:34 +00:00
, verbose = False
, ..
2020-07-06 20:39:16 +00:00
}
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
2020-07-13 16:27:21 +00:00
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain s muri l av pfreq' = do
writeIORef uri' muri
2020-07-06 20:39:16 +00:00
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
2020-07-13 16:27:21 +00:00
eApps <- getAppState (Just av) pfreq'
2020-07-06 20:39:16 +00:00
case eApps of
Right as -> defaultMain app (selectLatest as) $> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
where
selectLatest :: AppState -> AppState
selectLatest AppState {..} =
(\ix -> AppState { lr = listMoveTo ix lr, .. })
. fromJust
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
$ (listElements lr)
2020-07-13 16:27:21 +00:00
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState mg pfreq' = do
muri <- readIORef uri'
2020-07-06 20:39:16 +00:00
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE
2020-07-13 16:27:21 +00:00
@'[JSONError, DownloadFailed, FileDoesNotExistError]
2020-07-06 20:39:16 +00:00
$ do
2020-07-13 16:27:21 +00:00
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
2020-07-06 20:39:16 +00:00
2020-07-13 16:27:21 +00:00
lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
2020-07-06 20:39:16 +00:00
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]