482 lines
15 KiB
Haskell
482 lines
15 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
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)
|
|
import Codec.Archive
|
|
#endif
|
|
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
|
|
import qualified Brick.Widgets.List as L
|
|
|
|
|
|
data AppData = AppData {
|
|
lr :: LR
|
|
, dls :: GHCupDownloads
|
|
, pfreq :: PlatformRequest
|
|
} deriving Show
|
|
|
|
data AppSettings = AppSettings {
|
|
showAll :: Bool
|
|
} deriving Show
|
|
|
|
data AppState = AppState {
|
|
appData :: AppData
|
|
, appSettings :: AppSettings
|
|
} deriving Show
|
|
|
|
type LR = GenericList String Vector ListResult
|
|
|
|
|
|
keyHandlers :: [ ( Char
|
|
, AppSettings -> String
|
|
, AppState -> EventM n (Next AppState)
|
|
)
|
|
]
|
|
keyHandlers =
|
|
[ ('q', const "Quit" , halt)
|
|
, ('i', const "Install" , withIOAction install')
|
|
, ('u', const "Uninstall", withIOAction del')
|
|
, ('s', const "Set" , withIOAction set')
|
|
, ('c', const "ChangeLog", withIOAction changelog')
|
|
, ( 'a'
|
|
, (\AppSettings {..} ->
|
|
if showAll then "Hide old versions" else "Show all versions"
|
|
)
|
|
, (\AppState {..} ->
|
|
let newAppSettings =
|
|
appSettings { showAll = not . showAll $ appSettings }
|
|
in continue (AppState appData newAppSettings)
|
|
)
|
|
)
|
|
]
|
|
|
|
|
|
ui :: AppState -> Widget String
|
|
ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
|
|
( padBottom Max
|
|
$ ( withBorderStyle unicode
|
|
$ borderWithLabel (str "GHCup")
|
|
$ ( center
|
|
$ (header <=> hBorder <=> renderList
|
|
renderItem
|
|
True
|
|
(L.listReverse lr)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
<=> footer
|
|
|
|
where
|
|
footer =
|
|
withAttr "help"
|
|
. txtWrap
|
|
. T.pack
|
|
. foldr1 (\x y -> x <> " " <> y)
|
|
. (++ ["↑↓:Navigation"])
|
|
$ (fmap (\(c, s, _) -> (c : ':' : s as)) 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 {..}) =
|
|
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
|
|
active = if b then withAttr "active" else id
|
|
in dim
|
|
( marks
|
|
<+> (( padLeft (Pad 2)
|
|
$ active
|
|
$ minHSize 6
|
|
$ (str (fmap toLower . show $ lTool))
|
|
)
|
|
)
|
|
<+> (minHSize 15 $ active $ (str ver))
|
|
<+> (let l = catMaybes . fmap printTag $ sort lTag
|
|
in padLeft (Pad 1) $ minHSize 25 $
|
|
if null l
|
|
then emptyWidget
|
|
else foldr1 (\x y -> x <+> str "," <+> y) l
|
|
)
|
|
<+> ( padLeft (Pad 5)
|
|
$ let notes = printNotes listResult
|
|
in if null notes
|
|
then emptyWidget
|
|
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
|
|
)
|
|
)
|
|
|
|
printTag Recommended = Just $ withAttr "recommended" $ str "recommended"
|
|
printTag Latest = Just $ withAttr "latest" $ str "latest"
|
|
printTag Prerelease = Just $ withAttr "prerelease" $ str "prerelease"
|
|
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
|
|
printTag Old = Nothing
|
|
printTag (UnknownTag t ) = Just $ str t
|
|
|
|
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)
|
|
|
|
|
|
|
|
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
|
|
, 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)
|
|
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
|
|
, ("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)
|
|
]
|
|
|
|
|
|
|
|
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 { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KUp) _))
|
|
= continue (AppState (AppData (listMoveUp lr) dls pfreq) appSettings)
|
|
eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KDown) _))
|
|
= continue (AppState (AppData (listMoveDown lr) dls pfreq) appSettings)
|
|
eventHandler as@(AppState appD appS) (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
|
case find (\(c', _, _) -> c' == c) keyHandlers of
|
|
Nothing -> continue as
|
|
Just ('a', _, handler) ->
|
|
if (not $ showAll appS) -- it's not swapped to `showAll` yet, but it will in the handler
|
|
then do
|
|
newAppData <- liftIO $ replaceLR (\_ -> True) appD
|
|
handler (AppState (selectLatest newAppData) appS)
|
|
else do -- hide old versions
|
|
newAppData <- liftIO $ replaceLR (filterVisible (not $ showAll appS)) appD
|
|
handler (AppState (selectLatest newAppData) appS)
|
|
Just (_, _, handler) -> handler as
|
|
eventHandler st _ = continue st
|
|
|
|
|
|
replaceLR :: (ListResult -> Bool) -> AppData -> IO AppData
|
|
replaceLR filterF (AppData {..}) = do
|
|
settings <- liftIO $ readIORef settings'
|
|
l <- liftIO $ readIORef logger'
|
|
let runLogger = myLoggerT l
|
|
lV <- runLogger
|
|
. flip runReaderT settings
|
|
. fmap (V.fromList . filter filterF)
|
|
. listVersions dls Nothing Nothing
|
|
$ pfreq
|
|
pure $ AppData { lr = L.listReplace lV Nothing $ lr, .. }
|
|
|
|
|
|
filterVisible :: Bool -> ListResult -> Bool
|
|
filterVisible showAll e
|
|
| lInstalled e = True
|
|
| showAll = True
|
|
| otherwise = not (elem Old (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 :: (AppState -> (Int, ListResult) -> IO (Either String a))
|
|
-> AppState
|
|
-> EventM n (Next AppState)
|
|
withIOAction action as = case listSelectedElement (lr . appData $ as) of
|
|
Nothing -> continue as
|
|
Just (ix, e) -> suspendAndResume $ do
|
|
action as (ix, e) >>= \case
|
|
Left err -> putStrLn $ ("Error: " <> err)
|
|
Right _ -> putStrLn "Success"
|
|
apps <-
|
|
(fmap . fmap)
|
|
(\AppData {..} -> AppState
|
|
{ appData = AppData { lr = listMoveTo ix lr, .. }
|
|
, appSettings = (appSettings as)
|
|
}
|
|
)
|
|
$ getAppData Nothing (pfreq . appData $ as)
|
|
case apps of
|
|
Right nas -> do
|
|
putStrLn "Press enter to continue"
|
|
_ <- getLine
|
|
pure nas
|
|
Left err -> throwIO $ userError err
|
|
|
|
|
|
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
|
install' AppState { appData = AppData {..}} (_, 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
|
|
, NoUpdate
|
|
, TarDirDoesNotExist
|
|
]
|
|
|
|
(run $ do
|
|
case lTool of
|
|
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 $> ()
|
|
)
|
|
>>= \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 $> ()
|
|
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 $> ()
|
|
GHCup -> pure ()
|
|
)
|
|
>>= \case
|
|
VRight _ -> pure $ Right ()
|
|
VLeft e -> pure $ Left [i|#{e}|]
|
|
|
|
|
|
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
|
changelog' AppState { appData = AppData {..}} (_, 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
|
|
let cmd = case _rPlatform pfreq of
|
|
Darwin -> "open"
|
|
Linux _ -> "xdg-open"
|
|
FreeBSD -> "xdg-open"
|
|
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
|
|
Right _ -> pure $ Right ()
|
|
Left e -> pure $ Left [i|#{e}|]
|
|
|
|
|
|
uri' :: IORef (Maybe URI)
|
|
{-# NOINLINE uri' #-}
|
|
uri' = unsafePerformIO (newIORef Nothing)
|
|
|
|
|
|
settings' :: IORef Settings
|
|
{-# NOINLINE settings' #-}
|
|
settings' = unsafePerformIO $ do
|
|
dirs <- getDirs
|
|
newIORef Settings { cache = True
|
|
, noVerify = False
|
|
, keepDirs = Never
|
|
, downloader = Curl
|
|
, verbose = False
|
|
, ..
|
|
}
|
|
|
|
|
|
logger' :: IORef LoggerConfig
|
|
{-# NOINLINE logger' #-}
|
|
logger' = unsafePerformIO
|
|
(newIORef $ LoggerConfig { lcPrintDebug = False
|
|
, colorOutter = \_ -> pure ()
|
|
, rawOutter = \_ -> pure ()
|
|
}
|
|
)
|
|
|
|
|
|
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
|
|
brickMain s muri l av pfreq' = do
|
|
writeIORef uri' muri
|
|
writeIORef settings' s
|
|
-- logger interpreter
|
|
writeIORef logger' l
|
|
let runLogger = myLoggerT l
|
|
|
|
eAppData <- getAppData (Just av) pfreq'
|
|
case eAppData of
|
|
Right ad -> defaultMain app (AppState (selectLatest ad) defaultAppSettings) $> ()
|
|
Left e -> do
|
|
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
|
exitWith $ ExitFailure 2
|
|
|
|
|
|
selectLatest :: AppData -> AppData
|
|
selectLatest (AppData {..}) =
|
|
(\ix -> AppData { lr = listMoveTo ix lr, .. } )
|
|
. fromJust
|
|
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
|
|
$ (listElements lr)
|
|
|
|
|
|
defaultAppSettings :: AppSettings
|
|
defaultAppSettings = AppSettings {
|
|
showAll = False
|
|
}
|
|
|
|
|
|
getDownloads' :: IO (Either String GHCupDownloads)
|
|
getDownloads' = do
|
|
muri <- readIORef uri'
|
|
settings <- readIORef settings'
|
|
l <- readIORef logger'
|
|
let runLogger = myLoggerT l
|
|
|
|
r <-
|
|
runLogger
|
|
. flip runReaderT settings
|
|
. runE
|
|
@'[JSONError, DownloadFailed, FileDoesNotExistError]
|
|
$ fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)
|
|
|
|
case r of
|
|
VRight a -> pure $ Right a
|
|
VLeft e -> pure $ Left [i|#{e}|]
|
|
|
|
|
|
getAppData :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppData)
|
|
getAppData mg pfreq' = do
|
|
settings <- readIORef settings'
|
|
l <- readIORef logger'
|
|
let runLogger = myLoggerT l
|
|
|
|
r <- maybe getDownloads' (pure . Right) mg
|
|
|
|
runLogger
|
|
. flip runReaderT settings
|
|
$ do
|
|
case r of
|
|
Right dls -> do
|
|
lV <- listVersions dls Nothing Nothing pfreq'
|
|
pure $ Right $ (AppData (list "Tool versions"
|
|
(V.fromList . filter (filterVisible (showAll defaultAppSettings)) $ lV) 1) dls pfreq')
|
|
Left e -> pure $ Left [i|#{e}|]
|