diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2016 FP Complete + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,50 @@ +## say + +Send textual messages to a `Handle` in a thread-friendly way. + +[![Build Status](https://travis-ci.org/fpco/say.svg?branch=master)](https://travis-ci.org/fpco/say) [![Build status](https://ci.appveyor.com/api/projects/status/v628d8r2iq1kxfx5?svg=true)](https://ci.appveyor.com/project/snoyberg/say) + +The motivation for this package is described in [a blog post on Haskell's +Missing Concurrency +Basics](http://www.snoyman.com/blog/2016/11/haskells-missing-concurrency-basics). +The simple explanation is, when writing a line of textual data to a `Handle` - +such as sending some messages t o ther terminal - we'd like to have the +following properties: + +* Properly handle character encoding settings on the `Handle` +* For reasonably sized messages, ensure that the entire message is written in + one chunk to avoid interleaving data with other threads + * This includes the trailing newline character +* Avoid unnecessary memory allocations and copies +* Minimize locking +* Provide a simple API + +On the last point: for the most part, you can make the following substitutions +in your API usage: + +* Replace `putStrLn` with `say` +* Replace `print` with `sayShow` +* If you're using a `String` instead of `Text`, replace `putStrLn` with `sayString` + +In addition, `sayErr`, `sayErrString` and `sayErrShow` work on +standard error instead, and `hSay`, `hSayString` and `hSayShow` work +on arbitrary `Handle`s. + +```haskell +#!/usr/bin/env stack +-- stack --install-ghc --resolver lts-6.23 runghc --package async --package say +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad (forM_, void) +import Say (sayString) + +worker :: Int -> IO () +worker ident = forM_ [1..1000] $ \msg -> sayString $ concat + [ "Hello, I am worker #" + , show ident + , ", and this is message #" + , show msg + ] + +main :: IO () +main = void $ mapConcurrently worker [1..100] +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/say-bench.hs b/bench/say-bench.hs new file mode 100644 --- /dev/null +++ b/bench/say-bench.hs @@ -0,0 +1,42 @@ +import Criterion.Main +import qualified System.IO as IO +import System.IO.Temp +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Say + +main :: IO () +main = withSystemTempFile "say-bench" $ \_ h -> do + defaultMain $ map (doSize h) + [ 10 + , 100 + , 1000 + , 10000 + , 100000 + ] + +doSize :: IO.Handle -> Int -> Benchmark +doSize h size = bgroup (show size) + [ doString h "ascii" $ replicate size 'A' + , doString h "non-ascii" $ replicate size 'א' + ] + +doString :: IO.Handle -> String -> String -> Benchmark +doString h name' str = bgroup name' + [ doTest "string" IO.hPutStrLn str + , doTest "Text: putStrLn" TIO.hPutStrLn text + , doTest "Text: putStr" (\h t -> TIO.hPutStrLn h (T.snoc t '\n')) text + , doTest "say" hSay text + , doTest "sayString" hSayString str + , doTest "BS: putStrLn + encodeUtf8" (\h t -> S8.hPutStrLn h (TE.encodeUtf8 t)) text + , doTest "BS: putStr + encodeUtf8" (\h t -> S8.hPutStrLn h (S.snoc (TE.encodeUtf8 t) 10)) text + ] + where + text = T.pack str + + doTest name f x = bench name $ whnfIO $ do + f h x + IO.hFlush h diff --git a/say.cabal b/say.cabal new file mode 100644 --- /dev/null +++ b/say.cabal @@ -0,0 +1,54 @@ +name: say +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/fpco/say#readme +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2016 FP Complete +category: Text +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Say + build-depends: base >= 4.3 && < 5 + , bytestring >= 0.10.4 + , text >= 1.2 + , transformers + default-language: Haskell2010 + +test-suite say-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: SaySpec + build-depends: base + , bytestring + , hspec + , say + , temporary + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark say-bench + type: exitcode-stdio-1.0 + main-is: say-bench.hs + hs-source-dirs: bench + build-depends: base + , bytestring + , criterion + , say + , temporary + , text + ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/fpco/say diff --git a/src/Say.hs b/src/Say.hs new file mode 100644 --- /dev/null +++ b/src/Say.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Say + ( -- * Stdout + say + , sayString + , sayShow + -- * Stderr + , sayErr + , sayErrString + , sayErrShow + -- * Handle + , hSay + , hSayString + , hSayShow + ) where + +import Control.Monad (join, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.ByteString as S +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Prim as BBP +import qualified Data.ByteString.Char8 as S8 +import Data.IORef +import Data.Monoid (mappend) +import Data.Text (Text, pack) +import qualified Data.Text.Encoding as TE +import Data.Text.Internal.Fusion (stream) +import Data.Text.Internal.Fusion.Types (Step (..), Stream (..)) +import GHC.IO.Buffer (Buffer (..), BufferState (..), + CharBufElem, CharBuffer, + RawCharBuffer, emptyBuffer, + newCharBuffer, writeCharBuf) +import GHC.IO.Encoding.Types (textEncodingName) +import GHC.IO.Handle.Internals (wantWritableHandle) +import GHC.IO.Handle.Text (commitBuffer') +import GHC.IO.Handle.Types (BufferList (..), + Handle__ (..)) +import System.IO (Handle, Newline (..), stderr, + stdout) + +-- | Send a 'Text' to standard output, appending a newline, and chunking the +-- data. By default, the chunk size is 2048 characters, so any messages below +-- that size will be sent as one contiguous unit. If larger messages are used, +-- it is possible for interleaving with other threads to occur. +-- +-- @since 0.1.0.0 +say :: MonadIO m => Text -> m () +say = hSay stdout +{-# INLINE say #-} + +-- | Same as 'say', but operates on a 'String'. Note that this will +-- force the entire @String@ into memory at once, and will fail for +-- infinite @String@s. +-- +-- @since 0.1.0.0 +sayString :: MonadIO m => String -> m () +sayString = hSayString stdout +{-# INLINE sayString #-} + +-- | Same as 'say', but for instances of 'Show'. +-- +-- If your @Show@ instance generates infinite output, this will fail. However, +-- an infinite result for @show@ would generally be considered an invalid +-- instance anyway. +-- +-- @since 0.1.0.0 +sayShow :: (MonadIO m, Show a) => a -> m () +sayShow = hSayShow stdout +{-# INLINE sayShow #-} + +-- | Same as 'say', but data is sent to standard error. +-- +-- @since 0.1.0.0 +sayErr :: MonadIO m => Text -> m () +sayErr = hSay stderr +{-# INLINE sayErr #-} + +-- | Same as 'sayString', but data is sent to standard error. +-- +-- @since 0.1.0.0 +sayErrString :: MonadIO m => String -> m () +sayErrString = hSayString stderr +{-# INLINE sayErrString #-} + +-- | Same as 'sayShow', but data is sent to standard error. +-- +-- @since 0.1.0.0 +sayErrShow :: (MonadIO m, Show a) => a -> m () +sayErrShow = hSayShow stderr +{-# INLINE sayErrShow #-} + +-- | Same as 'say', but data is sent to the provided 'Handle'. +-- +-- @since 0.1.0.0 +hSay :: MonadIO m => Handle -> Text -> m () +hSay h msg = + liftIO $ join $ wantWritableHandle "hSay" h $ \h_ -> do + let nl = haOutputNL h_ + if fmap textEncodingName (haCodec h_) == Just "UTF-8" + then return $ case nl of + LF -> viaUtf8Raw + CRLF -> viaUtf8CRLF + else do + buf <- getSpareBuffer h_ + return $ + case nl of + CRLF -> writeBlocksCRLF buf str + LF -> writeBlocksRaw buf str + -- Note that the release called below will return the buffer to the + -- list of spares + where + str = stream msg + + viaUtf8Raw :: IO () + viaUtf8Raw = BB.hPutBuilder h (TE.encodeUtf8Builder msg `mappend` BB.word8 10) + + viaUtf8CRLF :: IO () + viaUtf8CRLF = + BB.hPutBuilder h (builder `mappend` BBP.primFixed crlf (error "viaUtf8CRLF")) + where + builder = TE.encodeUtf8BuilderEscaped escapeLF msg + escapeLF = + BBP.condB + (== 10) + (BBP.liftFixedToBounded crlf) + (BBP.liftFixedToBounded BBP.word8) + + crlf = + fixed2 (13, 10) + where + fixed2 x = const x BBP.>$< BBP.word8 BBP.>*< BBP.word8 + + getSpareBuffer :: Handle__ -> IO CharBuffer + getSpareBuffer Handle__{haCharBuffer=ref, haBuffers=spare_ref} = do + -- Despite appearances, IORef operations here are not a race + -- condition, since we're already inside the MVar lock + buf <- readIORef ref + bufs <- readIORef spare_ref + case bufs of + BufferListCons b rest -> do + writeIORef spare_ref rest + return (emptyBuffer b (bufSize buf) WriteBuffer) + BufferListNil -> do + new_buf <- newCharBuffer (bufSize buf) WriteBuffer + return new_buf + + writeBlocksRaw :: Buffer CharBufElem -> Stream Char -> IO () + writeBlocksRaw buf0 (Stream next0 s0 _len) = + outer s0 buf0 + where + outer s1 Buffer{bufRaw=raw, bufSize=len} = + inner s1 0 + where + commit = commitBuffer h raw len + inner !s !n = + case next0 s of + Done + | n + 1 >= len -> flush + | otherwise -> do + n1 <- writeCharBuf raw n '\n' + void $ commit n1 False{-no flush-} True{-release-} + Skip s' -> inner s' n + Yield x s' + | n + 1 >= len -> flush + | otherwise -> writeCharBuf raw n x >>= inner s' + where + flush = commit n True{-needs flush-} False{-don't release-} >>= outer s + + writeBlocksCRLF :: Buffer CharBufElem -> Stream Char -> IO () + writeBlocksCRLF buf0 (Stream next0 s0 _len) = + outer s0 buf0 + where + outer s1 Buffer{bufRaw=raw, bufSize=len} = + inner s1 0 + where + commit = commitBuffer h raw len + inner !s !n = + case next0 s of + Done + | n + 2 >= len -> flush + | otherwise -> do + n1 <- writeCharBuf raw n '\r' + n2 <- writeCharBuf raw n1 '\n' + void $ commit n2 False{-no flush-} True{-release-} + Skip s' -> inner s' n + Yield '\n' s' + | n + 2 >= len -> flush + | otherwise -> do + n1 <- writeCharBuf raw n '\r' + n2 <- writeCharBuf raw n1 '\n' + inner s' n2 + Yield x s' + | n + 1 >= len -> flush + | otherwise -> writeCharBuf raw n x >>= inner s' + where + flush = commit n True{-needs flush-} False{-don't release-} >>= outer s + + commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool + -> IO CharBuffer + commitBuffer hdl !raw !sz !count flush release = + wantWritableHandle "commitAndReleaseBuffer" hdl $ + commitBuffer' raw sz count flush release +{-# SPECIALIZE hSay :: Handle -> Text -> IO () #-} + +-- | Same as 'sayString', but data is sent to the provided 'Handle'. +-- +-- @since 0.1.0.0 +hSayString :: MonadIO m => Handle -> String -> m () +hSayString h = hSay h . pack +{-# INLINE hSayString #-} + +-- | Same as 'sayShow', but data is sent to the provided 'Handle'. +-- +-- @since 0.1.0.0 +hSayShow :: (MonadIO m, Show a) => Handle -> a -> m () +hSayShow h = hSayString h . show +{-# INLINE hSayShow #-} diff --git a/test/SaySpec.hs b/test/SaySpec.hs new file mode 100644 --- /dev/null +++ b/test/SaySpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +module SaySpec (spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Say +import Control.Monad (forM_) +import Data.Text (pack) +import qualified Data.Text.IO as T +import System.IO +import System.IO.Temp (withSystemTempFile) +import qualified Data.ByteString as S +import Data.List (nub) + +encodings :: [TextEncoding] +encodings = [utf8, utf16le, utf32be +#if MIN_VERSION_base(4, 4, 0) + , char8 +#endif + ] + +newlines :: [NewlineMode] +newlines = nub + [ noNewlineTranslation + , universalNewlineMode + , nativeNewlineMode + , NewlineMode CRLF CRLF + ] + +bufferings :: [BufferMode] +bufferings = + [ NoBuffering + , LineBuffering + , BlockBuffering Nothing + , BlockBuffering $ Just 10 + , BlockBuffering $ Just 2048 + , BlockBuffering $ Just 30000 + ] + +alts :: [(String, Handle -> String -> IO ())] +alts = + [ ("String", hPutStrLn) + , ("Text", \h -> T.hPutStrLn h . pack) + ] + +spec :: Spec +spec = do + forM_ encodings $ \encoding -> describe ("Encoding: " ++ show encoding) $ + forM_ newlines $ \newline -> describe ("Newline: " ++ show newline) $ + forM_ bufferings $ \buffering -> describe ("Buffering: " ++ show buffering) $ + forM_ alts $ \(altName, altFunc) -> describe ("Versus: " ++ altName) $ do + let prepHandle h = do + hSetEncoding h encoding + hSetNewlineMode h newline + hSetBuffering h buffering + + test str = + withSystemTempFile "say" $ \fpSay handleSay -> + withSystemTempFile "alt" $ \fpAlt handleAlt -> do + forM_ [(handleSay, \h -> hSay h . pack), (handleAlt, altFunc)] $ \(h, f) -> do + prepHandle h + f h str + hClose h + bsSay <- S.readFile fpSay + bsAlt <- S.readFile fpAlt + bsSay `shouldBe` bsAlt + + prop "matches" test + + forM_ [10, 20, 100, 1000, 2047, 2048, 2049, 10000] $ \size -> do + it ("size: " ++ show size) $ test $ replicate size 'A' diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}