diff --git a/app/ghcup/AnsiMain.hs b/app/ghcup/AnsiMain.hs index 4c3b9fb..07c73d9 100644 --- a/app/ghcup/AnsiMain.hs +++ b/app/ghcup/AnsiMain.hs @@ -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) + + diff --git a/ghcup.cabal b/ghcup.cabal index d8ea4ad..ff0172c 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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