diff --git a/app/ghcup/AnsiMain.hs b/app/ghcup/AnsiMain.hs index 1822f9e..2aa12a1 100644 --- a/app/ghcup/AnsiMain.hs +++ b/app/ghcup/AnsiMain.hs @@ -14,10 +14,15 @@ 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) +import Data.Maybe (catMaybes) +import Codec.Archive import Control.Monad.IO.Class import Control.Monad.Trans.Except -- import System.Console.ANSI @@ -27,9 +32,13 @@ import System.Console.ANSI.Types import Terminal.Game import Text.PrettyPrint.HughesPJClass ( prettyShow ) -import Control.Monad ( join, when ) +import Control.Exception.Safe +import Control.Monad ( join, when, void, forM_ ) import Control.Monad.ST -import Control.Monad.Reader ( ReaderT(runReaderT) ) +import Control.Monad.Reader ( ReaderT(runReaderT), MonadReader, ask, lift ) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Resource +import Data.Functor import Data.Bifunctor import Data.STRef import Data.IORef @@ -40,7 +49,15 @@ import qualified Data.Vector as V import GHC.IO ( unsafePerformIO ) import Haskus.Utils.Variant.Excepts import System.Exit +import System.Environment (getExecutablePath) import Data.Versions (prettyVer) +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 @@ -69,10 +86,22 @@ data BrickState = BrickState , 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 @@ -85,10 +114,12 @@ ansiMain s = do (constructList ad defaultAppSettings Nothing) (keyBindings (s :: AppState)) False + False Nothing - errorPress $ playGame (ghcupGame g) + void $ startGame g + cleanAndExit Left e -> do flip runReaderT s $ logError $ "Error building app state: " <> Tx.pack (show e) @@ -102,40 +133,64 @@ ansiMain s = do ghcupGame :: BrickState -> Game BrickState ghcupGame bs = Game 13 - bs -- ticks per second - (\ge s e -> logicFun ge s e) -- logic function + bs -- ticks per second + (\ge s e -> logicFun ge s e) -- logic function (\r s -> centerFull r $ drawFun s r) -- draw function - appQuit -- quit function + (\bs -> appQuit bs || appRestart bs) -- quit function drawFun :: BrickState -> GEnv -> Plane drawFun (BrickState {..}) GEnv{..} = blankPlane mw mh & (1, 1) % box 1 1 '┌' - & (2, 1) % box 1 (mh - 2) '│' + & (2, 1) % box 1 (mh - 3) '│' & (1, 2) % box (mw - 2) 1 '─' - & (2, mw) % box 1 (mh - 2) '│' + & (2, mw) % box 1 (mh - 3) '│' & (1, mw) % box 1 1 '┐' - & (mh, 2) % box (mw - 2) 1 '─' - & (mh, 1) % box 1 1 '└' - & (mh, mw) % box 1 1 '┘' - & (2, 2) % box (mw - 2) (mh - 2) ' ' - & (2, 2) % renderItems + & (mh-1, 2) % box (mw - 2) 1 '─' + & (mh-1, 1) % box 1 1 '└' + & (mh-1, mw) % box 1 1 '┘' + & (2, 2) % box (mw - 2) (mh - 3) ' ' + & (2, 2) % (header === box (mw - 2) 1 '─' === renderItems) + & (mh, 1) % footer + & (1, mw `div` 2 - 2) % stringPlane "GHCup" where 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 = hcat + . intersperse space + . fmap stringPlane + $ ["Tool", "Version", "Tags", "Notes"] renderItems = drawListElements renderItem True appState - renderItem _ b ListResult{..} = + renderItem _ b listResult@ListResult{..} = let marks = if - | lSet -> (stringPlane "✔✔") - | lInstalled -> (stringPlane "✓ ") - | otherwise -> (stringPlane "✗ ") + | lSet -> color Green Vivid (stringPlane "✔✔") + | lInstalled -> color Green Dull (stringPlane "✓ ") + | otherwise -> color Red Vivid (stringPlane "✗ ") ver = case lCross of Nothing -> stringPlane . Tx.unpack . prettyVer $ lVer Just c -> stringPlane . Tx.unpack $ (c <> "-" <> prettyVer lVer) tool = printTool lTool - in marks ||| space ||| space ||| tool ||| space ||| ver + 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 hcat [marks, space, space, tool, space, ver, space, tag, space, 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" @@ -143,6 +198,12 @@ drawFun (BrickState {..}) GEnv{..} = 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. @@ -183,7 +244,7 @@ drawFun (BrickState {..}) GEnv{..} = pure $ V.fromList [markSelected elemWidget] i <- readSTRef ref pure (arr, i) - in vcat $ V.toList (makeVisible drawnElements (mh - 2) selIx) + in vcat $ V.toList (makeVisible drawnElements (mh - 5) selIx) where makeVisible :: V.Vector Plane -> Height -> Maybe Int -> V.Vector Plane makeVisible listElements drawableHeight (Just ix) = @@ -202,17 +263,55 @@ drawFun (BrickState {..}) GEnv{..} = hBorder = box (mw - 2) 1 '─' -logicFun :: GEnv -> BrickState -> Event -> BrickState -logicFun _ gs (KeyPress 'q') = gs { appQuit = True } -logicFun _ gs Tick = gs -logicFun _ gs@BrickState{appMoreInput = Nothing} (KeyPress '\ESC') = gs { appMoreInput = Just "\ESC" } -logicFun _ gs@BrickState{appMoreInput = Just "\ESC"} (KeyPress '[') = gs { appMoreInput = Just "\ESC[" } +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') - = gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up } + = pure gs { appMoreInput = Nothing, appState = moveCursor 1 s' Up } logicFun _ gs@BrickState{appMoreInput = Just "\ESC[", appState = s'} (KeyPress 'B') - = gs { appMoreInput = Nothing, appState = moveCursor 1 s' Down } -logicFun _ gs@BrickState{appMoreInput = Just _} _ = gs { appMoreInput = Nothing } -logicFun _ gs (KeyPress c) = gs + = 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 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 = @@ -225,6 +324,20 @@ 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 @@ -282,6 +395,172 @@ 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' #-}