-- | 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
      { RunState text -> OutputStyle
_output :: OutputStyle -- ^ Overall style of output
      , RunState text -> text
_outprefix :: text     -- ^ Prefix for lines of stdout
      , RunState text -> text
_errprefix :: text     -- ^ Prefix for lines of stderr
      , RunState text -> Bool
_echoStart :: Bool     -- ^ Echo command as process starts
      , RunState text -> Bool
_echoEnd :: Bool       -- ^ Echo command as process finishes
      , RunState text -> Int
_verbosity :: Int      -- ^ A progression of progress modes
      , RunState text -> Bool
_lazy :: Bool          -- ^ Use the lazy or strict runner?
      , 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 '.')

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 :: RunT text m a -> m a
runT action :: 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 :: forall text.
OutputStyle
-> text
-> text
-> Bool
-> Bool
-> Int
-> Bool
-> text
-> RunState text
RunState { _outprefix :: text
_outprefix = String -> text
forall a. IsString a => String -> a
fromString "1> "
                   , _errprefix :: text
_errprefix = String -> text
forall a. IsString a => String -> a
fromString "2> "
                   , _output :: OutputStyle
_output = OutputStyle
All
                   , _echoStart :: Bool
_echoStart = Bool
True
                   , _echoEnd :: Bool
_echoEnd = Bool
True
                   , _verbosity :: Int
_verbosity = 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 :: m ()
noEcho = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\x :: RunState t
x -> RunState t
x { _echoStart :: Bool
_echoStart = Bool
False, _echoEnd :: Bool
_echoEnd = Bool
False })

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

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

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

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

dots :: (MonadState (RunState t) m) => Int -> m ()
dots :: Int -> m ()
dots n :: Int
n = (RunState t -> RunState t) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\x :: RunState t
x -> RunState t
x { _output :: OutputStyle
_output = Int -> OutputStyle
Dots Int
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 :: (t -> t) -> (t -> t) -> m ()
indent so :: t -> t
so se :: 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
$ \x :: 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 :: t
_outprefix = t
so'
      , _errprefix :: t
_errprefix = t
se'
      , _output :: OutputStyle
_output = if t -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null t
so' Bool -> Bool -> Bool
&&
                     t -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null t
se' then RunState t -> OutputStyle
forall text. RunState text -> OutputStyle
_output RunState t
x else OutputStyle
Indented }

noIndent :: (MonadState (RunState text) m, ListLike text char) => m ()
noIndent :: 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 :: Int -> m ()
vlevel n :: Int
n = do
  (RunState text -> RunState text) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\x :: RunState text
x -> RunState text
x {_verbosity :: Int
_verbosity = Int
n})
  case Int
n of
    _ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 -> m ()
forall t (m :: * -> *). MonadState (RunState t) m => m ()
noEcho m () -> m () -> m ()
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 (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
    1 -> Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel 0 m () -> m () -> m ()
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
    2 -> Int -> m ()
forall (m :: * -> *) text char.
(IsString text, ListLike text char, MonadIO m,
 MonadState (RunState text) m) =>
Int -> m ()
vlevel 1 m () -> m () -> m ()
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m ()
forall t (m :: * -> *). MonadState (RunState t) m => Int -> m ()
dots 100       -- Output command at start and end, dots to show output
    _ ->                                       -- 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 2 m () -> m () -> m ()
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 (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 "1> ")) (text -> text -> text
forall a b. a -> b -> a
const (String -> text
forall a. IsString a => String -> a
fromString ("2> ")))

quieter :: RunM text char m => m ()
quieter :: m ()
quieter = m (RunState text)
forall s (m :: * -> *). MonadState s m => m s
get m (RunState text) -> (RunState text -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: 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
- 1)

noisier :: RunM text char m => m ()
noisier :: m ()
noisier = m (RunState text)
forall s (m :: * -> *). MonadState s m => m s
get m (RunState text) -> (RunState text -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: 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
+ 1)

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

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

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

class Dot c where
    dot :: c

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

run' :: forall m maker text char.
        (RunM text char m,
         ProcessMaker maker) =>
        maker -> text -> m [Chunk text]
run' :: maker -> text -> m [Chunk text]
run' maker :: maker
maker input :: text
input = do
  RunState text
st0 <- m (RunState text)
forall s (m :: * -> *). MonadState s m => m s
get
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunState text -> Bool
forall text. RunState text -> Bool
_echoStart RunState text
st0) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr ("-> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ maker -> String
forall a. ProcessMaker a => a -> String
showProcessMakerForUser maker
maker))
  [Chunk text]
result <- IO [Chunk text] -> m [Chunk text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Chunk text] -> m [Chunk text])
-> IO [Chunk text] -> m [Chunk text]
forall a b. (a -> b) -> a -> b
$ (if RunState text -> Bool
forall text. RunState text -> Bool
_lazy RunState text
st0 then maker -> text -> IO [Chunk text]
forall maker a b c.
(ProcessMaker maker, ProcessResult a b, ListLikeProcessIO a c) =>
maker -> a -> IO b
readCreateProcessLazy else maker -> text -> IO [Chunk text]
forall maker a b c.
(ProcessMaker maker, ProcessResult a b, ListLikeProcessIO a c) =>
maker -> a -> IO b
readCreateProcess) maker
maker text
input IO [Chunk text]
-> ([Chunk text] -> IO [Chunk text]) -> IO [Chunk text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RunState text -> [Chunk text] -> IO [Chunk text]
doOutput RunState text
st0
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunState text -> Bool
forall text. RunState text -> Bool
_echoEnd RunState text
st0) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr ("<- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ maker -> String
forall a. ProcessMaker a => a -> String
showProcessMakerForUser maker
maker))
  [Chunk text] -> m [Chunk text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk text]
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 n :: Int
n}) cs :: [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}) cs :: [Chunk text]
cs = [Chunk text] -> IO [Chunk text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk text]
cs
      doOutput (RunState {_output :: forall text. RunState text -> OutputStyle
_output = OutputStyle
All}) cs :: [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}) cs :: [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 :: maker -> text -> m result
run maker :: maker
maker input :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= result -> m result
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 :: Int -> [Chunk text] -> IO [Chunk text]
putDotsLn cpd :: Int
cpd chunks :: [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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ r :: [Chunk text]
r -> Handle -> String -> IO ()
System.IO.hPutStr Handle
stderr "\n" IO () -> IO [Chunk text] -> IO [Chunk text]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Chunk text] -> IO [Chunk text]
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 :: Int -> [Chunk text] -> IO [Chunk text]
putDots charsPerDot :: Int
charsPerDot chunks :: [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)
mapM (\ x :: 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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chunk text -> StateT Int IO (Chunk text)
forall (m :: * -> *) a. Monad m => a -> m a
return Chunk text
x) [Chunk text]
chunks) 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 :: Int -> Chunk text -> StateT Int m [Chunk text]
dotifyChunk charsPerDot :: Int
charsPerDot chunk :: Chunk text
chunk =
    case Chunk text
chunk of
      Stdout x :: text
x -> Int -> StateT Int m [Chunk text]
doChars (text -> Int
forall full item. ListLike full item => full -> Int
ListLike.length text
x)
      Stderr x :: 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] -> StateT Int m [Chunk text]
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 count :: Int
count = do
        Int
remaining <- StateT Int m Int
forall s (m :: * -> *). MonadState s m => m s
get
        let (count' :: Int
count', remaining' :: Int
remaining') = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod (Int
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
charsPerDot)
        Int -> StateT Int m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Int
remaining'
        if (Int
count' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) then [Chunk text] -> StateT Int m [Chunk text]
forall (m :: * -> *) a. Monad m => a -> m a
return [text -> Chunk text
forall a. a -> Chunk a
Stderr ([Item text] -> text
forall l. IsList l => [Item l] -> l
ListLike.fromList (Int -> char -> [char]
forall a. Int -> a -> [a]
replicate Int
count' char
forall c. Dot c => c
dot))] else [Chunk text] -> StateT Int m [Chunk text]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Write the Stdout chunks to stdout and the Stderr chunks to stderr.
putChunk :: ListLikeProcessIO text char => Chunk text -> IO ()
putChunk :: Chunk text -> IO ()
putChunk (Stdout x :: text
x) = text -> IO ()
forall full item. ListLikeIO full item => full -> IO ()
ListLike.putStr text
x
putChunk (Stderr x :: text
x) = Handle -> text -> IO ()
forall full item. ListLikeIO full item => Handle -> full -> IO ()
ListLike.hPutStr Handle
stderr text
x
putChunk _ = () -> IO ()
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 :: text -> text -> [Chunk text] -> IO [Chunk text]
writeOutputIndented outp :: text
outp errp :: text
errp chunks :: [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)
mapM (\(c :: Chunk text
c, cs :: [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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chunk text -> IO (Chunk text)
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 :: text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]
indentChunks outp :: text
outp errp :: text
errp chunks :: [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)
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 "\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
/= :: BOL -> BOL -> Bool
$c/= :: BOL -> BOL -> Bool
== :: BOL -> BOL -> Bool
$c== :: 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 :: char -> text -> text -> Chunk text -> m (Chunk text, [Chunk text])
indentChunk nl :: char
nl outp :: text
outp errp :: text
errp chunk :: Chunk text
chunk =
    case Chunk text
chunk of
      Stdout x :: text
x -> (text -> Chunk text) -> text -> text -> m [Chunk text]
forall (m :: * -> *) p a.
(MonadState BOL m, ListLike p (Item p), ListLike p char) =>
(p -> a) -> p -> p -> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text])
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 x :: text
x -> (text -> Chunk text) -> text -> text -> m [Chunk text]
forall (m :: * -> *) p a.
(MonadState BOL m, ListLike p (Item p), ListLike p char) =>
(p -> a) -> p -> p -> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Chunk text, [Chunk text]) -> m (Chunk text, [Chunk text])
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]) -> m (Chunk text, [Chunk text])
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 :: (p -> a) -> p -> p -> m [a]
doText con :: p -> a
con pre :: p
pre x :: p
x = do
        let (hd :: p
hd, tl :: p
tl) = (char -> Bool) -> p -> (p, p)
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) p
x
        [a]
hd' <- (p -> a) -> p -> p -> m [a]
forall t (m :: * -> *) a.
(ListLike t (Item t), MonadState BOL m) =>
(t -> a) -> t -> t -> m [a]
doHead p -> a
con p
pre p
hd
        [a]
tl' <- (p -> a) -> p -> p -> m [a]
doTail p -> a
con p
pre p
tl
        [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [a]
hd' [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
tl'
      -- doHead :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
      doHead :: (t -> a) -> t -> t -> m [a]
doHead _ _ x :: t
x | t -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null t
x = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      doHead con :: t -> a
con pre :: t
pre x :: t
x = do
        BOL
bol <- m BOL
forall s (m :: * -> *). MonadState s m => m s
get
        case BOL
bol of
          BOL -> BOL -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put BOL
MOL m () -> m [a] -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [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)]
          MOL -> [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 :: (p -> a) -> p -> p -> m [a]
doTail _ _ x :: p
x | p -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null p
x = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      doTail con :: p -> a
con pre :: p
pre x :: p
x = do
        BOL
bol <- m BOL
forall s (m :: * -> *). MonadState s m => m s
get
        BOL -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put BOL
BOL
        [a]
tl <- (p -> a) -> p -> p -> m [a]
doText p -> a
con p
pre (p -> p
forall full item. ListLike full item => full -> full
ListLike.tail p
x)
        [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ (if BOL
bol BOL -> BOL -> Bool
forall a. Eq a => a -> a -> Bool
== BOL
BOL then [p -> a
con p
pre] else []) [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [p -> a
con (char -> p
forall full item. ListLike full item => item -> full
singleton char
nl)] [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
tl