Haskell livestream - Subprocess management

Main.hs

{-# LANGUAGE ApplicativeDo     #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Concurrent.Async (Concurrently(..))
import Data.Foldable (traverse_)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import Foreign.C
import GHC.IO.Exception (IOErrorType(..), IOException(..))
import System.Process (CreateProcess(..), StdStream(..))
import System.IO (Handle)

import qualified Control.Concurrent.Async as Async
import qualified Control.Exception        as Exception
import qualified Control.Monad            as Monad
import qualified Data.List.NonEmpty       as NonEmpty
import qualified Data.Text                as Text
import qualified Data.Text.IO             as Text.IO
import qualified System.Environment       as Environment
import qualified System.Exit              as Exit
import qualified System.IO                as IO
import qualified System.Process           as Process

display :: Text -> Handle -> Text -> IO ()
display prefix handle string = do
    Text.IO.hPutStrLn handle (prefix <> " " <> string)

displayLines :: Text -> Handle -> Text -> IO ()
displayLines prefix handle string = do
    traverse_ (display prefix handle) (Text.lines string)

ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = Exception.handle handler
  where
    handler IOError{ ioe_type = ResourceVanished, ioe_errno = Just ioe }
        | Errno ioe == ePIPE = return ()
    handler exception = Exception.throwIO exception

main :: IO ()
main = do -- ignoreSigPipe $ do
    args <- Environment.getArgs

    case args of
        [] -> mempty
        command : arguments -> do
            let process = (Process.proc command arguments)
                    { std_out = CreatePipe
                    , std_err = CreatePipe
                    }

            Process.withCreateProcess process
                $ \_ (Just subStdout) (Just subStderr) processHandle -> do
                    let process prefix inHandle outHandle = loop ""
                          where
                            loop remainder = do
                                let p = display prefix outHandle

                                chunk <- Text.IO.hGetChunk inHandle
                                if Text.null chunk then
                                    Monad.when (not (Text.null remainder)) $ do
                                        p remainder
                                else do
                                    case Text.lines (remainder <> chunk) of
                                        [] -> loop ""
                                        l : ls -> do
                                            let n :: NonEmpty Text
                                                n = l :| ls
                                            traverse_ p (NonEmpty.init n)

                                            loop (NonEmpty.last n)

                    let thread0 = process "[+]" subStdout IO.stdout
                    let thread1 = process "[!]" subStderr IO.stderr
                    let thread2 = do
                            exitCode <- Process.waitForProcess processHandle

                            Exit.exitWith exitCode

                    runConcurrently $ do
                        _        <- Concurrently thread0
                        _        <- Concurrently thread1
                        exitCode <- Concurrently thread2

                        return exitCode