say-0.1.0.0: src/Say.hs
{-# 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 #-}