This commit is contained in:
Julian Ospald 2022-06-18 23:19:16 +02:00
parent 0f8c3ba9d9
commit e6ce466700
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 94 additions and 67 deletions

View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
@ -10,32 +9,37 @@ module AnsiMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics ( getDirs )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Prelude ( decUTF8Safe )
import GHCup.Prelude ( decUTF8Safe )
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Types.Optics ( getDirs )
import GHCup.Utils
import Control.Monad.IO.Class
import Terminal.Game
import Control.Monad.Trans.Except
-- import System.Console.ANSI
import System.Console.ANSI
import System.Console.ANSI.Codes
import System.Console.ANSI.Types
import Terminal.Game
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Control.Monad.Reader ( ReaderT(runReaderT) )
import Data.IORef
import Data.Maybe ( fromMaybe )
import qualified Data.Text as Tx
import qualified Data.Tuple as T
import qualified Data.Vector as V
import qualified Data.Text as Tx
import Data.Maybe (fromMaybe)
import Control.Monad.Reader (ReaderT(runReaderT))
import System.Exit
import Data.IORef
import GHC.IO (unsafePerformIO)
import GHC.IO ( unsafePerformIO )
import Haskus.Utils.Variant.Excepts
import System.Exit
import Data.Versions (prettyVer)
data BrickData = BrickData
{ lr :: [ListResult]
{ lr :: [ListResult]
}
deriving Show
@ -56,6 +60,7 @@ data BrickState = BrickState
, appSettings :: BrickSettings
, appState :: BrickInternalState
, appKeys :: KeyBindings
, appQuit :: Bool
}
deriving Show
@ -67,73 +72,92 @@ ansiMain s = do
case eAppData of
Right ad -> do
let g = BrickState ad
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
(keyBindings (s :: AppState))
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
(keyBindings (s :: AppState))
False
sizeCheck
errorPress $ playGame (ghcupGame g)
Left e -> do
flip runReaderT s $ logError $ "Error building app state: " <> Tx.pack (show e)
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
sizeCheck = let (w, h) = T.swap . snd $ boundaries in assertTermDims w h
ghcupGame :: BrickState -> Game BrickState
ghcupGame s = Game 13 BrickState -- ticks per second
(\_ s e -> logicFun s e) -- logic function
(\r s -> centerFull r $
drawFun s) -- draw function
undefined -- quit function
ghcupGame bs = Game 13
bs -- ticks per second
(\_ s e -> logicFun s e) -- logic function
(\r s -> centerFull r $ drawFun s r) -- draw function
appQuit -- quit function
drawFun :: BrickState -> Plane
drawFun (BrickState {..}) =
blankPlane mw mh &
(1, 1) % box mw mh '.' &
(2, 2) % box (mw-2) (mh-2) ' ' &
(15, 20) % textBox 10 4
"Tap WASD to move, tap again to stop." &
(20, 60) % textBox 8 10
"Press Q to quit." # color Blue Vivid
drawFun :: BrickState -> GEnv -> Plane
drawFun (BrickState {..}) GEnv{..} =
blankPlane mw mh
& (1, 1) % box mw mh '.'
& (2, 2) % box (mw-2) (mh-2) ' '
& (2, 2) % renderItems (renderItem <$> lr appData)
where
mh :: Height
mw :: Width
(mh, mw) = snd boundaries
renderItems = foldr1 (===)
renderItem ListResult{..} =
let marks = if
| lSet -> (stringPlane "✔✔")
| lInstalled -> (stringPlane "")
| otherwise -> (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
printTool Cabal = stringPlane "cabal"
printTool GHC = stringPlane "GHC"
printTool GHCup = stringPlane "GHCup"
printTool HLS = stringPlane "HLS"
printTool Stack = stringPlane "Stack"
space = stringPlane " "
logicFun :: BrickState -> Event -> BrickState
logicFun gs (KeyPress 'q') = gs
logicFun gs (KeyPress 'q') = gs { appQuit = True }
logicFun gs Tick = gs
logicFun gs (KeyPress c) = gs
defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
defaultAppSettings =
BrickSettings { showAllVersions = False, showAllTools = False }
constructList :: BrickData
-> BrickSettings
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings =
replaceLR (filterVisible (showAllVersions appSettings)
(showAllTools appSettings))
(lr appD)
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
:: (ListResult -> Bool)
-> [ListResult]
-> Maybe BrickInternalState
-> BrickInternalState
replaceLR filterF lr s =
let oldElem = s >>= listSelectedElement'
newVec = V.fromList . filter filterF $ lr
@ -148,17 +172,12 @@ replaceLR filterF lr s =
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)
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]
@ -166,11 +185,12 @@ hiddenTools = []
selectLatest :: V.Vector ListResult -> Int
selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
selectLatest = fromMaybe 0
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr V.!? ix
listSelectedElement' BrickInternalState {..} = fmap (ix, ) $ clr V.!? ix
boundaries :: (Coords, Coords)
@ -194,8 +214,7 @@ settings' = unsafePerformIO $ do
loggerConfig
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
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 })
@ -210,11 +229,19 @@ getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
r <-
r <-
flip runReaderT settings
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
. runE
@'[ DigestError
, GPGError
, JSONError
, DownloadFailed
, FileDoesNotExistError
]
$ liftE getDownloadsF
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e)

View File

@ -129,7 +129,7 @@ library
, directory ^>=1.3.6.0
, disk-free-space ^>=0.1.0.1
, exceptions ^>=0.10
, filepath ^>=1.4.2.1
, filepath ==1.4.2.1
, haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0
@ -256,7 +256,7 @@ executable ghcup
, containers ^>=0.6
, deepseq ^>=1.4
, directory ^>=1.3.6.0
, filepath ^>=1.4.2.1
, filepath ==1.4.2.1
, ghcup
, haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1
@ -340,7 +340,7 @@ test-suite ghcup-test
, bytestring >=0.10 && <0.12
, containers ^>=0.6
, directory ^>=1.3.6.0
, filepath ^>=1.4.2.1
, filepath ==1.4.2.1
, generic-arbitrary >=0.1.0 && <0.2.1 || >=0.2.2 && <0.3
, ghcup
, hspec >=2.7.10 && <2.11