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