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

Get rid of concurrent-output

Browse Source 
Also improve some NO_COLOR foo.
This commit is contained in:
Julian Ospald 2021-09-24 23:11:51 +02:00
parent b5ca01dc4f
commit 15dd810d67
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
10 changed files with 196 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/ghcup-gen/Main.hs
View File

@ -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

6
app/ghcup/BrickMain.hs
View File

@ -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)

15
app/ghcup/Main.hs
View File

@ -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'
@ -1529,6 +1529,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
@ -1536,10 +1537,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
@ -1585,7 +1586,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 =
@ -1610,7 +1611,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

5
cabal.project
View File

@ -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

23
ghcup.cabal
View File

@ -16,18 +16,18 @@ description:
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

1
lib/GHCup/Types.hs
View File

@ -417,6 +417,7 @@ data Settings = Settings
, urlSource :: URLSource
, noNetwork :: Bool
, gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig
}
deriving (Show, GHC.Generic)

73
lib/GHCup/Utils/File/Posix.hs
View File

@ -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,44 +138,55 @@ 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
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 (forM_ rs (liftIO . closeConsoleRegion))
when ps (liftIO $ BS.putStr (pos1 <> moveLineUp size <> clearScreen))
throw ex
)
$ readTilEOF (lineAction rs) fdIn
) $ 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')
liftIO TP.size >>= \case
Nothing -> pure ()
Just (Window _ w) -> do
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
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

43
lib/System/Console/Terminal/Common.hs Normal file
View File

@ -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
)

65
lib/System/Console/Terminal/Posix.hsc Normal file
View File

@ -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 <sys/ioctl.h>
#include <unistd.h>
#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)

3
stack.yaml
View File

@ -4,9 +4,6 @@ packages:
- .
extra-deps:
- git: https://github.com/bgamari/terminal-size
commit: 34ea816bd63f75f800eedac12c6908c6f3736036
- git: https://github.com/hasufell/libarchive
commit: 8587aab78dd515928024ecd82c8f215e06db85cd