Implement proper build log scrolling

2020-03-24 16:49:18 +01:00 · 2020-03-24 16:49:18 +01:00 · 31a8316bfa
parent 3ff6be5435
commit 31a8316bfa
5 changed files with 482 additions and 242 deletions
--- a/app/ghcup-gen/GHCupDownloads.hs
+++ b/app/ghcup-gen/GHCupDownloads.hs
@ -1680,7 +1680,7 @@ ghcupDownloads = M.fromList
    )
  , ( GHCup
    , M.fromList
-      [ ( [vver|0.1.0|]
+      [ ( [vver|0.0.0|]
        , VersionInfo [Recommended, Latest] Nothing $ M.fromList
          [ ( A_64
            , M.fromList
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -1,236 +1,371 @@
-cabal-version:       2.2
+cabal-version:      3.0
+name:               ghcup
+version:            0.1.0.0
+synopsis:           ghc toolchain installer as an exe/library
+description:
+  A rewrite of the shell script ghcup, for providing
+  a more stable user experience and exposing an API.

-name:                ghcup
-version:             0.1.0.0
-synopsis:            ghc toolchain installer as an exe/library
-description:         A rewrite of the shell script ghcup, for providing
-                     a more stable user experience and exposing an API.
-homepage:            https://github.com/hasufell/ghcup-hs
-bug-reports:         https://github.com/hasufell/ghcup-hs/issues
-license:             LGPL-3.0-only
-license-file:        LICENSE
-author:              Julian Ospald
-maintainer:          hasufell@posteo.de
-copyright:           Julian Ospald 2020
-category:            System
-build-type:          Simple
-extra-source-files:  CHANGELOG.md
+homepage:           https://github.com/hasufell/ghcup-hs
+bug-reports:        https://github.com/hasufell/ghcup-hs/issues
+license:            LGPL-3.0-only
+license-file:       LICENSE
+author:             Julian Ospald
+maintainer:         hasufell@posteo.de
+copyright:          Julian Ospald 2020
+category:           System
+build-type:         Simple
+extra-source-files: CHANGELOG.md

 source-repository head
-  type: git
+  type:     git
  location: https://github.com/hasufell/ghcup-hs

-common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
-common aeson { build-depends: aeson >= 1.4 }
-common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
-common ascii-string { build-depends: ascii-string >= 1.0 }
-common async { build-depends: async >= 0.8 }
-common attoparsec { build-depends: attoparsec >= 0.13 }
-common base { build-depends: base >= 4.12 && < 5 }
-common binary { build-depends: binary >= 0.8.6.0 }
-common bytestring { build-depends: bytestring >= 0.10 }
-common bzlib { build-depends: bzlib >= 0.5.0.5 }
-common case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
-common containers { build-depends: containers >= 0.6 }
-common generics-sop { build-depends: generics-sop >= 0.5 }
-common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
-common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
-common hopenssl { build-depends: hopenssl >= 2.2.4 }
-common hpath { build-depends: hpath >= 0.11 }
-common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
-common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
-common hpath-io { build-depends: hpath-io >= 0.13.1 }
-common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
-common http-io-streams { build-depends: http-io-streams >= 0.1.2.0 }
-common io-streams { build-depends: io-streams >= 1.5 }
-common language-bash { build-depends: language-bash >= 0.9 }
-common lzma { build-depends: lzma >= 0.0.0.3 }
-common megaparsec { build-depends: megaparsec >= 3.5.3 }
-common monad-logger { build-depends: monad-logger >= 0.3.31 }
-common mtl { build-depends: mtl >= 2.2 }
-common optics { build-depends: optics >= 0.2 }
-common optics-vl { build-depends: optics-vl >= 0.2 }
-common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
-common parsec { build-depends: parsec >= 3.1 }
-common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
-common regex-posix { build-depends: regex-posix >= 0.96 }
-common resourcet { build-depends: resourcet >= 1.2.2 }
-common safe { build-depends: safe >= 0.3.18 }
-common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
-common streamly { build-depends: streamly >= 0.7.1 }
-common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
-common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
-common strict-base { build-depends: strict-base >= 0.4 }
-common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
-common table-layout { build-depends: table-layout >= 0.8 }
-common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.1 }
-common template-haskell { build-depends: template-haskell >= 2.7 }
-common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
-common text { build-depends: text >= 1.2 }
-common time { build-depends: time >= 1.9.3 }
-common transformers { build-depends: transformers >= 0.5 }
-common unix { build-depends: unix >= 2.7 }
-common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
-common uri-bytestring { build-depends: uri-bytestring >= 0.3.2.2 }
-common utf8-string { build-depends: utf8-string >= 1.0 }
-common vector { build-depends: vector >= 0.12 }
-common versions { build-depends: versions >= 3.5 }
-common waargonaut { build-depends: waargonaut >= 0.8 }
-common word8 { build-depends: word8 >= 0.1.3 }
-common zlib { build-depends: zlib >= 0.6.2.1 }
+common HsOpenSSL
+  build-depends: HsOpenSSL >=0.11

+common aeson
+  build-depends: aeson >=1.4
+
+common aeson-pretty
+  build-depends: aeson-pretty >=0.8.8
+
+common ascii-string
+  build-depends: ascii-string >=1.0
+
+common async
+  build-depends: async >=0.8
+
+common attoparsec
+  build-depends: attoparsec >=0.13
+
+common base
+  build-depends: base >=4.12 && <5
+
+common binary
+  build-depends: binary >=0.8.6.0
+
+common bytestring
+  build-depends: bytestring >=0.10
+
+common bzlib
+  build-depends: bzlib >=0.5.0.5
+
+common case-insensitive
+  build-depends: case-insensitive >=1.2.1.0
+
+common concurrent-output
+  build-depends: concurrent-output >=1.10.11
+
+common containers
+  build-depends: containers >=0.6
+
+common generics-sop
+  build-depends: generics-sop >=0.5
+
+common haskus-utils-types
+  build-depends: haskus-utils-types >=1.5
+
+common haskus-utils-variant
+  build-depends: haskus-utils-variant >=3.0
+
+common hopenssl
+  build-depends: hopenssl >=2.2.4
+
+common hpath
+  build-depends: hpath >=0.11
+
+common hpath-directory
+  build-depends: hpath-directory >=0.13.2
+
+common hpath-filepath
+  build-depends: hpath-filepath >=0.10.3
+
+common hpath-io
+  build-depends: hpath-io >=0.13.1
+
+common hpath-posix
+  build-depends: hpath-posix >=0.11.1
+
+common http-io-streams
+  build-depends: http-io-streams >=0.1.2.0
+
+common io-streams
+  build-depends: io-streams >=1.5
+
+common language-bash
+  build-depends: language-bash >=0.9
+
+common lzma
+  build-depends: lzma >=0.0.0.3
+
+common megaparsec
+  build-depends: megaparsec >=8.0.0
+
+common monad-logger
+  build-depends: monad-logger >=0.3.31
+
+common mtl
+  build-depends: mtl >=2.2
+
+common optics
+  build-depends: optics >=0.2
+
+common optics-vl
+  build-depends: optics-vl >=0.2
+
+common optparse-applicative
+  build-depends: optparse-applicative >=0.15.1.0
+
+common parsec
+  build-depends: parsec >=3.1
+
+common pretty-terminal
+  build-depends: pretty-terminal >=0.1.0.0
+
+common regex-posix
+  build-depends: regex-posix >=0.96
+
+common resourcet
+  build-depends: resourcet >=1.2.2
+
+common safe
+  build-depends: safe >=0.3.18
+
+common safe-exceptions
+  build-depends: safe-exceptions >=0.1
+
+common streamly
+  build-depends: streamly >=0.7.1
+
+common streamly-posix
+  build-depends: streamly-posix >=0.1.0.0
+
+common streamly-bytestring
+  build-depends: streamly-bytestring >=0.1.2
+
+common strict-base
+  build-depends: strict-base >=0.4
+
+common string-interpolate
+  build-depends: string-interpolate >=0.2.0.0
+
+common table-layout
+  build-depends: table-layout >=0.8
+
+common tar-bytestring
+  build-depends: tar-bytestring >=0.6.3.1
+
+common template-haskell
+  build-depends: template-haskell >=2.7
+
+common terminal-progress-bar
+  build-depends: terminal-progress-bar >=0.4.1
+
+common text
+  build-depends: text >=1.2
+
+common time
+  build-depends: time >=1.9.3
+
+common transformers
+  build-depends: transformers >=0.5
+
+common unix
+  build-depends: unix >=2.7
+
+common unix-bytestring
+  build-depends: unix-bytestring >=0.3
+
+common uri-bytestring
+  build-depends: uri-bytestring >=0.3.2.2
+
+common utf8-string
+  build-depends: utf8-string >=1.0
+
+common vector
+  build-depends: vector >=0.12
+
+common versions
+  build-depends: versions >=3.5
+
+common waargonaut
+  build-depends: waargonaut >=0.8
+
+common word8
+  build-depends: word8 >=0.1.3
+
+common zlib
+  build-depends: zlib >=0.6.2.1

 common config
-  default-language:     Haskell2010
-  ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded
-  default-extensions:     LambdaCase
-                        , MultiWayIf
-                        , PackageImports
-                        , RecordWildCards
-                        , ScopedTypeVariables
-                        , StrictData
-                        , Strict
-                        , TupleSections
+  default-language:   Haskell2010
+  ghc-options:
+    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
+    -fwarn-incomplete-record-updates -threaded
+
+  default-extensions:
+    LambdaCase
+    MultiWayIf
+    PackageImports
+    RecordWildCards
+    ScopedTypeVariables
+    Strict
+    StrictData
+    TupleSections

 library
-  import:              config
-                     , base
-                       -- deps
-                     , HsOpenSSL
-                     , aeson
-                     , ascii-string
-                     , async
-                     , attoparsec
-                     , binary
-                     , bytestring
-                     , bzlib
-                     , case-insensitive
-                     , containers
-                     , generics-sop
-                     , haskus-utils-types
-                     , haskus-utils-variant
-                     , hopenssl
-                     , hpath
-                     , hpath-directory
-                     , hpath-filepath
-                     , hpath-io
-                     , hpath-posix
-                     , http-io-streams
-                     , io-streams
-                     , language-bash
-                     , lzma
-                     , monad-logger
-                     , mtl
-                     , optics
-                     , optics-vl
-                     , parsec
-                     , pretty-terminal
-                     , regex-posix
-                     , resourcet
-                     , safe
-                     , safe-exceptions
-                     , streamly
-                     , streamly-posix
-                     , streamly-bytestring
-                     , strict-base
-                     , string-interpolate
-                     , tar-bytestring
-                     , template-haskell
-                     , terminal-progress-bar
-                     , text
-                     , time
-                     , transformers
-                     , unix
-                     , unix-bytestring
-                     , uri-bytestring
-                     , utf8-string
-                     , vector
-                     , versions
-                     , word8
-                     , zlib
-  exposed-modules:     GHCup
-                       GHCup.Download
-                       GHCup.Errors
-                       GHCup.Platform
-                       GHCup.Types
-                       GHCup.Types.JSON
-                       GHCup.Types.Optics
-                       GHCup.Utils
-                       GHCup.Utils.Bash
-                       GHCup.Utils.Dirs
-                       GHCup.Utils.File
-                       GHCup.Utils.Logger
-                       GHCup.Utils.Prelude
-                       GHCup.Utils.String.QQ
-                       GHCup.Utils.Version.QQ
-                       GHCup.Version
+  import:
+    config
+    , base
+    , HsOpenSSL
+    , aeson
+    , ascii-string
+    , async
+    , attoparsec
+    , binary
+    , bytestring
+    , bzlib
+    , case-insensitive
+    , concurrent-output
+    , containers
+    , generics-sop
+    , haskus-utils-types
+    , haskus-utils-variant
+    , hopenssl
+    , hpath
+    , hpath-directory
+    , hpath-filepath
+    , hpath-io
+    , hpath-posix
+    , http-io-streams
+    , io-streams
+    , language-bash
+    , lzma
+    , monad-logger
+    , mtl
+    , optics
+    , optics-vl
+    , parsec
+    , pretty-terminal
+    , regex-posix
+    , resourcet
+    , safe
+    , safe-exceptions
+    , streamly
+    , streamly-posix
+    , streamly-bytestring
+    , strict-base
+    , string-interpolate
+    , tar-bytestring
+    , template-haskell
+    , terminal-progress-bar
+    , text
+    , time
+    , transformers
+    , unix
+    , unix-bytestring
+    , uri-bytestring
+    , utf8-string
+    , vector
+    , versions
+    , word8
+    , zlib
+
+  -- deps
+  -- cabal-fmt: expand lib
+  exposed-modules:
+    GHCup
+    GHCup.Download
+    GHCup.Errors
+    GHCup.Platform
+    GHCup.Types
+    GHCup.Types.JSON
+    GHCup.Types.Optics
+    GHCup.Utils
+    GHCup.Utils.Bash
+    GHCup.Utils.Dirs
+    GHCup.Utils.File
+    GHCup.Utils.Logger
+    GHCup.Utils.Prelude
+    GHCup.Utils.String.QQ
+    GHCup.Utils.Version.QQ
+    GHCup.Version
+
  -- other-modules:
  -- other-extensions:
-  hs-source-dirs:      lib
+  hs-source-dirs:  lib

 executable ghcup
-  import:                config
-                       , base
-                       --
-                       , bytestring
-                       , containers
-                       , haskus-utils-variant
-                       , monad-logger
-                       , megaparsec
-                       , mtl
-                       , optparse-applicative
-                       , text
-                       , versions
-                       , hpath
-                       , hpath-io
-                       , pretty-terminal
-                       , resourcet
-                       , string-interpolate
-                       , table-layout
-                       , uri-bytestring
-                       , utf8-string
-  main-is:             Main.hs
+  import:
+    config
+    , base
+    , bytestring
+    , containers
+    , haskus-utils-variant
+    , monad-logger
+    , megaparsec
+    , mtl
+    , optparse-applicative
+    , text
+    , versions
+    , hpath
+    , hpath-io
+    , pretty-terminal
+    , resourcet
+    , string-interpolate
+    , table-layout
+    , uri-bytestring
+    , utf8-string
+
+  --
+  main-is:          Main.hs
+
  -- other-modules:
  -- other-extensions:
-  build-depends:       ghcup
-  hs-source-dirs:      app/ghcup
-  default-language:    Haskell2010
+  build-depends:    ghcup
+  hs-source-dirs:   app/ghcup
+  default-language: Haskell2010

 executable ghcup-gen
-  import:                config
-                       , base
-                       --
-                       , aeson
-                       , aeson-pretty
-                       , bytestring
-                       , containers
-                       , safe-exceptions
-                       , haskus-utils-variant
-                       , monad-logger
-                       , mtl
-                       , optics
-                       , optparse-applicative
-                       , text
-                       , versions
-                       , hpath
-                       , pretty-terminal
-                       , resourcet
-                       , string-interpolate
-                       , table-layout
-                       , transformers
-                       , uri-bytestring
-                       , utf8-string
-  main-is:             Main.hs
-  other-modules:       GHCupDownloads
-                       Validate
+  import:
+    config
+    , base
+    , aeson
+    , aeson-pretty
+    , bytestring
+    , containers
+    , safe-exceptions
+    , haskus-utils-variant
+    , monad-logger
+    , mtl
+    , optics
+    , optparse-applicative
+    , text
+    , versions
+    , hpath
+    , pretty-terminal
+    , resourcet
+    , string-interpolate
+    , table-layout
+    , transformers
+    , uri-bytestring
+    , utf8-string
+
+  --
+  main-is:          Main.hs
+  other-modules:
+    GHCupDownloads
+    Validate
+
  -- other-extensions:
-  build-depends:       ghcup
-  hs-source-dirs:      app/ghcup-gen
-  default-language:    Haskell2010
+  build-depends:    ghcup
+  hs-source-dirs:   app/ghcup-gen
+  default-language: Haskell2010

 test-suite ghcup-test
-  default-language:    Haskell2010
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      test
-  main-is:             MyLibTest.hs
-  build-depends:       base ^>=4.12.0.0
+  default-language: Haskell2010
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          MyLibTest.hs
+  build-depends:    base >=4.12.0.0
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -138,7 +138,7 @@ installGHCBin bDls ver mpfReq = do
    lEM $ liftIO $ execLogged "./configure"
                              False
                              ["--prefix=" <> toFilePath inst]
-                              [rel|ghc-configure.log|]
+                              [rel|ghc-configure|]
                              (Just path)
                              Nothing
    lEM $ liftIO $ make ["install"] (Just path)
@ -516,7 +516,7 @@ GhcWithLlvmCodeGen = YES|]
          "./configure"
          False
          ["--prefix=" <> toFilePath ghcdir]
-          [rel|ghc-configure.log|]
+          [rel|ghc-conf|]
          (Just workdir)
          (Just (("GHC", toFilePath bghcPath) : newEnv))
      | otherwise -> do
@ -524,7 +524,7 @@ GhcWithLlvmCodeGen = YES|]
          "./configure"
          False
          ["--prefix=" <> toFilePath ghcdir, "--with-ghc=" <> toFilePath bghc]
-          [rel|ghc-configure.log|]
+          [rel|ghc-conf|]
          (Just workdir)
          (Just newEnv)

@ -612,7 +612,7 @@ compileCabal dls tver bver jobs = do
    lEM $ liftIO $ execLogged "./bootstrap.sh"
                              False
                              (maybe [] (\j -> ["-j", fS (show j)]) jobs)
-                              [rel|cabal-bootstrap.log|]
+                              [rel|cabal-bootstrap|]
                              (Just workdir)
                              (Just newEnv)

--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -335,4 +335,4 @@ make args workdir = do
  spaths    <- catMaybes . fmap parseAbs <$> getSearchPath
  has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
  let mymake = if has_gmake then "gmake" else "make"
-  execLogged mymake True args [rel|ghc-make.log|] workdir Nothing
+  execLogged mymake True args [rel|ghc-make|] workdir Nothing
--- a/lib/GHCup/Utils/File.hs
+++ b/lib/GHCup/Utils/File.hs
@ -1,18 +1,21 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}

 module GHCup.Utils.File where

 import           GHCup.Utils.Dirs
 import           GHCup.Utils.Prelude

+import           Control.Concurrent
 import           Control.Exception.Safe
 import           Control.Monad
-import           Data.ByteString
+import           Data.ByteString                ( ByteString )
 import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
 import           Data.Char
 import           Data.Foldable
 import           Data.Functor
+import           Data.IORef
 import           Data.Maybe
 import           GHC.Foreign                    ( peekCStringLen )
 import           GHC.IO.Encoding                ( getLocaleEncoding )
@ -23,7 +26,10 @@ import           Optics
 import           Streamly
 import           Streamly.External.ByteString
 import           Streamly.External.ByteString.Lazy
+import           System.Console.Pretty
+import           System.Console.Regions
 import           System.IO
+import           System.IO.Error
 import           System.Posix.Directory.ByteString
 import           System.Posix.FD               as FD
 import           System.Posix.FilePath   hiding ( (</>) )
@ -34,6 +40,9 @@ import           System.Posix.Process           ( ProcessStatus(..) )
 import           System.Posix.Types


+import qualified Control.Exception             as EX
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
 import qualified System.Posix.Process.ByteString
                                               as SPPB
 import           Streamly.External.Posix.DirStream
@ -42,7 +51,16 @@ import qualified Streamly.Internal.Memory.ArrayStream
 import qualified Streamly.FileSystem.Handle    as FH
 import qualified Streamly.Internal.Data.Unfold as SU
 import qualified Streamly.Prelude              as S
+import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as L
+import qualified "unix-bytestring" System.Posix.IO.ByteString
+                                               as SPIB
+
+
+data StopThread = StopThread Bool
+  deriving Show
+
+instance Exception StopThread


 data ProcessError = NonZeroExit Int ByteString [ByteString]
@ -99,7 +117,7 @@ findExecutable ex = do

 -- | Execute the given command and collect the stdout, stderr and the exit code.
 -- The command is run in a subprocess.
-executeOut :: Path b          -- ^ command as filename, e.g. 'ls'
+executeOut :: Path b            -- ^ command as filename, e.g. 'ls'
           -> [ByteString]      -- ^ arguments to the command
           -> Maybe (Path Abs)  -- ^ chdir to this path
           -> IO CapturedProcess
@ -116,26 +134,110 @@ execLogged :: ByteString       -- ^ thing to execute
           -> Maybe [(ByteString, ByteString)] -- ^ optional environment
           -> IO (Either ProcessError ())
 execLogged exe spath args lfile chdir env = do
-  ldir <- ghcupLogsDir
-  let logfile = ldir </> lfile
+  ldir    <- ghcupLogsDir
+  logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
  bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
 where
  action fd = do
-    pid <- SPPB.forkProcess $ do
-      -- dup stdout
-      void $ dupTo fd stdOutput
+    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
+      -- start the thread that logs to stdout in a region
+      done <- newEmptyMVar
+      tid  <-
+        forkIO
+        $ EX.handle (\(_ :: StopThread) -> pure ())
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ flip finally (putMVar done ())
+        $ printToRegion fd stdoutRead 6

-      -- dup stderr
-      void $ dupTo fd stdError
+      -- fork our subprocess
+      pid <- SPPB.forkProcess $ do
+        void $ dupTo stdoutWrite stdOutput
+        void $ dupTo stdoutWrite stdError
+        closeFd stdoutWrite
+        closeFd stdoutRead

-      -- execute the action
-      maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-      SPPB.executeFile exe spath args env
+        -- execute the action
+        maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+        SPPB.executeFile exe spath args env
+
+      closeFd stdoutWrite
+
+      -- wait for the subprocess to finish
+      e <- SPPB.getProcessStatus True True pid >>= \case
+        i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
+        i                        -> pure $ toProcessError exe args i
+
+      -- make sure the logging thread stops
+      case e of
+        Left  _ -> EX.throwTo tid (StopThread False)
+        Right _ -> EX.throwTo tid (StopThread True)
+      takeMVar done
+
+      closeFd stdoutRead
+      pure e
+
+  -- Reads fdIn and logs the output in a continous scrolling area
+  -- of 'size' terminal lines. Also writes to a log file.
+  printToRegion fileFd fdIn size = do
+    ref <- newIORef ([] :: [ByteString])
+    displayConsoleRegions $ do
+      rs <- sequence . replicate size . openConsoleRegion $ Linear
+      flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
+        $ handle
+            (\(StopThread b) -> do
+              when b (forM_ rs closeConsoleRegion)
+              EX.throw (StopThread b)
+            )
+        $ readForever (lineAction ref rs) fdIn
+
+   where
+    -- action to perform line by line
+    lineAction ref rs bs' = do
+      modifyIORef' ref (swapRegs bs')
+      regs <- readIORef ref
+      forM (zip regs rs) $ \(bs, r) -> do
+        setConsoleRegion r $ do
+          w <- consoleWidth
+          return
+            . T.pack
+            . color Blue
+            . T.unpack
+            . E.decodeUtf8
+            . trim w
+            . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
+            $ bs
+        SPIB.fdWrite fileFd (bs <> "\n")


-    SPPB.getProcessStatus True True pid >>= \case
-      i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
-      i                         -> pure $ toProcessError exe args i
+    swapRegs bs regs | length regs < size = regs ++ [bs]
+                     | otherwise          = tail regs ++ [bs]
+
+    -- trim output line to terminal width
+    trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
+              | otherwise                 = bs
+
+    -- read an entire line from the file descriptor (removes the newline char)
+    readLine fd' = do
+      bs <-
+        handle
+            (\(e :: IOError) -> do
+              if isEOFError e then threadDelay 1000 >> pure "" else throw e
+            )
+          $ SPIB.fdRead fd' 1
+      if
+        | bs == "\n" -> pure ""
+        | bs == ""   -> pure ""
+        | otherwise  -> fmap (bs <>) $ readLine fd'
+
+    readForever action' fd' = do
+      bs <- readLine fd'
+      if not $ BS.null bs
+        then action' bs >> readForever action' fd'
+        else readForever action' fd'
+
+    readTilEOF action' fd' = do
+      bs <- readLine fd'
+      when (not $ BS.null bs) (action' bs >> readTilEOF action' fd')


 -- | Capture the stdout and stderr of the given action, which
@ -176,10 +278,13 @@ captureOutStreams action =
                                 }
        _ -> throwIO $ userError $ ("No such PID " ++ show pid)

- where
-  actionWithPipes a =
-    createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
-  cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
+
+actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
+actionWithPipes a =
+  createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
+
+cleanup :: [Fd] -> IO ()
+cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd