hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

lala

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
app/ghcup/AnsiMain.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -10,28 +9,33 @@ module AnsiMain where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors 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.File
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Types.Optics ( getDirs )
import GHCup.Utils
import Control.Monad.IO.Class 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
import System.Console.ANSI.Codes import System.Console.ANSI.Codes
import System.Console.ANSI.Types 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.Tuple as T
import qualified Data.Vector as V 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 data BrickData = BrickData
@ -56,6 +60,7 @@ data BrickState = BrickState
, appSettings :: BrickSettings , appSettings :: BrickSettings
, appState :: BrickInternalState , appState :: BrickInternalState
, appKeys :: KeyBindings , appKeys :: KeyBindings
, appQuit :: Bool
} }
deriving Show deriving Show
@ -70,67 +75,86 @@ ansiMain s = do
defaultAppSettings defaultAppSettings
(constructList ad defaultAppSettings Nothing) (constructList ad defaultAppSettings Nothing)
(keyBindings (s :: AppState)) (keyBindings (s :: AppState))
False
sizeCheck sizeCheck
errorPress $ playGame (ghcupGame g) errorPress $ playGame (ghcupGame g)
Left e -> do 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 exitWith $ ExitFailure 2
where where
sizeCheck :: IO () sizeCheck :: IO ()
sizeCheck = let (w, h) = T.swap . snd $ boundaries sizeCheck = let (w, h) = T.swap . snd $ boundaries in assertTermDims w h
in assertTermDims w h
ghcupGame :: BrickState -> Game BrickState ghcupGame :: BrickState -> Game BrickState
ghcupGame s = Game 13 BrickState -- ticks per second ghcupGame bs = Game 13
bs -- ticks per second
(\_ s e -> logicFun s e) -- logic function (\_ s e -> logicFun s e) -- logic function
(\r s -> centerFull r $ (\r s -> centerFull r $ drawFun s r) -- draw function
drawFun s) -- draw function appQuit -- quit function
undefined -- quit function
drawFun :: BrickState -> Plane drawFun :: BrickState -> GEnv -> Plane
drawFun (BrickState {..}) = drawFun (BrickState {..}) GEnv{..} =
blankPlane mw mh & blankPlane mw mh
(1, 1) % box mw mh '.' & & (1, 1) % box mw mh '.'
(2, 2) % box (mw-2) (mh-2) ' ' & & (2, 2) % box (mw-2) (mh-2) ' '
(15, 20) % textBox 10 4 & (2, 2) % renderItems (renderItem <$> lr appData)
"Tap WASD to move, tap again to stop." &
(20, 60) % textBox 8 10
"Press Q to quit." # color Blue Vivid
where where
mh :: Height mh :: Height
mw :: Width mw :: Width
(mh, mw) = snd boundaries (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 :: BrickState -> Event -> BrickState
logicFun gs (KeyPress 'q') = gs logicFun gs (KeyPress 'q') = gs { appQuit = True }
logicFun gs Tick = gs logicFun gs Tick = gs
logicFun gs (KeyPress c) = gs logicFun gs (KeyPress c) = gs
defaultAppSettings :: BrickSettings defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False } defaultAppSettings =
BrickSettings { showAllVersions = False, showAllTools = False }
constructList :: BrickData constructList
:: BrickData
-> BrickSettings -> BrickSettings
-> Maybe BrickInternalState -> Maybe BrickInternalState
-> BrickInternalState -> BrickInternalState
constructList appD appSettings = constructList appD appSettings = replaceLR
replaceLR (filterVisible (showAllVersions appSettings) (filterVisible (showAllVersions appSettings) (showAllTools appSettings))
(showAllTools appSettings))
(lr appD) (lr appD)
-- | Replace the @appState@ or construct it based on a filter function -- | Replace the @appState@ or construct it based on a filter function
-- and a new @[ListResult]@ evidence. -- and a new @[ListResult]@ evidence.
-- When passed an existing @appState@, tries to keep the selected element. -- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool) replaceLR
:: (ListResult -> Bool)
-> [ListResult] -> [ListResult]
-> Maybe BrickInternalState -> Maybe BrickInternalState
-> BrickInternalState -> BrickInternalState
@ -148,17 +172,12 @@ replaceLR filterF lr s =
filterVisible :: Bool -> Bool -> ListResult -> Bool filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True filterVisible v t e
| v | lInstalled e = True
, not t | v, not t, lTool e `notElem` hiddenTools = True
, lTool e `notElem` hiddenTools = True | not v, t, Old `notElem` lTag e = True
| not v | v, t = True
, t | otherwise = (Old `notElem` lTag e) && (lTool e `notElem` hiddenTools)
, Old `notElem` lTag e = True
| v
, t = True
| otherwise = (Old `notElem` lTag e) &&
(lTool e `notElem` hiddenTools)
hiddenTools :: [Tool] hiddenTools :: [Tool]
@ -166,7 +185,8 @@ hiddenTools = []
selectLatest :: V.Vector ListResult -> Int 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 -> Maybe (Int, ListResult)
@ -194,8 +214,7 @@ settings' = unsafePerformIO $ do
loggerConfig loggerConfig
getAppData :: Maybe GHCupInfo getAppData :: Maybe GHCupInfo -> IO (Either String BrickData)
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do getAppData mgi = runExceptT $ do
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
@ -212,9 +231,17 @@ getGHCupInfo = do
r <- r <-
flip runReaderT settings flip runReaderT settings
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] . runE
@'[ DigestError
, GPGError
, JSONError
, DownloadFailed
, FileDoesNotExistError
]
$ liftE getDownloadsF $ liftE getDownloadsF
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyShow e) VLeft e -> pure $ Left (prettyShow e)

6
ghcup.cabal
View File

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