{-# 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 :: forall (m :: * -> *). MonadIO m => Text -> m ()
say = Handle -> Text -> m ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hSay Handle
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 :: forall (m :: * -> *). MonadIO m => String -> m ()
sayString = Handle -> String -> m ()
forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hSayString Handle
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 :: 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 #-}

-- | Same as 'say', but data is sent to standard error.
--
-- @since 0.1.0.0
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 #-}

-- | Same as 'sayString', but data is sent to standard error.
--
-- @since 0.1.0.0
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 #-}

-- | Same as 'sayShow', but data is sent to standard error.
--
-- @since 0.1.0.0
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 #-}

-- | Same as 'say', but data is sent to the provided 'Handle'.
--
-- @since 0.1.0.0
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
        -- Note that the release called below will return the buffer to the
        -- list of spares
  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
        -- Despite appearances, IORef operations here are not a race
        -- condition, since we're already inside the MVar lock
        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{-no flush-} Bool
True{-release-}
                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{-needs flush-} Bool
False{-don't release-} 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{-no flush-} Bool
True{-release-}
                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{-needs flush-} Bool
False{-don't release-} 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 () #-}

-- | Same as 'sayString', but data is sent to the provided 'Handle'.
--
-- @since 0.1.0.0
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 #-}

-- | 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 :: 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 #-}