1-- | Flexible control of progress reporting for readCreateProcess and friends.
2
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TupleSections #-}
11{-# LANGUAGE UndecidableInstances #-}
12
13module System.Process.Run
14    (
15    -- * Monad transformer
16      RunT
17    , runT
18    , RunState(..)
19    , OutputStyle(..)
20    -- * Monad class
21    , RunM
22    -- * Modify moand RunM state parameters
23    , echoStart
24    , echoEnd
25    , output
26    , silent
27    , dots
28    , indent
29    , vlevel
30    , quieter
31    , noisier
32    , lazy
33    , strict
34    , message
35    -- * Monadic process runner
36    , run
37    -- * Re-exports
38    , module System.Process.ListLike
39    ) where
40
41#if __GLASGOW_HASKELL__ <= 709
42import Data.Monoid (Monoid, mempty)
43#endif
44import Control.Monad (when)
45import Control.Monad.State (evalState, evalStateT, get, modify, MonadState, put, StateT)
46import Control.Monad.Trans (MonadIO, lift, liftIO)
47import Data.ByteString (ByteString)
48import qualified Data.ByteString.Lazy as Lazy (ByteString)
49import Data.Char (ord)
50import Data.Default (Default(def))
51import Data.ListLike as ListLike
52    (break, fromList, head, hPutStr, length, ListLike, null, putStr, singleton, tail)
53import Data.Monoid ((<>))
54import Data.String (IsString, fromString)
55import Data.Text (Text)
56import Data.Word (Word8)
57import qualified Data.Text.Lazy as Lazy (Text)
58import System.IO (hPutStr, hPutStrLn, stderr)
59import System.Process.ListLike
60
61-- | This is the state record that controls the output style.
62data RunState text
63    = RunState
64      { _output :: OutputStyle -- ^ Overall style of output
65      , _outprefix :: text     -- ^ Prefix for lines of stdout
66      , _errprefix :: text     -- ^ Prefix for lines of stderr
67      , _echoStart :: Bool     -- ^ Echo command as process starts
68      , _echoEnd :: Bool       -- ^ Echo command as process finishes
69      , _verbosity :: Int      -- ^ A progression of progress modes
70      , _lazy :: Bool          -- ^ Use the lazy or strict runner?
71      , _message :: text       -- ^ Extra text for start/end message - e.g. the change root
72      }
73
74type RunT text m = StateT (RunState text) m
75
76class (MonadState (RunState text) m,
77       ProcessText text char,
78       ListLikeProcessIO text char,
79       MonadIO m, IsString text, Eq char, Dot char) =>
80    RunM text char m
81
82instance Dot Word8 where
83    dot = fromIntegral (ord '.')
84
85instance (MonadIO m, MonadState (RunState String) m) => RunM String Char m
86instance (MonadIO m, MonadState (RunState Text) m) => RunM Text Char m
87instance (MonadIO m, MonadState (RunState Lazy.Text) m) => RunM Lazy.Text Char m
88instance (MonadIO m, MonadState (RunState ByteString) m) => RunM ByteString Word8 m
89instance (MonadIO m, MonadState (RunState Lazy.ByteString) m) => RunM Lazy.ByteString Word8 m
90
91runT :: forall m text char a. (MonadIO m, ProcessText text char) => RunT text m a -> m a
92runT action = evalStateT action (def :: RunState text)
93
94data OutputStyle
95    = Dots Int  -- ^ Output one dot per n output characters
96    | All       -- ^ send process stdout to console stdout and process stderr to console stderr
97    | Indented  -- ^ Output with prefixes
98    | Silent    -- ^ No output
99
100instance ProcessText text char => Default (RunState text) where
101    def = RunState { _outprefix = fromString "1> "
102                   , _errprefix = fromString "2> "
103                   , _output = All
104                   , _echoStart = True
105                   , _echoEnd = True
106                   , _verbosity = 3
107                   , _lazy = False
108                   , _message = mempty }
109
110{-
111class (Monoid text, MonadIO m) => MonadRun m text where
112    type Text m
113    getRunState :: m (RunState text)
114    putRunState :: RunState text -> m ()
115
116instance Monoid text => MonadRun IO text where
117    getRunState = return def
118    putRunState _ = return ()
119
120instance (MonadIO m, Monoid t, MonadState (RunState t) m) => MonadRun m t where
121    getRunState = get
122    putRunState = put
123-}
124
125noEcho :: (MonadState (RunState t) m) => m ()
126noEcho = modify (\x -> x { _echoStart = False, _echoEnd = False })
127
128echoStart :: (MonadState (RunState t) m) => m ()
129echoStart = modify (\x -> x { _echoStart = True })
130
131echoEnd :: (MonadState (RunState t) m) => m ()
132echoEnd = modify (\x -> x { _echoEnd = True })
133
134output :: (MonadState (RunState t) m) => m ()
135output = modify (\x -> x { _output = All })
136
137silent :: (MonadState (RunState t) m) => m ()
138silent = modify (\x -> x { _output = Silent })
139
140dots :: (MonadState (RunState t) m) => Int -> m ()
141dots n = modify (\x -> x { _output = Dots n })
142
143-- | Modify the indentation prefixes for stdout and stderr in the
144-- progress monad.
145indent :: (MonadState (RunState t) m, ListLike t char) => (t -> t) -> (t -> t) -> m ()
146indent so se = modify $ \x ->
147    let so' = so (_outprefix x)
148        se' = se (_errprefix x) in
149    x { _outprefix = so'
150      , _errprefix = se'
151      , _output = if ListLike.null so' &&
152                     ListLike.null se' then _output x else Indented }
153
154noIndent :: (MonadState (RunState text) m, ListLike text char) => m ()
155noIndent = indent (const mempty) (const mempty)
156
157-- | Set verbosity to a specific level from 0 to 3.
158-- vlevel :: (MonadIO m, Monoid text, MonadState (RunState text) m) => Int -> m ()
159-- vlevel :: forall m text char. (IsString text, ListLike text char, MonadIO m) => Int -> m ()
160vlevel :: forall m text char.
161          (IsString text, ListLike text char, MonadIO m, MonadState (RunState text) m) =>
162          Int -> m ()
163vlevel n = do
164  modify (\x -> x {_verbosity = n})
165  case n of
166    _ | n <= 0 -> noEcho >> silent >> noIndent -- No output
167    1 -> vlevel 0 >> echoStart                 -- Output command at start
168    2 -> vlevel 1 >> echoEnd >> dots 100       -- Output command at start and end, dots to show output
169    _ ->                                       -- echo command at start and end, and send all output
170                                               -- to the console with channel prefixes 1> and 2>
171          vlevel 2 >> output >> indent (const (fromString "1> ")) (const (fromString ("2> ")))
172
173quieter :: RunM text char m => m ()
174quieter = get >>= \x -> vlevel (_verbosity x - 1)
175
176noisier :: RunM text char m => m ()
177noisier = get >>= \x -> vlevel (_verbosity x + 1)
178
179strict :: RunM text char m => m ()
180strict = modify (\x -> x { _lazy = False })
181
182lazy :: RunM text char m => m ()
183lazy = modify (\x -> x { _lazy = True})
184
185message :: RunM text char m => (text -> text) -> m ()
186message f = modify (\x -> x { _message = f (_message x) })
187
188class Dot c where
189    dot :: c
190
191instance Dot Char where
192    dot = '.'
193
194run' :: forall m maker text char.
195        (RunM text char m,
196         ProcessMaker maker) =>
197        maker -> text -> m [Chunk text]
198run' maker input = do
199  st0 <- get
200  when (_echoStart st0) (liftIO $ hPutStrLn stderr ("-> " ++ showProcessMakerForUser maker))
201  result <- liftIO $ (if _lazy st0 then readCreateProcessLazy else readCreateProcess) maker input >>= doOutput st0
202  when (_echoEnd st0) (liftIO $ hPutStrLn stderr ("<- " ++ showProcessMakerForUser maker))
203  return result
204    where
205      doOutput :: RunState text -> [Chunk text] -> IO [Chunk text]
206      doOutput (RunState {_output = Dots n}) cs = putDotsLn n cs
207      doOutput (RunState {_output = Silent}) cs = return cs
208      doOutput (RunState {_output = All}) cs = writeOutput cs
209      doOutput (RunState {_output = Indented, _outprefix = outp, _errprefix = errp}) cs = writeOutputIndented outp errp cs
210
211run :: forall m maker text char result.
212       (RunM text char m,
213        ProcessMaker maker,
214        ProcessResult text result) =>
215       maker -> text -> m result
216run maker input = run' maker input >>= return . collectOutput
217
218-- | Output the dotified text of a chunk list with a newline at EOF.
219-- Returns the original list.
220putDotsLn :: (ListLikeProcessIO text char, Dot char) =>
221             Int -> [Chunk text] -> IO [Chunk text]
222putDotsLn cpd chunks = putDots cpd chunks >>= \ r -> System.IO.hPutStr stderr "\n" >> return r
223
224-- | Output the dotified text of a chunk list. Returns the original
225-- (undotified) list.
226putDots :: (ListLikeProcessIO text char, Dot char) => Int -> [Chunk text] -> IO [Chunk text]
227putDots charsPerDot chunks =
228    evalStateT (mapM (\ x -> dotifyChunk charsPerDot x >>= mapM_ (lift . putChunk) >> return x) chunks) 0
229
230-- | dotifyChunk charsPerDot dot chunk - Replaces every charsPerDot
231-- characters in the Stdout and Stderr chunks with one dot.  Runs in
232-- the state monad to keep track of how many characters had been seen
233-- when the previous chunk finished.  chunks.
234dotifyChunk :: forall text char m. (Monad m, ListLike text char, Dot char) =>
235               Int -> Chunk text -> StateT Int m [Chunk text]
236dotifyChunk charsPerDot chunk =
237    case chunk of
238      Stdout x -> doChars (ListLike.length x)
239      Stderr x -> doChars (ListLike.length x)
240      _ -> return [chunk]
241    where
242      doChars :: Int -> StateT Int m [Chunk text]
243      doChars count = do
244        remaining <- get
245        let (count', remaining') = divMod (remaining + count) (fromIntegral charsPerDot)
246        put remaining'
247        if (count' > 0) then return [Stderr (ListLike.fromList (replicate count' dot))] else return []
248
249-- | Write the Stdout chunks to stdout and the Stderr chunks to stderr.
250putChunk :: ListLikeProcessIO text char => Chunk text -> IO ()
251putChunk (Stdout x) = ListLike.putStr x
252putChunk (Stderr x) = ListLike.hPutStr stderr x
253putChunk _ = return ()
254
255writeOutputIndented :: (ListLikeProcessIO text char, Eq char, IsString text) =>
256                       text -> text -> [Chunk text] -> IO [Chunk text]
257writeOutputIndented outp errp chunks =
258    mapM (\(c, cs) -> mapM_ writeChunk cs >> return c) (indentChunks outp errp chunks)
259
260-- | Pure function to indent the text of a chunk list.
261indentChunks :: forall text char. (ListLikeProcessIO text char, Eq char, IsString text) =>
262                text -> text -> [Chunk text] -> [(Chunk text, [Chunk text])]
263indentChunks outp errp chunks =
264    evalState (mapM (indentChunk nl outp errp) chunks) BOL
265    where
266      nl :: char
267      nl = ListLike.head (fromString "\n" :: text)
268
269-- | The monad state, are we at the beginning of a line or the middle?
270data BOL = BOL | MOL deriving (Eq)
271
272-- | Indent the text of a chunk with the prefixes given for stdout and
273-- stderr.  The state monad keeps track of whether we are at the
274-- beginning of a line - when we are and more text comes we insert one
275-- of the prefixes.
276indentChunk :: forall m text char.
277               (Eq char, ListLike text char, MonadState BOL m) =>
278               char -> text -> text -> Chunk text -> m (Chunk text, [Chunk text])
279indentChunk nl outp errp chunk =
280    case chunk of
281      Stdout x -> doText Stdout outp x >>= return . (chunk,)
282      Stderr x -> doText Stderr errp x >>= return . (chunk,)
283      _ -> return (chunk, [chunk])
284    where
285      -- doText :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
286      doText con pre x = do
287        let (hd, tl) = ListLike.break (== nl) x
288        hd' <- doHead con pre hd
289        tl' <- doTail con pre tl
290        return $ hd' <> tl'
291      -- doHead :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
292      doHead _ _ x | ListLike.null x = return []
293      doHead con pre x = do
294        bol <- get
295        case bol of
296          BOL -> put MOL >> return [con (pre <> x)]
297          MOL -> return [con x]
298      -- doTail :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]
299      doTail _ _ x | ListLike.null x = return []
300      doTail con pre x = do
301        bol <- get
302        put BOL
303        tl <- doText con pre (ListLike.tail x)
304        return $ (if bol == BOL then [con pre] else []) <> [con (singleton nl)] <> tl
305