say (empty) → 0.1.0.0
raw patch · 9 files changed
+462/−0 lines, 9 filesdep +basedep +bytestringdep +criterionsetup-changed
Dependencies added: base, bytestring, criterion, hspec, say, temporary, text, transformers
Files
- ChangeLog.md +3/−0
- LICENSE +21/−0
- README.md +50/−0
- Setup.hs +2/−0
- bench/say-bench.hs +42/−0
- say.cabal +54/−0
- src/Say.hs +218/−0
- test/SaySpec.hs +71/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.1.0.0++* Initial commit
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,50 @@+## say++Send textual messages to a `Handle` in a thread-friendly way.++[](https://travis-ci.org/fpco/say) [](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]+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/say-bench.hs view
@@ -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
+ say.cabal view
@@ -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
+ src/Say.hs view
@@ -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 #-}
+ test/SaySpec.hs view
@@ -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'
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}