lala
This commit is contained in:
parent
0f8c3ba9d9
commit
e6ce466700
@ -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)
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user