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