{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
module System.Process.Run
(
RunT
, runT
, RunState(..)
, OutputStyle(..)
, RunM
, echoStart
, echoEnd
, output
, silent
, dots
, indent
, vlevel
, quieter
, noisier
, lazy
, strict
, message
, run
, 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
data RunState text
= RunState
{ RunState text -> OutputStyle
_output :: OutputStyle
, RunState text -> text
_outprefix :: text
, RunState text -> text
_errprefix :: text
, RunState text -> Bool
_echoStart :: Bool
, RunState text -> Bool
_echoEnd :: Bool
, RunState text -> Int
_verbosity :: Int
, RunState text -> Bool
_lazy :: Bool
, RunState text -> text
_message :: text
}
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
| All
| Indented
| Silent
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 }
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 })
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)
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
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
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
_ ->
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
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
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 :: 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 ([char] -> text
forall full item. ListLike full item => [item] -> full
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 []
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)
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)
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)
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 p (m :: * -> *) a.
(MonadState BOL m, 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 p (m :: * -> *) a.
(MonadState BOL m, 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 :: (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 item (m :: * -> *) a.
(ListLike t item, 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 :: (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 :: (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