diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +concurrent-output (1.0.1) unstable; urgency=medium + + * Generalize what can be output. + * Dropped dependency on MissingH; added dependency on text. + + -- Joey Hess Thu, 29 Oct 2015 00:47:12 -0400 + concurrent-output (1.0.0) unstable; urgency=medium * First release. diff --git a/Control/Concurrent/Output.hs b/Control/Concurrent/Output.hs --- a/Control/Concurrent/Output.hs +++ b/Control/Concurrent/Output.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -- | @@ -20,6 +20,7 @@ module Control.Concurrent.Output ( withConcurrentOutput, flushConcurrentOutput, + Outputable(..), outputConcurrent, createProcessConcurrent, waitForProcessConcurrent, @@ -40,13 +41,14 @@ 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 @@ -- 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 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs deleted file mode 100644 --- a/Utility/FileSystemEncoding.hs +++ /dev/null @@ -1,165 +0,0 @@ -{- GHC File system encoding handling. - - - - Copyright 2012-2014 Joey Hess - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} - -module Utility.FileSystemEncoding ( - fileEncoding, - withFilePath, - md5FilePath, - decodeBS, - encodeBS, - decodeW8, - encodeW8, - encodeW8NUL, - decodeW8NUL, - truncateFilePath, -) where - -import qualified GHC.Foreign as GHC -import qualified GHC.IO.Encoding as Encoding -import Foreign.C -import System.IO -import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 -import Data.Word -import Data.Bits.Utils -import Data.List.Utils -import qualified Data.ByteString.Lazy as L -#ifdef mingw32_HOST_OS -import qualified Data.ByteString.Lazy.UTF8 as L8 -#endif - -import Utility.Exception - -{- Sets a Handle to use the filesystem encoding. This causes data - - written or read from it to be encoded/decoded the same - - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". - -} -fileEncoding :: Handle -> IO () -#ifndef mingw32_HOST_OS -fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding -#else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} -fileEncoding h = hSetEncoding h Encoding.utf8 -#endif - -{- Marshal a Haskell FilePath into a NUL terminated C string using temporary - - storage. The FilePath is encoded using the filesystem encoding, - - reversing the decoding that should have been done when the FilePath - - was obtained. -} -withFilePath :: FilePath -> (CString -> IO a) -> IO a -withFilePath fp f = Encoding.getFileSystemEncoding - >>= \enc -> GHC.withCString enc fp f - -{- Encodes a FilePath into a String, applying the filesystem encoding. - - - - There are very few things it makes sense to do with such an encoded - - string. It's not a legal filename; it should not be displayed. - - So this function is not exported, but instead used by the few functions - - that can usefully consume it. - - - - This use of unsafePerformIO is belived to be safe; GHC's interface - - only allows doing this conversion with CStrings, and the CString buffer - - is allocated, used, and deallocated within the call, with no side - - effects. - - - - If the FilePath contains a value that is not legal in the filesystem - - encoding, rather than thowing an exception, it will be returned as-is. - -} -{-# NOINLINE _encodeFilePath #-} -_encodeFilePath :: FilePath -> String -_encodeFilePath fp = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString enc fp (GHC.peekCString Encoding.char8) - `catchNonAsync` (\_ -> return fp) - -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -md5FilePath :: FilePath -> MD5.Str -md5FilePath = MD5.Str . _encodeFilePath - -{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} -decodeBS :: L.ByteString -> FilePath -#ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . L.unpack -#else -{- On Windows, we assume that the ByteString is utf-8, since Windows - - only uses unicode for filenames. -} -decodeBS = L8.toString -#endif - -{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} -encodeBS :: FilePath -> L.ByteString -#ifndef mingw32_HOST_OS -encodeBS = L.pack . decodeW8NUL -#else -encodeBS = L8.fromString -#endif - -{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - - - w82c produces a String, which may contain Chars that are invalid - - unicode. From there, this is really a simple matter of applying the - - file system encoding, only complicated by GHC's interface to doing so. - - - - Note that the encoding stops at any NUL in the input. FilePaths - - do not normally contain embedded NUL, but Haskell Strings may. - -} -{-# NOINLINE encodeW8 #-} -encodeW8 :: [Word8] -> FilePath -encodeW8 w8 = unsafePerformIO $ do - enc <- Encoding.getFileSystemEncoding - GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc - -{- Useful when you want the actual number of bytes that will be used to - - represent the FilePath on disk. -} -decodeW8 :: FilePath -> [Word8] -decodeW8 = s2w8 . _encodeFilePath - -{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} -encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul) - where - nul = ['\NUL'] - -decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul - where - nul = ['\NUL'] - -{- Truncates a FilePath to the given number of bytes (or less), - - as represented on disk. - - - - Avoids returning an invalid part of a unicode byte sequence, at the - - cost of efficiency when running on a large FilePath. - -} -truncateFilePath :: Int -> FilePath -> FilePath -#ifndef mingw32_HOST_OS -truncateFilePath n = go . reverse - where - go f = - let bytes = decodeW8 f - in if length bytes <= n - then reverse f - else go (drop 1 f) -#else -{- On Windows, count the number of bytes used by each utf8 character. -} -truncateFilePath n = reverse . go [] n . L8.fromString - where - go coll cnt bs - | cnt <= 0 = coll - | otherwise = case L8.decode bs of - Just (c, x) | c /= L8.replacement_char -> - let x' = fromIntegral x - in if cnt - x' < 0 - then coll - else go (c:coll) (cnt - x') (L8.drop 1 bs) - _ -> coll -#endif diff --git a/concurrent-output.cabal b/concurrent-output.cabal --- a/concurrent-output.cabal +++ b/concurrent-output.cabal @@ -1,5 +1,5 @@ Name: concurrent-output -Version: 1.0.0 +Version: 1.0.1 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess @@ -20,23 +20,22 @@ Library GHC-Options: -Wall -fno-warn-tabs -O2 Build-Depends: base (>= 4.5), base < 5 - , bytestring (>= 0.10.0), bytestring (< 0.11) - , async (>= 2.0), async (< 2.1) - , stm (>= 2.0), stm (< 2.5) - , process (>= 1.2.0), process (< 1.4.0) - , unix (>= 2.7.0), unix (< 2.8.0) - , directory (>= 1.2.0), directory (< 1.3.0) - , containers (>= 0.5.0), containers (< 0.6.0) - , transformers (>= 0.3.0), transformers (< 0.5.0) - , exceptions (>= 0.8.0), exceptions (< 0.9.0) - , MissingH (>= 1.3.0), MissingH (< 1.4.0) + , bytestring (>= 0.10.0 && < 0.11) + , text (>= 1.2.0 && < 1.3.0) + , async (>= 2.0 && < 2.1) + , stm (>= 2.0 && < 2.5) + , process (>= 1.2.0 && < 1.4.0) + , unix (>= 2.7.0 && < 2.8.0) + , directory (>= 1.2.0 && < 1.3.0) + , containers (>= 0.5.0 && < 0.6.0) + , transformers (>= 0.3.0 && < 0.5.0) + , exceptions (>= 0.8.0 && < 0.9.0) Exposed-Modules: Control.Concurrent.Output Other-Modules: Utility.Monad Utility.Data Utility.Exception - Utility.FileSystemEncoding source-repository head type: git