Get rid of concurrent-output

Also improve some NO_COLOR foo.
2021-09-24 23:11:51 +02:00 · 2021-09-24 23:11:51 +02:00 · 15dd810d67
parent b5ca01dc4f
commit 15dd810d67
10 changed files with 196 additions and 82 deletions
--- 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
--- 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)
--- 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'
@ -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
--- 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
--- 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
--- 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)

--- 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
--- a/lib/System/Console/Terminal/Common.hs
+++ 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
+    )
--- a/lib/System/Console/Terminal/Posix.hsc
+++ 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 <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)
--- 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