diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index f5bae3f..6a9369e 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -123,7 +123,7 @@ main = do , fancyColors = not no_color } dirs <- liftIO getAllDirs - let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings loggerConfig + let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig pfreq <- ( flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest @@ -133,7 +133,7 @@ main = do flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e liftIO $ exitWith (ExitFailure 2) - let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig + let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig _ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) >>= \Options {..} -> case optCommand of diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 0981a10..dd620f0 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -43,7 +43,6 @@ import Data.Vector ( Vector import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile ) -import System.Environment import System.Exit import System.IO.Unsafe import Text.PrettyPrint.HughesPJClass ( prettyShow ) @@ -550,6 +549,7 @@ settings' = unsafePerformIO $ do , urlSource = GHCupURL , noNetwork = False , gpgSetting = GPGNone + , noColor = False , .. }) dirs @@ -565,13 +565,11 @@ brickMain :: AppState brickMain s = do writeIORef settings' s - no_color <- isJust <$> lookupEnv "NO_COLOR" - eAppData <- getAppData (Just $ ghcupInfo s) case eAppData of Right ad -> defaultMain - (app (defaultAttributes no_color) (dimAttributes no_color)) + (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s))) (BrickState ad defaultAppSettings (constructList ad defaultAppSettings Nothing) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 74e4fca..c99ca6f 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1344,7 +1344,7 @@ tagCompleter tool add = listIOCompleter $ do , fancyColors = False } let appState = LeanAppState - (Settings True False Never Curl False GHCupURL True GPGNone) + (Settings True False Never Curl False GHCupURL True GPGNone False) dirs' defaultKeyBindings loggerConfig @@ -1370,7 +1370,7 @@ versionCompleter criteria tool = listIOCompleter $ do , fileOutter = mempty , fancyColors = False } - let settings = Settings True False Never Curl False GHCupURL True GPGNone + let settings = Settings True False Never Curl False GHCupURL True GPGNone False let leanAppState = LeanAppState settings dirs' @@ -1532,6 +1532,7 @@ absolutePathParser f = case isValid f && isAbsolute f of toSettings :: Options -> IO (Settings, KeyBindings) toSettings options = do + noColor <- isJust <$> lookupEnv "NO_COLOR" userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case VRight r -> pure r VLeft (V (JSONDecodeError e)) -> do @@ -1539,10 +1540,10 @@ toSettings options = do pure defaultUserSettings _ -> do die "Unexpected error!" - pure $ mergeConf options userConf + pure $ mergeConf options userConf noColor where - mergeConf :: Options -> UserSettings -> (Settings, KeyBindings) - mergeConf Options{..} UserSettings{..} = + mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) + mergeConf Options{..} UserSettings{..} noColor = let cache = fromMaybe (fromMaybe False uCache) optCache noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify verbose = fromMaybe (fromMaybe False uVerbose) optVerbose @@ -1588,7 +1589,7 @@ updateSettings config settings = do urlSource' = fromMaybe urlSource uUrlSource noNetwork' = fromMaybe noNetwork uNoNetwork gpgSetting' = fromMaybe gpgSetting uGPGSetting - in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' + in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor upgradeOptsP :: Parser UpgradeOpts upgradeOptsP = @@ -1613,7 +1614,7 @@ describe_result = $( LitE . StringL <$> runIO (do CapturedProcess{..} <- do dirs <- liftIO getAllDirs - let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone) + let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False) dirs defaultKeyBindings flip runReaderT settings $ executeOut "git" ["describe"] Nothing diff --git a/cabal.project b/cabal.project index 224e03a..4bdb535 100644 --- a/cabal.project +++ b/cabal.project @@ -8,11 +8,6 @@ package ghcup tests: True flags: +tui -source-repository-package - type: git - location: https://github.com/bgamari/terminal-size - tag: 34ea816bd63f75f800eedac12c6908c6f3736036 - source-repository-package type: git location: https://github.com/hasufell/libarchive diff --git a/ghcup.cabal b/ghcup.cabal index a5a5e01..56a27c4 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,33 +1,33 @@ -cabal-version: 3.0 -name: ghcup -version: 0.1.17 -license: LGPL-3.0-only -license-file: LICENSE -copyright: Julian Ospald 2020 -maintainer: hasufell@posteo.de -author: Julian Ospald -homepage: https://gitlab.haskell.org/haskell/ghcup-hs -bug-reports: https://gitlab.haskell.org/haskell/ghcup-hs/issues -synopsis: ghc toolchain installer +cabal-version: 3.0 +name: ghcup +version: 0.1.17 +license: LGPL-3.0-only +license-file: LICENSE +copyright: Julian Ospald 2020 +maintainer: hasufell@posteo.de +author: Julian Ospald +homepage: https://gitlab.haskell.org/haskell/ghcup-hs +bug-reports: https://gitlab.haskell.org/haskell/ghcup-hs/issues +synopsis: ghc toolchain installer description: A rewrite of the shell script ghcup, for providing a more stable user experience and exposing an API. -category: System -build-type: Simple +category: System +build-type: Simple extra-doc-files: - README.md - docs/CHANGELOG.md - docs/HACKING.md - docs/RELEASING.md data/config.yaml data/metadata/ghcup-0.0.4.yaml data/metadata/ghcup-0.0.5.yaml data/metadata/ghcup-0.0.6.yaml + docs/CHANGELOG.md + docs/HACKING.md + docs/RELEASING.md + README.md extra-source-files: - data/build_mk/default data/build_mk/cross + data/build_mk/default source-repository head type: git @@ -102,7 +102,6 @@ library , Cabal , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 - , concurrent-output ^>=1.10.11 , containers ^>=0.6 , cryptohash-sha256 ^>=0.11.101.0 , deepseq ^>=1.4.4.0 @@ -111,6 +110,7 @@ library , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5 , haskus-utils-variant >=3.0 && <3.2 + , HsYAML-aeson ^>=0.2.0.0 , libarchive ^>=3.0.0.0 , lzma-static ^>=5.2.5.3 , megaparsec >=8.0.0 && <9.1 @@ -136,7 +136,6 @@ library , vector ^>=0.12 , versions >=4.0.1 && <5.1 , word8 ^>=0.1.3 - , HsYAML-aeson ^>=0.2.0.0 , zlib ^>=0.6.2.2 if (flag(internal-downloader) && !os(windows)) @@ -158,7 +157,11 @@ library , Win32 ^>=2.10 else - other-modules: GHCup.Utils.File.Posix + other-modules: + GHCup.Utils.File.Posix + System.Console.Terminal.Common + System.Console.Terminal.Posix + build-depends: , bz2 >=0.5.0.5 && <1.1 , unix ^>=2.7 @@ -198,6 +201,7 @@ executable ghcup , filepath ^>=1.4.2.1 , ghcup , haskus-utils-variant >=3.0 && <3.2 + , HsYAML-aeson ^>=0.2.0.0 , libarchive ^>=3.0.0.0 , megaparsec >=8.0.0 && <9.1 , mtl ^>=2.2 @@ -212,7 +216,6 @@ executable ghcup , uri-bytestring ^>=0.3.2.2 , utf8-string ^>=1.0 , versions >=4.0.1 && <5.1 - , HsYAML-aeson ^>=0.2.0.0 if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER @@ -260,6 +263,7 @@ executable ghcup-gen , filepath ^>=1.4.2.1 , ghcup , haskus-utils-variant >=3.0 && <3.2 + , HsYAML-aeson ^>=0.2.0.0 , libarchive ^>=3.0.0.0 , mtl ^>=2.2 , optics ^>=0.4 @@ -272,7 +276,6 @@ executable ghcup-gen , text ^>=1.2.4.0 , transformers ^>=0.5 , versions >=4.0.1 && <5.1 - , HsYAML-aeson ^>=0.2.0.0 test-suite ghcup-test type: exitcode-stdio-1.0 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index b01b202..e4c3a7c 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -417,6 +417,7 @@ data Settings = Settings , urlSource :: URLSource , noNetwork :: Bool , gpgSetting :: GPGSetting + , noColor :: Bool -- this also exists in LoggerConfig } deriving (Show, GHC.Generic) diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index a30397e..fdd788b 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -35,8 +35,7 @@ import Data.Sequence ( Seq, (|>) ) import Data.List import Data.Word8 import GHC.IO.Exception -import System.Console.Pretty hiding ( Pretty ) -import System.Console.Regions +import System.Console.Terminal.Common import System.IO.Error import System.FilePath import System.Directory @@ -52,6 +51,7 @@ import qualified Data.Sequence as Sq import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified System.Posix.Process as SPP +import qualified System.Console.Terminal.Posix as TP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified "unix-bytestring" System.Posix.IO.ByteString @@ -88,9 +88,9 @@ execLogged exe args chdir lfile env = do let logfile = logsDir lfile <> ".log" liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) closeFd - (action verbose) + (action verbose noColor) where - action verbose fd = do + action verbose no_color fd = do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do -- start the thread that logs to stdout pState <- newEmptyMVar @@ -101,7 +101,7 @@ execLogged exe args chdir lfile env = do $ EX.finally (if verbose then tee fd stdoutRead - else printToRegion fd stdoutRead 6 pState + else printToRegion fd stdoutRead 6 pState no_color ) (putMVar done ()) @@ -138,46 +138,57 @@ execLogged exe args chdir lfile env = do -- Reads fdIn and logs the output in a continous scrolling area -- of 'size' terminal lines. Also writes to a log file. - printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO () - printToRegion fileFd fdIn size pState = do - void $ displayConsoleRegions $ do - rs <- - liftIO - . fmap Sq.fromList - . sequence - . replicate size - . openConsoleRegion - $ Linear - flip runStateT mempty - $ handle - (\(ex :: SomeException) -> do - ps <- liftIO $ takeMVar pState - when ps (forM_ rs (liftIO . closeConsoleRegion)) - throw ex - ) - $ readTilEOF (lineAction rs) fdIn + printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO () + printToRegion fileFd fdIn size pState no_color = do + -- init region + forM_ [1..size] $ \_ -> BS.putStr "\n" + + void $ flip runStateT mempty + $ do + handle + (\(ex :: SomeException) -> do + ps <- liftIO $ takeMVar pState + when ps (liftIO $ BS.putStr (pos1 <> moveLineUp size <> clearScreen)) + throw ex + ) $ readTilEOF lineAction fdIn where + clearScreen :: ByteString + clearScreen = "\x1b[0J" + clearLine :: ByteString + clearLine = "\x1b[2K" + moveLineUp :: Int -> ByteString + moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A" + moveLineDown :: Int -> ByteString + moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B" + pos1 :: ByteString + pos1 = "\r" + overwriteNthLine :: Int -> ByteString -> ByteString + overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1 + + blue :: ByteString -> ByteString + blue bs + | no_color = bs + | otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m" + -- action to perform line by line - -- TODO: do this with vty for efficiency lineAction :: (MonadMask m, MonadIO m) - => Seq ConsoleRegion - -> ByteString + => ByteString -> StateT (Seq ByteString) m () - lineAction rs = \bs' -> do + lineAction = \bs' -> do void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n") modify (swapRegs bs') - regs <- get - liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do - w <- consoleWidth - return - . T.pack - . color Blue - . T.unpack - . decUTF8Safe - . trim w - . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b) - $ bs + liftIO TP.size >>= \case + Nothing -> pure () + Just (Window _ w) -> do + regs <- get + liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do + BS.putStr + . overwriteNthLine (size - i) + . trim w + . blue + . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b) + $ bs swapRegs :: a -> Seq a -> Seq a swapRegs bs = \regs -> if diff --git a/lib/System/Console/Terminal/Common.hs b/lib/System/Console/Terminal/Common.hs new file mode 100644 index 0000000..768e0e0 --- /dev/null +++ b/lib/System/Console/Terminal/Common.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} + +#if __GLASGOW_HASKELL__ >= 702 +#define LANGUAGE_DeriveGeneric +{-# LANGUAGE DeriveGeneric #-} +#endif + +module System.Console.Terminal.Common + ( Window(..) + ) where + +import Data.Data (Typeable, Data) + +#if __GLASGOW_HASKELL__ < 710 +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +#endif + +#ifdef LANGUAGE_DeriveGeneric +import GHC.Generics + ( Generic +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) +#endif + +-- | Terminal window width and height +data Window a = Window + { height :: !a + , width :: !a + } deriving + ( Show, Eq, Read, Data, Typeable + , Foldable, Functor, Traversable +#ifdef LANGUAGE_DeriveGeneric + , Generic +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif +#endif + ) diff --git a/lib/System/Console/Terminal/Posix.hsc b/lib/System/Console/Terminal/Posix.hsc new file mode 100644 index 0000000..9b2df59 --- /dev/null +++ b/lib/System/Console/Terminal/Posix.hsc @@ -0,0 +1,65 @@ +{-# LANGUAGE CApiFFI #-} + +module System.Console.Terminal.Posix + ( size, fdSize, hSize + ) where + +import System.Console.Terminal.Common +import Control.Exception (catch) +import Data.Typeable (cast) +import Foreign +import Foreign.C.Error +import Foreign.C.Types +import GHC.IO.FD (FD(FD, fdFD)) +import GHC.IO.Handle.Internals (withHandle_) +import GHC.IO.Handle.Types (Handle, Handle__(Handle__, haDevice)) +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706) +import Prelude hiding (catch) +#endif +import System.Posix.Types (Fd(Fd)) + +#include +#include + + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + + +-- Interesting part of @struct winsize@ +data CWin = CWin CUShort CUShort + +instance Storable CWin where + sizeOf _ = (#size struct winsize) + alignment _ = (#alignment struct winsize) + peek ptr = do + row <- (#peek struct winsize, ws_row) ptr + col <- (#peek struct winsize, ws_col) ptr + return $ CWin row col + poke ptr (CWin row col) = do + (#poke struct winsize, ws_row) ptr row + (#poke struct winsize, ws_col) ptr col + + +fdSize :: Integral n => Fd -> IO (Maybe (Window n)) +fdSize (Fd fd) = with (CWin 0 0) $ \ws -> do + _ <- throwErrnoIfMinus1 "ioctl" $ + ioctl fd (#const TIOCGWINSZ) ws + CWin row col <- peek ws + return . Just $ Window (fromIntegral row) (fromIntegral col) + `catch` + handler + where + handler :: IOError -> IO (Maybe (Window h)) + handler _ = return Nothing + +foreign import capi "sys/ioctl.h ioctl" + ioctl :: CInt -> CULong -> Ptr CWin -> IO CInt + +size :: Integral n => IO (Maybe (Window n)) +size = fdSize (Fd (#const STDOUT_FILENO)) + +hSize :: Integral n => Handle -> IO (Maybe (Window n)) +hSize h = withHandle_ "hSize" h $ \Handle__ { haDevice = dev } -> + case cast dev of + Nothing -> return Nothing + Just FD { fdFD = fd } -> fdSize (Fd fd) diff --git a/stack.yaml b/stack.yaml index 2316a4a..c313627 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,9 +4,6 @@ packages: - . extra-deps: - - git: https://github.com/bgamari/terminal-size - commit: 34ea816bd63f75f800eedac12c6908c6f3736036 - - git: https://github.com/hasufell/libarchive commit: 8587aab78dd515928024ecd82c8f215e06db85cd