summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2015-10-29 00:38:53 -0400
committerJoey Hess2015-10-29 00:46:49 -0400
commit39fa051833de3178639974fa4fc7c803c5918f0e (patch)
tree3e3dcae0886adb1c851bdfdbc1a1d5ee99cb26e2 /src/Utility
parentceee9305dce89a9529b316db6d6a5eabe1ad8adb (diff)
generalize what can be output
This adds a dependency on Text, but I don't mind propellor depending on it and am somewhat surprised it doesn't already. Using Text also lets this use encodeUtf8 instead of the nasty hack it was using to go from String -> ByteString.
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/ConcurrentOutput.hs35
1 files changed, 25 insertions, 10 deletions
diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs
index 94cd4202..c24744a3 100644
--- a/src/Utility/ConcurrentOutput.hs
+++ b/src/Utility/ConcurrentOutput.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-- |
@@ -20,6 +20,7 @@
module Utility.ConcurrentOutput (
withConcurrentOutput,
flushConcurrentOutput,
+ Outputable(..),
outputConcurrent,
createProcessConcurrent,
waitForProcessConcurrent,
@@ -40,13 +41,14 @@ import Control.Concurrent.Async
import Data.Maybe
import Data.List
import Data.Monoid
-import qualified Data.ByteString as B
import qualified System.Process as P
import qualified Data.Set as S
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
import Utility.Monad
import Utility.Exception
-import Utility.FileSystemEncoding
data OutputHandle = OutputHandle
{ outputLock :: TMVar Lock
@@ -137,27 +139,40 @@ flushConcurrentOutput = do
-- generating output, and flush any buffered output.
lockOutput $ return ()
--- | Displays a string to stdout, and flush output so it's displayed.
+-- | Values that can be output.
+class Outputable v where
+ toOutput :: v -> B.ByteString
+
+instance Outputable B.ByteString where
+ toOutput = id
+
+instance Outputable T.Text where
+ toOutput = encodeUtf8
+
+instance Outputable String where
+ toOutput = toOutput . T.pack
+
+-- | Displays a value to stdout, and flush output so it's displayed.
--
--- Uses locking to ensure that the whole string is output atomically
+-- Uses locking to ensure that the whole output occurs atomically
-- even when other threads are concurrently generating output.
--
-- When something else is writing to the console at the same time, this does
--- not block. It buffers the string, so it will be displayed once the other
+-- not block. It buffers the value, so it will be displayed once the other
-- writer is done.
-outputConcurrent :: String -> IO ()
-outputConcurrent s = bracket setup cleanup go
+outputConcurrent :: Outputable v => v -> IO ()
+outputConcurrent v = bracket setup cleanup go
where
setup = tryTakeOutputLock
cleanup False = return ()
cleanup True = dropOutputLock
go True = do
- putStr s
+ B.hPut stdout (toOutput v)
hFlush stdout
go False = do
bv <- outputBuffer <$> getOutputHandle
oldbuf <- atomically $ takeTMVar bv
- newbuf <- addBuffer (Output (B.pack (decodeW8NUL s))) oldbuf
+ newbuf <- addBuffer (Output (toOutput v)) oldbuf
atomically $ putTMVar bv newbuf
-- | This must be used to wait for processes started with