{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Say
(
say
, sayString
, sayShow
, sayErr
, sayErrString
, sayErrShow
, 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)
say :: MonadIO m => Text -> m ()
say :: Text -> m ()
say = Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
stdout
{-# INLINE say #-}
sayString :: MonadIO m => String -> m ()
sayString :: String -> m ()
sayString = Handle -> String -> m ()
forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hSayString Handle
stdout
{-# INLINE sayString #-}
sayShow :: (MonadIO m, Show a) => a -> m ()
sayShow :: a -> m ()
sayShow = Handle -> a -> m ()
forall (m :: * -> *) a. (MonadIO m, Show a) => Handle -> a -> m ()
hSayShow Handle
stdout
{-# INLINE sayShow #-}
sayErr :: MonadIO m => Text -> m ()
sayErr :: Text -> m ()
sayErr = Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
stderr
{-# INLINE sayErr #-}
sayErrString :: MonadIO m => String -> m ()
sayErrString :: String -> m ()
sayErrString = Handle -> String -> m ()
forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hSayString Handle
stderr
{-# INLINE sayErrString #-}
sayErrShow :: (MonadIO m, Show a) => a -> m ()
sayErrShow :: a -> m ()
sayErrShow = Handle -> a -> m ()
forall (m :: * -> *) a. (MonadIO m, Show a) => Handle -> a -> m ()
hSayShow Handle
stderr
{-# INLINE sayErrShow #-}
hSay :: MonadIO m => Handle -> Text -> m ()
hSay :: Handle -> Text -> m ()
hSay h :: Handle
h msg :: Text
msg =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Handle -> (Handle__ -> IO (IO ())) -> IO (IO ())
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle "hSay" Handle
h ((Handle__ -> IO (IO ())) -> IO (IO ()))
-> (Handle__ -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \h_ :: Handle__
h_ -> do
let nl :: Newline
nl = Handle__ -> Newline
haOutputNL Handle__
h_
if (TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> String
textEncodingName (Handle__ -> Maybe TextEncoding
haCodec Handle__
h_) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "UTF-8"
then IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ case Newline
nl of
LF -> IO ()
viaUtf8Raw
CRLF -> IO ()
viaUtf8CRLF
else do
CharBuffer
buf <- Handle__ -> IO CharBuffer
getSpareBuffer Handle__
h_
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
case Newline
nl of
CRLF -> CharBuffer -> Stream Char -> IO ()
writeBlocksCRLF CharBuffer
buf Stream Char
str
LF -> CharBuffer -> Stream Char -> IO ()
writeBlocksRaw CharBuffer
buf Stream Char
str
where
str :: Stream Char
str = Text -> Stream Char
stream Text
msg
viaUtf8Raw :: IO ()
viaUtf8Raw :: IO ()
viaUtf8Raw = Handle -> Builder -> IO ()
BB.hPutBuilder Handle
h (Text -> Builder
TE.encodeUtf8Builder Text
msg Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
BB.word8 10)
viaUtf8CRLF :: IO ()
viaUtf8CRLF :: IO ()
viaUtf8CRLF =
Handle -> Builder -> IO ()
BB.hPutBuilder Handle
h (Builder
builder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` FixedPrim Any -> Any -> Builder
forall a. FixedPrim a -> a -> Builder
BBP.primFixed FixedPrim Any
forall b. FixedPrim b
crlf (String -> Any
forall a. HasCallStack => String -> a
error "viaUtf8CRLF"))
where
builder :: Builder
builder = BoundedPrim Word8 -> Text -> Builder
TE.encodeUtf8BuilderEscaped BoundedPrim Word8
escapeLF Text
msg
escapeLF :: BoundedPrim Word8
escapeLF =
(Word8 -> Bool)
-> BoundedPrim Word8 -> BoundedPrim Word8 -> BoundedPrim Word8
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BBP.condB
(Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 10)
(FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
BBP.liftFixedToBounded FixedPrim Word8
forall b. FixedPrim b
crlf)
(FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
BBP.liftFixedToBounded FixedPrim Word8
BBP.word8)
crlf :: FixedPrim b
crlf =
(Word8, Word8) -> FixedPrim b
forall b. (Word8, Word8) -> FixedPrim b
fixed2 (13, 10)
where
fixed2 :: (Word8, Word8) -> FixedPrim b
fixed2 x :: (Word8, Word8)
x = (Word8, Word8) -> b -> (Word8, Word8)
forall a b. a -> b -> a
const (Word8, Word8)
x (b -> (Word8, Word8)) -> FixedPrim (Word8, Word8) -> FixedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
BBP.>$< FixedPrim Word8
BBP.word8 FixedPrim Word8 -> FixedPrim Word8 -> FixedPrim (Word8, Word8)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BBP.>*< FixedPrim Word8
BBP.word8
getSpareBuffer :: Handle__ -> IO CharBuffer
getSpareBuffer :: Handle__ -> IO CharBuffer
getSpareBuffer Handle__{haCharBuffer :: Handle__ -> IORef CharBuffer
haCharBuffer=IORef CharBuffer
ref, haBuffers :: Handle__ -> IORef (BufferList Char)
haBuffers=IORef (BufferList Char)
spare_ref} = do
CharBuffer
buf <- IORef CharBuffer -> IO CharBuffer
forall a. IORef a -> IO a
readIORef IORef CharBuffer
ref
BufferList Char
bufs <- IORef (BufferList Char) -> IO (BufferList Char)
forall a. IORef a -> IO a
readIORef IORef (BufferList Char)
spare_ref
case BufferList Char
bufs of
BufferListCons b :: RawBuffer Char
b rest :: BufferList Char
rest -> do
IORef (BufferList Char) -> BufferList Char -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (BufferList Char)
spare_ref BufferList Char
rest
CharBuffer -> IO CharBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return (RawBuffer Char -> Int -> BufferState -> CharBuffer
forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Char
b (CharBuffer -> Int
forall e. Buffer e -> Int
bufSize CharBuffer
buf) BufferState
WriteBuffer)
BufferListNil -> do
CharBuffer
new_buf <- Int -> BufferState -> IO CharBuffer
newCharBuffer (CharBuffer -> Int
forall e. Buffer e -> Int
bufSize CharBuffer
buf) BufferState
WriteBuffer
CharBuffer -> IO CharBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return CharBuffer
new_buf
writeBlocksRaw :: Buffer CharBufElem -> Stream Char -> IO ()
writeBlocksRaw :: CharBuffer -> Stream Char -> IO ()
writeBlocksRaw buf0 :: CharBuffer
buf0 (Stream next0 :: s -> Step s Char
next0 s0 :: s
s0 _len :: Size
_len) =
s -> CharBuffer -> IO ()
outer s
s0 CharBuffer
buf0
where
outer :: s -> CharBuffer -> IO ()
outer s1 :: s
s1 Buffer{bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Char
raw, bufSize :: forall e. Buffer e -> Int
bufSize=Int
len} =
s -> Int -> IO ()
inner s
s1 0
where
commit :: Int -> Bool -> Bool -> IO CharBuffer
commit = Handle
-> RawBuffer Char -> Int -> Int -> Bool -> Bool -> IO CharBuffer
commitBuffer Handle
h RawBuffer Char
raw Int
len
inner :: s -> Int -> IO ()
inner !s
s !Int
n =
case s -> Step s Char
next0 s
s of
Done
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len -> IO ()
flush
| Bool
otherwise -> do
Int
n1 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n '\n'
IO CharBuffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CharBuffer -> IO ()) -> IO CharBuffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Bool -> IO CharBuffer
commit Int
n1 Bool
False Bool
True
Skip s' :: s
s' -> s -> Int -> IO ()
inner s
s' Int
n
Yield x :: Char
x s' :: s
s'
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len -> IO ()
flush
| Bool
otherwise -> RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n Char
x IO Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Int -> IO ()
inner s
s'
where
flush :: IO ()
flush = Int -> Bool -> Bool -> IO CharBuffer
commit Int
n Bool
True Bool
False IO CharBuffer -> (CharBuffer -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> CharBuffer -> IO ()
outer s
s
writeBlocksCRLF :: Buffer CharBufElem -> Stream Char -> IO ()
writeBlocksCRLF :: CharBuffer -> Stream Char -> IO ()
writeBlocksCRLF buf0 :: CharBuffer
buf0 (Stream next0 :: s -> Step s Char
next0 s0 :: s
s0 _len :: Size
_len) =
s -> CharBuffer -> IO ()
outer s
s0 CharBuffer
buf0
where
outer :: s -> CharBuffer -> IO ()
outer s1 :: s
s1 Buffer{bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Char
raw, bufSize :: forall e. Buffer e -> Int
bufSize=Int
len} =
s -> Int -> IO ()
inner s
s1 0
where
commit :: Int -> Bool -> Bool -> IO CharBuffer
commit = Handle
-> RawBuffer Char -> Int -> Int -> Bool -> Bool -> IO CharBuffer
commitBuffer Handle
h RawBuffer Char
raw Int
len
inner :: s -> Int -> IO ()
inner !s
s !Int
n =
case s -> Step s Char
next0 s
s of
Done
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len -> IO ()
flush
| Bool
otherwise -> do
Int
n1 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n '\r'
Int
n2 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n1 '\n'
IO CharBuffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CharBuffer -> IO ()) -> IO CharBuffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Bool -> IO CharBuffer
commit Int
n2 Bool
False Bool
True
Skip s' :: s
s' -> s -> Int -> IO ()
inner s
s' Int
n
Yield '\n' s' :: s
s'
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len -> IO ()
flush
| Bool
otherwise -> do
Int
n1 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n '\r'
Int
n2 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n1 '\n'
s -> Int -> IO ()
inner s
s' Int
n2
Yield x :: Char
x s' :: s
s'
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len -> IO ()
flush
| Bool
otherwise -> RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n Char
x IO Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Int -> IO ()
inner s
s'
where
flush :: IO ()
flush = Int -> Bool -> Bool -> IO CharBuffer
commit Int
n Bool
True Bool
False IO CharBuffer -> (CharBuffer -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> CharBuffer -> IO ()
outer s
s
commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
-> IO CharBuffer
commitBuffer :: Handle
-> RawBuffer Char -> Int -> Int -> Bool -> Bool -> IO CharBuffer
commitBuffer hdl :: Handle
hdl !RawBuffer Char
raw !Int
sz !Int
count flush :: Bool
flush release :: Bool
release =
String -> Handle -> (Handle__ -> IO CharBuffer) -> IO CharBuffer
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle "commitAndReleaseBuffer" Handle
hdl ((Handle__ -> IO CharBuffer) -> IO CharBuffer)
-> (Handle__ -> IO CharBuffer) -> IO CharBuffer
forall a b. (a -> b) -> a -> b
$
RawBuffer Char
-> Int -> Int -> Bool -> Bool -> Handle__ -> IO CharBuffer
commitBuffer' RawBuffer Char
raw Int
sz Int
count Bool
flush Bool
release
{-# SPECIALIZE hSay :: Handle -> Text -> IO () #-}
hSayString :: MonadIO m => Handle -> String -> m ()
hSayString :: Handle -> String -> m ()
hSayString h :: Handle
h = Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
h (Text -> m ()) -> (String -> Text) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
{-# INLINE hSayString #-}
hSayShow :: (MonadIO m, Show a) => Handle -> a -> m ()
hSayShow :: Handle -> a -> m ()
hSayShow h :: Handle
h = Handle -> String -> m ()
forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hSayString Handle
h (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
{-# INLINE hSayShow #-}