{-# 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 :: forall (m :: * -> *). MonadIO m => Text -> m ()
say = Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
stdout
{-# INLINE say #-}
sayString :: MonadIO m => String -> m ()
sayString :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *) a. (MonadIO m, Show a) => 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 :: forall (m :: * -> *). MonadIO m => Text -> m ()
sayErr = Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
stderr
{-# INLINE sayErr #-}
sayErrString :: MonadIO m => String -> m ()
sayErrString :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *) a. (MonadIO m, Show a) => 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 :: forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
h 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 String
"hSay" Handle
h ((Handle__ -> IO (IO ())) -> IO (IO ()))
-> (Handle__ -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \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 String
"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
Newline
LF -> IO ()
viaUtf8Raw
Newline
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
Newline
CRLF -> CharBuffer -> Stream Char -> IO ()
writeBlocksCRLF CharBuffer
buf Stream Char
str
Newline
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 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 String
"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
== Word8
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 (Word8
13, Word8
10)
where
fixed2 :: (Word8, Word8) -> FixedPrim b
fixed2 (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 RawBuffer Char
b 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)
BufferList Char
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 CharBuffer
buf0 (Stream s -> Step s Char
next0 s
s0 Size
_len) =
s -> CharBuffer -> IO ()
outer s
s0 CharBuffer
buf0
where
outer :: s -> CharBuffer -> IO ()
outer 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 Int
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
Step s Char
Done
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 Char
'\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 -> Int -> IO ()
inner s
s' Int
n
Yield Char
x s
s'
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 CharBuffer
buf0 (Stream s -> Step s Char
next0 s
s0 Size
_len) =
s -> CharBuffer -> IO ()
outer s
s0 CharBuffer
buf0
where
outer :: s -> CharBuffer -> IO ()
outer 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 Int
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
Step s Char
Done
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 Char
'\r'
Int
n2 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n1 Char
'\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 -> Int -> IO ()
inner s
s' Int
n
Yield Char
'\n' s
s'
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 Char
'\r'
Int
n2 <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
raw Int
n1 Char
'\n'
s -> Int -> IO ()
inner s
s' Int
n2
Yield Char
x s
s'
| Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 Handle
hdl !RawBuffer Char
raw !Int
sz !Int
count Bool
flush Bool
release =
String -> Handle -> (Handle__ -> IO CharBuffer) -> IO CharBuffer
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle String
"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 :: forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hSayString 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 :: forall (m :: * -> *) a. (MonadIO m, Show a) => Handle -> a -> m ()
hSayShow 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 #-}