-- | Flexible control of progress reporting for readCreateProcess and friends.

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

module System.Process.Run
    ( 
    -- * Monad transformer
      RunT
    , runT
    , RunState(..)
    , OutputStyle(..)
    -- * Monad class
    , RunM
    -- * Modify moand RunM state parameters
    , echoStart
    , echoEnd
    , output
    , silent
    , dots
    , indent
    , vlevel
    , quieter
    , noisier
    , lazy
    , strict
    , message
    -- * Monadic process runner
    , run
    -- * Re-exports
    , module System.Process.ListLike
    ) where

#if __GLASGOW_HASKELL__ <= 709
import Data.Monoid (Monoid, mempty)
#endif
import Control.Monad (when)
import Control.Monad.State (evalState, evalStateT, get, modify, MonadState, put, StateT)
import Control.Monad.Trans (MonadIO, lift, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Data.Char (ord)
import Data.Default (Default(def))
import Data.ListLike as ListLike
    (break, fromList, head, hPutStr, length, ListLike, null, putStr, singleton, tail)
import Data.Monoid ((<>))
import Data.String (IsString, fromString)
import Data.Text (Text)
import Data.Word (Word8)
import qualified Data.Text.Lazy as Lazy (Text)
import System.IO (hPutStr, hPutStrLn, stderr)
import System.Process.ListLike

-- | This is the state record that controls the output style.
data RunState text
    = RunState
      { forall text. RunState text -> OutputStyle
_output :: OutputStyle -- ^ Overall style of output
      , forall text. RunState text -> text
_outprefix :: text     -- ^ Prefix for lines of stdout
      , forall text. RunState text -> text
_errprefix :: text     -- ^ Prefix for lines of stderr
      , forall text. RunState text -> Bool
_echoStart :: Bool     -- ^ Echo command as process starts
      , forall text. RunState text -> Bool
_echoEnd :: Bool       -- ^ Echo command as process finishes
      , forall text. RunState text -> Int
_verbosity :: Int      -- ^ A progression of progress modes
      , forall text. RunState text -> Bool
_lazy :: Bool          -- ^ Use the lazy or strict runner?
      , forall text. RunState text -> text
_message :: text       -- ^ Extra text for start/end message - e.g. the change root
      }

type RunT text m = StateT (RunState text) m

class (MonadState (RunState text) m,
       ProcessText text char,
       ListLikeProcessIO text char,
       MonadIO m, IsString text, Eq char, Dot char) =>
    RunM text char m

instance Dot Word8 where
    dot :: Word8
dot = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'.')

instance (MonadIO m, MonadState (RunState String) m) => RunM String Char m
instance (MonadIO m, MonadState (RunState Text) m) => RunM Text Char m
instance (MonadIO m, MonadState (RunState Lazy.Text) m) => RunM Lazy.Text Char m
instance (MonadIO m, MonadState (RunState ByteString) m) => RunM ByteString Word8 m
instance (MonadIO m, MonadState (RunState Lazy.ByteString) m) => RunM Lazy.ByteString Word8 m

runT :: forall m text char a. (MonadIO m, ProcessText text char) => RunT text m a -> m a
runT :: forall (m :: * -> *) text char a.
(MonadIO m, ProcessText text char) =>
RunT text m a -> m a
runT RunT text m a
action = RunT text m a -> RunState text -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT RunT text m a
action (RunState text
forall a. Default a => a
def :: RunState text)

data OutputStyle
    = Dots Int  -- ^ Output one dot per n output characters
    | All       -- ^ send process stdout to console stdout and process stderr to console stderr
    | Indented  -- ^ Output with prefixes
    | Silent    -- ^ No output

instance ProcessText text char => Default (RunState text) where
    def :: RunState text
def = RunState { _outprefix :: text
_outprefix = String -> text
forall a. IsString a => String -> a
fromString String
"1> "
                   , _errprefix :: text
_errprefix = String -> text
forall a. IsString a => String -> a
fromString String
"2> "
                   , _output :: OutputStyle
_output = OutputStyle
All
                   , _echoStart :: Bool
_echoStart = Bool
True
                   , _echoEnd :: Bool
_echoEnd = Bool
True
                   , _verbosity :: Int
_verbosity = Int
3
                   , _lazy :: Bool
_lazy = Bool
False
                   , _message :: text
_message = text
forall a. Monoid a => a
mempty }

{-
class (Monoid text, MonadIO m) => MonadRun m text where
    type Text m
    getRunState :: m (RunState text)
    putRunState :: RunState text -> m ()

instance Monoid text => MonadRun IO text where
    getRunState = return def
    putRunState _ = return ()

instance (MonadIO m, Monoid t, MonadState (RunState t) m) => MonadRun m t where
    getRunState = get
    putRunState = put
-}

noEcho :: (MonadState (RunState t) m) => m ()
noEcho :: forall t (m :: * -> *). MonadState (RunState t) m => m ()
noEcho = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState t
x -> RunState t
x { _echoStart = False, _echoEnd = False })

echoStart :: (MonadState (RunState t) m) => m ()
echoStart :: forall t (m :: * -> *). MonadState (RunState t) m => m ()
echoStart = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState t
x -> RunState t
x { _echoStart = True })

echoEnd :: (MonadState (RunState t) m) => m ()
echoEnd :: forall t (m :: * -> *). MonadState (RunState t) m => m ()
echoEnd = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState t
x -> RunState t
x { _echoEnd = True })

output :: (MonadState (RunState t) m) => m ()
output :: forall t (m :: * -> *). MonadState (RunState t) m => m ()
output = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState t
x -> RunState t
x { _output = All })

silent :: (MonadState (RunState t) m) => m ()
silent :: forall t (m :: * -> *). MonadState (RunState t) m => m ()
silent = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState t
x -> RunState t
x { _output = Silent })

dots :: (MonadState (RunState t) m) => Int -> m ()
dots :: forall t (m :: * -> *). MonadState (RunState t) m => Int -> m ()
dots Int
n = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState t
x -> RunState t
x { _output = Dots n })

-- | Modify the indentation prefixes for stdout and stderr in the
-- progress monad.
indent :: (MonadState (RunState t) m, ListLike t char) => (t -> t) -> (t -> t) -> m ()
indent :: forall t (m :: * -> *) char.
(MonadState (RunState t) m, ListLike t char) =>
(t -> t) -> (t -> t) -> m ()
indent t -> t
so t -> t
se = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RunState t -> RunState t) -> m ())
-> (RunState t -> RunState t) -> m ()
forall a b. (a -> b) -> a -> b
$ \RunState t
x ->
    let so' :: t
so' = t -> t
so (RunState t -> t
forall text. RunState text -> text
_outprefix RunState t
x)
        se' :: t
se' = t -> t
se (RunState t -> t
forall text. RunState text -> text
_errprefix RunState t
x) in
    RunState t
x { _outprefix = so'
      , _errprefix = se'
      , _output = if ListLike.null so' &&
                     ListLike.null se' then _output x else Indented }

noIndent :: (MonadState (RunState text) m, ListLike text char) => m ()
noIndent :: forall text (m :: * -> *) char.
(MonadState (RunState text) m, ListLike text char) =>
m ()
noIndent = (text -> text) -> (text -> text) -> m ()
forall t (m :: * -> *) char.
(MonadState (RunState t) m, ListLike t char) =>
(t -> t) -> (t -> t) -> m ()
indent (text -> text -> text
forall a b. a -> b -> a
const text
forall a. Monoid a => a
mempty) (text -> text -> text
forall a b. a -> b -> a
const text
forall a. Monoid a => a
mempty)

-- | Set verbosity to a specific level from 0 to 3.
-- vlevel :: (MonadIO m, Monoid text, MonadState (RunState text) m) => Int -> m ()
-- vlevel :: forall m text char. (IsString text, ListLike text char, MonadIO m) => Int -> m ()
vlevel :: forall m text char.
          (IsString text, ListLike text char, MonadIO m, MonadState (RunState text) m) =>
          Int -> m ()
vlevel :: forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel Int
n = do
  (RunState text -> RunState text) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState text
x -> RunState text
x {_verbosity = n})
  case Int
n of
    Int
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> m ()
forall t (m :: * -> *). MonadState (RunState t) m => m ()
noEcho m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall t (m :: * -> *). MonadState (RunState t) m => m ()
silent m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall text (m :: * -> *) char.
(MonadState (RunState text) m, ListLike text char) =>
m ()
noIndent -- No output
    Int
1 -> Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel Int
0 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall t (m :: * -> *). MonadState (RunState t) m => m ()
echoStart                 -- Output command at start
    Int
2 -> Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel Int
1 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall t (m :: * -> *). MonadState (RunState t) m => m ()
echoEnd m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m ()
forall t (m :: * -> *). MonadState (RunState t) m => Int -> m ()
dots Int
100       -- Output command at start and end, dots to show output
    Int
_ ->                                       -- echo command at start and end, and send all output
                                               -- to the console with channel prefixes 1> and 2>
          Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel Int
2 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall t (m :: * -> *). MonadState (RunState t) m => m ()
output m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (text -> text) -> (text -> text) -> m ()
forall t (m :: * -> *) char.
(MonadState (RunState t) m, ListLike t char) =>
(t -> t) -> (t -> t) -> m ()
indent (text -> text -> text
forall a b. a -> b -> a
const (String -> text
forall a. IsString a => String -> a
fromString String
"1> ")) (text -> text -> text
forall a b. a -> b -> a
const (String -> text
forall a. IsString a => String -> a
fromString (String
"2> ")))

quieter :: RunM text char m => m ()
quieter :: forall text char (m :: * -> *). RunM text char m => m ()
quieter = m (RunState text)
forall s (m :: * -> *). MonadState s m => m s
get m (RunState text) -> (RunState text -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RunState text
x -> Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel (RunState text -> Int
forall text. RunState text -> Int
_verbosity RunState text
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

noisier :: RunM text char m => m ()
noisier :: forall text char (m :: * -> *). RunM text char m => m ()
noisier = m (RunState text)
forall s (m :: * -> *). MonadState s m => m s
get m (RunState text) -> (RunState text -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RunState text
x -> Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel (RunState text -> Int
forall text. RunState text -> Int
_verbosity RunState text
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

strict :: RunM text char m => m ()
strict :: forall text char (m :: * -> *). RunM text char m => m ()
strict = (RunState text -> RunState text) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState text
x -> RunState text
x { _lazy = False })

lazy :: RunM text char m => m ()
lazy :: forall text char (m :: * -> *). RunM text char m => m ()
lazy = (RunState text -> RunState text) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState text
x -> RunState text
x { _lazy = True})

message :: RunM text char m => (text -> text) -> m ()
message :: forall text char (m :: * -> *).
RunM text char m =>
(text -> text) -> m ()
message text -> text
f = (RunState text -> RunState text) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState text
x -> RunState text
x { _message = f (_message x) })

class Dot c where
    dot :: c

instance Dot Char where
    dot :: Char
dot = Char
'.'

run' :: forall m maker text char.
        (RunM text char m,
         ProcessMaker maker) =>
        maker -> text -> m [Chunk text]
run' :: forall (m :: * -> *) maker text char.
(RunM text char m, ProcessMaker maker) =>
maker -> text -> m [Chunk text]
run' maker
maker text
input = do
  st0 <- m (RunState text)
forall s (m :: * -> *). MonadState s m => m s
get
  when (_echoStart st0) (liftIO $ hPutStrLn stderr ("-> " ++ showProcessMakerForUser maker))
  result <- liftIO $ (if _lazy st0 then readCreateProcessLazy else readCreateProcess) maker input >>= doOutput st0
  when (_echoEnd st0) (liftIO $ hPutStrLn stderr ("<- " ++ showProcessMakerForUser maker))
  return result
    where
      doOutput :: RunState text -> [Chunk text] -> IO [Chunk text]
      doOutput :: RunState text -> [Chunk text] -> IO [Chunk text]
doOutput (RunState {_output :: forall text. RunState text -> OutputStyle
_output = Dots Int
n}) [Chunk text]
cs = Int -> [Chunk text] -> IO [Chunk text]
forall text char.
(ListLikeProcessIO text char, Dot char) =>
Int -> [Chunk text] -> IO [Chunk text]
putDotsLn Int
n [Chunk text]
cs
      doOutput (RunState {_output :: forall text. RunState text -> OutputStyle
_output = OutputStyle
Silent}) [Chunk text]
cs = [Chunk text] -> IO [Chunk text]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk text]
cs
      doOutput (RunState {_output :: forall text. RunState text -> OutputStyle
_output = OutputStyle
All}) [Chunk text]
cs = [Chunk text] -> IO [Chunk text]
forall a c. ListLikeIO a c => [Chunk a] -> IO [Chunk a]
writeOutput [Chunk text]
cs
      doOutput (RunState {_output :: forall text. RunState text -> OutputStyle
_output = OutputStyle
Indented, _outprefix :: forall text. RunState text -> text
_outprefix = text
outp, _errprefix :: forall text. RunState text -> text
_errprefix = text
errp}) [Chunk text]
cs = text -> text -> [Chunk text] -> IO [Chunk text]
forall text char.
(ListLikeProcessIO text char, Eq char, IsString text) =>
text -> text -> [Chunk text] -> IO [Chunk text]
writeOutputIndented text
outp text
errp [Chunk text]
cs

run :: forall m maker text char result.
       (RunM text char m,
        ProcessMaker maker,
        ProcessResult text result) =>
       maker -> text -> m result
run :: forall (m :: * -> *) maker text char result.
(RunM text char m, ProcessMaker maker,
 ProcessResult text result) =>
maker -> text -> m result
run maker
maker text
input = maker -> text -> m [Chunk text]
forall (m :: * -> *) maker text char.
(RunM text char m, ProcessMaker maker) =>
maker -> text -> m [Chunk text]
run' maker
maker text
input m [Chunk text] -> ([Chunk text] -> m result) -> m result
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= result -> m result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (result -> m result)
-> ([Chunk text] -> result) -> [Chunk text] -> m result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Chunk text] -> result
forall a b. ProcessResult a b => [Chunk a] -> b
collectOutput

-- | Output the dotified text of a chunk list with a newline at EOF.
-- Returns the original list.
putDotsLn :: (ListLikeProcessIO text char, Dot char) =>
             Int -> [Chunk text] -> IO [Chunk text]
putDotsLn :: forall text char.
(ListLikeProcessIO text char, Dot char) =>
Int -> [Chunk text] -> IO [Chunk text]
putDotsLn Int
cpd [Chunk text]
chunks = Int -> [Chunk text] -> IO [Chunk text]
forall text char.
(ListLikeProcessIO text char, Dot char) =>
Int -> [Chunk text] -> IO [Chunk text]
putDots Int
cpd [Chunk text]
chunks IO [Chunk text]
-> ([Chunk text] -> IO [Chunk text]) -> IO [Chunk text]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ [Chunk text]
r -> Handle -> String -> IO ()
System.IO.hPutStr Handle
stderr String
"\n" IO () -> IO [Chunk text] -> IO [Chunk text]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Chunk text] -> IO [Chunk text]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk text]
r

-- | Output the dotified text of a chunk list. Returns the original
-- (undotified) list.
putDots :: (ListLikeProcessIO text char, Dot char) => Int -> [Chunk text] -> IO [Chunk text]
putDots :: forall text char.
(ListLikeProcessIO text char, Dot char) =>
Int -> [Chunk text] -> IO [Chunk text]
putDots Int
charsPerDot [Chunk text]
chunks =
    StateT Int IO [Chunk text] -> Int -> IO [Chunk text]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((Chunk text -> StateT Int IO (Chunk text))
-> [Chunk text] -> StateT Int IO [Chunk text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ Chunk text
x -> Int -> Chunk text -> StateT Int IO [Chunk text]
forall text char (m :: * -> *).
(Monad m, ListLike text char, Dot char) =>
Int -> Chunk text -> StateT Int m [Chunk text]
dotifyChunk Int
charsPerDot Chunk text
x StateT Int IO [Chunk text]
-> ([Chunk text] -> StateT Int IO ()) -> StateT Int IO ()
forall a b.
StateT Int IO a -> (a -> StateT Int IO b) -> StateT Int IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Chunk text -> StateT Int IO ())
-> [Chunk text] -> StateT Int IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> StateT Int IO ()
forall (m :: * -> *) a. Monad m => m a -> StateT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT Int IO ())
-> (Chunk text -> IO ()) -> Chunk text -> StateT Int IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk text -> IO ()
forall text char.
ListLikeProcessIO text char =>
Chunk text -> IO ()
putChunk) StateT Int IO ()
-> StateT Int IO (Chunk text) -> StateT Int IO (Chunk text)
forall a b. StateT Int IO a -> StateT Int IO b -> StateT Int IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chunk text -> StateT Int IO (Chunk text)
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Chunk text
x) [Chunk text]
chunks) Int
0

-- | dotifyChunk charsPerDot dot chunk - Replaces every charsPerDot
-- characters in the Stdout and Stderr chunks with one dot.  Runs in
-- the state monad to keep track of how many characters had been seen
-- when the previous chunk finished.  chunks.
dotifyChunk :: forall text char m. (Monad m, ListLike text char, Dot char) =>
               Int -> Chunk text -> StateT Int m [Chunk text]
dotifyChunk :: forall text char (m :: * -> *).
(Monad m, ListLike text char, Dot char) =>
Int -> Chunk text -> StateT Int m [Chunk text]
dotifyChunk Int
charsPerDot Chunk text
chunk =
    case Chunk text
chunk of
      Stdout text
x -> Int -> StateT Int m [Chunk text]
doChars (text -> Int
forall full item. ListLike full item => full -> Int
ListLike.length text
x)
      Stderr text
x -> Int -> StateT Int m [Chunk text]
doChars (text -> Int
forall full item. ListLike full item => full -> Int
ListLike.length text
x)
      Chunk text
_ -> [Chunk text] -> StateT Int m [Chunk text]
forall a. a -> StateT Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk text
chunk]
    where
      doChars :: Int -> StateT Int m [Chunk text]
      doChars :: Int -> StateT Int m [Chunk text]
doChars Int
count = do
        remaining <- StateT Int m Int
forall s (m :: * -> *). MonadState s m => m s
get
        let (count', remaining') = divMod (remaining + count) (fromIntegral charsPerDot)
        put remaining'
        if (count' > 0) then return [Stderr (ListLike.fromList (replicate count' dot))] else return []

-- | Write the Stdout chunks to stdout and the Stderr chunks to stderr.
putChunk :: ListLikeProcessIO text char => Chunk text -> IO ()
putChunk :: forall text char.
ListLikeProcessIO text char =>
Chunk text -> IO ()
putChunk (Stdout text
x) = text -> IO ()
forall full item. ListLikeIO full item => full -> IO ()
ListLike.putStr text
x
putChunk (Stderr text
x) = Handle -> text -> IO ()
forall full item. ListLikeIO full item => Handle -> full -> IO ()
ListLike.hPutStr Handle
stderr text
x
putChunk Chunk text
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

writeOutputIndented :: (ListLikeProcessIO text char, Eq char, IsString text) =>
                       text -> text -> [Chunk text] -> IO [Chunk text]
writeOutputIndented :: forall text char.
(ListLikeProcessIO text char, Eq char, IsString text) =>
text -> text -> [Chunk text] -> IO [Chunk text]
writeOutputIndented text
outp text
errp [Chunk text]
chunks =
    ((Chunk text, [Chunk text]) -> IO (Chunk text))
-> [(Chunk text, [Chunk text])] -> IO [Chunk text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Chunk text
c, [Chunk text]
cs) -> (Chunk text -> IO (Chunk text)) -> [Chunk text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Chunk text -> IO (Chunk text)
forall a c. ListLikeIO a c => Chunk a -> IO (Chunk a)
writeChunk [Chunk text]
cs IO () -> IO (Chunk text) -> IO (Chunk text)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chunk text -> IO (Chunk text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Chunk text
c) (text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]
forall text char.
(ListLikeProcessIO text char, Eq char, IsString text) =>
text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]
indentChunks text
outp text
errp [Chunk text]
chunks)

-- | Pure function to indent the text of a chunk list.
indentChunks :: forall text char. (ListLikeProcessIO text char, Eq char, IsString text) =>
                text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]
indentChunks :: forall text char.
(ListLikeProcessIO text char, Eq char, IsString text) =>
text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]
indentChunks text
outp text
errp [Chunk text]
chunks =
    State BOL [(Chunk text, [Chunk text])]
-> BOL -> [(Chunk text, [Chunk text])]
forall s a. State s a -> s -> a
evalState ((Chunk text -> StateT BOL Identity (Chunk text, [Chunk text]))
-> [Chunk text] -> State BOL [(Chunk text, [Chunk text])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (char
-> text
-> text
-> Chunk text
-> StateT BOL Identity (Chunk text, [Chunk text])
forall (m :: * -> *) text char.
(Eq char, ListLike text char, MonadState BOL m) =>
char -> text -> text -> Chunk text -> m (Chunk text, [Chunk text])
indentChunk char
nl text
outp text
errp) [Chunk text]
chunks) BOL
BOL
    where
      nl :: char
      nl :: char
nl = text -> char
forall full item. ListLike full item => full -> item
ListLike.head (String -> text
forall a. IsString a => String -> a
fromString String
"\n" :: text)

-- | The monad state, are we at the beginning of a line or the middle?
data BOL = BOL | MOL deriving (BOL -> BOL -> Bool
(BOL -> BOL -> Bool) -> (BOL -> BOL -> Bool) -> Eq BOL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BOL -> BOL -> Bool
== :: BOL -> BOL -> Bool
$c/= :: BOL -> BOL -> Bool
/= :: BOL -> BOL -> Bool
Eq)

-- | Indent the text of a chunk with the prefixes given for stdout and
-- stderr.  The state monad keeps track of whether we are at the
-- beginning of a line - when we are and more text comes we insert one
-- of the prefixes.
indentChunk :: forall m text char.
               (Eq char, ListLike text char, MonadState BOL m) =>
               char -> text -> text -> Chunk text -> m (Chunk text, [Chunk text])
indentChunk :: forall (m :: * -> *) text char.
(Eq char, ListLike text char, MonadState BOL m) =>
char -> text -> text -> Chunk text -> m (Chunk text, [Chunk text])
indentChunk char
nl text
outp text
errp Chunk text
chunk =
    case Chunk text
chunk of
      Stdout text
x -> (text -> Chunk text) -> text -> text -> m [Chunk text]
forall {full} {m :: * -> *} {a}.
(Item full ~ char, MonadState BOL m, ListLike full char) =>
(full -> a) -> full -> full -> m [a]
doText text -> Chunk text
forall a. a -> Chunk a
Stdout text
outp text
x m [Chunk text]
-> ([Chunk text] -> m (Chunk text, [Chunk text]))
-> m (Chunk text, [Chunk text])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text]))
-> ([Chunk text] -> (Chunk text, [Chunk text]))
-> [Chunk text]
-> m (Chunk text, [Chunk text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk text
chunk,)
      Stderr text
x -> (text -> Chunk text) -> text -> text -> m [Chunk text]
forall {full} {m :: * -> *} {a}.
(Item full ~ char, MonadState BOL m, ListLike full char) =>
(full -> a) -> full -> full -> m [a]
doText text -> Chunk text
forall a. a -> Chunk a
Stderr text
errp text
x m [Chunk text]
-> ([Chunk text] -> m (Chunk text, [Chunk text]))
-> m (Chunk text, [Chunk text])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text]))
-> ([Chunk text] -> (Chunk text, [Chunk text]))
-> [Chunk text]
-> m (Chunk text, [Chunk text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk text
chunk,)
      Chunk text
_ -> (Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Chunk text
chunk, [Chunk text
chunk])
    where
      -- doText :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
      doText :: (full -> a) -> full -> full -> m [a]
doText full -> a
con full
pre full
x = do
        let (full
hd, full
tl) = (char -> Bool) -> full -> (full, full)
forall full item.
ListLike full item =>
(item -> Bool) -> full -> (full, full)
ListLike.break (char -> char -> Bool
forall a. Eq a => a -> a -> Bool
== char
nl) full
x
        hd' <- (full -> a) -> full -> full -> m [a]
forall {t} {m :: * -> *} {a}.
(ListLike t (Item t), MonadState BOL m) =>
(t -> a) -> t -> t -> m [a]
doHead full -> a
con full
pre full
hd
        tl' <- doTail con pre tl
        return $ hd' <> tl'
      -- doHead :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
      doHead :: (t -> a) -> t -> t -> m [a]
doHead t -> a
_ t
_ t
x | t -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null t
x = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      doHead t -> a
con t
pre t
x = do
        bol <- m BOL
forall s (m :: * -> *). MonadState s m => m s
get
        case bol of
          BOL
BOL -> BOL -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put BOL
MOL m () -> m [a] -> m [a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [t -> a
con (t
pre t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
x)]
          BOL
MOL -> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [t -> a
con t
x]
      -- doTail :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
      doTail :: (full -> a) -> full -> full -> m [a]
doTail full -> a
_ full
_ full
x | full -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null full
x = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      doTail full -> a
con full
pre full
x = do
        bol <- m BOL
forall s (m :: * -> *). MonadState s m => m s
get
        put BOL
        tl <- doText con pre (ListLike.tail x)
        return $ (if bol == BOL then [con pre] else []) <> [con (singleton nl)] <> tl