{-# LANGUAGE CPP #-}

-- | Provides types for typical "IO" processes.
module Shrun.IO.Handle
  ( -- * Read handle result
    HandleResult,
    ReadHandleResult (..),

    -- * Reading
    readHandle,
    readHandleRaw,
    readAndUpdateRefFinal,
  )
where

import Data.ByteString qualified as BS
#if MIN_VERSION_base (4, 19, 0)
import Data.List qualified as L
#endif
import Effects.FileSystem.HandleReader
  ( MonadHandleReader (hIsClosed),
    hGetNonBlocking,
    hIsReadable,
  )
import Effects.Time (MonadTime (getMonotonicTime))
import GHC.Real (RealFrac (floor))
import Shrun.Configuration.Data.CommandLogging
  ( BufferLength,
    BufferTimeout,
  )
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.Prelude

-- Timestamp and actual read result.
type HandleResult = Tuple2 Double ReadHandleResult

-- | Result from reading a handle. The ordering is based on:
--
-- @
-- 'ReadNoData' < 'ReadErr' < 'ReadSuccess'
-- @
--
-- The 'Semigroup' instance is based on this ordering, taking the greatest
-- element. For identical constructors, the left argument is taken.
data ReadHandleResult
  = -- | Error encountered while trying to read a handle.
    ReadErr (NonEmpty UnlinedText)
  | -- | Successfully read data from the handle.
    ReadSuccess (NonEmpty UnlinedText)
  | -- | Error encountered while trying to read a handle, but also have
    -- a successful previous read.
    ReadErrSuccess (NonEmpty UnlinedText) (NonEmpty UnlinedText)
  | -- | Successfully read no data from the handle.
    ReadNoData
  deriving stock (ReadHandleResult -> ReadHandleResult -> Bool
(ReadHandleResult -> ReadHandleResult -> Bool)
-> (ReadHandleResult -> ReadHandleResult -> Bool)
-> Eq ReadHandleResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReadHandleResult -> ReadHandleResult -> Bool
== :: ReadHandleResult -> ReadHandleResult -> Bool
$c/= :: ReadHandleResult -> ReadHandleResult -> Bool
/= :: ReadHandleResult -> ReadHandleResult -> Bool
Eq, Int -> ReadHandleResult -> ShowS
[ReadHandleResult] -> ShowS
ReadHandleResult -> String
(Int -> ReadHandleResult -> ShowS)
-> (ReadHandleResult -> String)
-> ([ReadHandleResult] -> ShowS)
-> Show ReadHandleResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadHandleResult -> ShowS
showsPrec :: Int -> ReadHandleResult -> ShowS
$cshow :: ReadHandleResult -> String
show :: ReadHandleResult -> String
$cshowList :: [ReadHandleResult] -> ShowS
showList :: [ReadHandleResult] -> ShowS
Show)

instance Semigroup ReadHandleResult where
  ReadSuccess NonEmpty UnlinedText
ls <> :: ReadHandleResult -> ReadHandleResult -> ReadHandleResult
<> ReadSuccess NonEmpty UnlinedText
rs = NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (NonEmpty UnlinedText
ls NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
rs)
  ReadSuccess NonEmpty UnlinedText
ls <> ReadErrSuccess NonEmpty UnlinedText
re NonEmpty UnlinedText
rs = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess NonEmpty UnlinedText
re (NonEmpty UnlinedText
ls NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
rs)
  ReadSuccess NonEmpty UnlinedText
ls <> ReadErr NonEmpty UnlinedText
re = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess NonEmpty UnlinedText
re NonEmpty UnlinedText
ls
  ReadErrSuccess NonEmpty UnlinedText
le NonEmpty UnlinedText
ls <> ReadSuccess NonEmpty UnlinedText
rs = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess NonEmpty UnlinedText
le (NonEmpty UnlinedText
ls NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
rs)
  ReadErrSuccess NonEmpty UnlinedText
le NonEmpty UnlinedText
ls <> ReadErrSuccess NonEmpty UnlinedText
re NonEmpty UnlinedText
rs = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess (NonEmpty UnlinedText
le NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
re) (NonEmpty UnlinedText
ls NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
rs)
  ReadErrSuccess NonEmpty UnlinedText
le NonEmpty UnlinedText
ls <> ReadErr NonEmpty UnlinedText
re = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess (NonEmpty UnlinedText
le NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
re) NonEmpty UnlinedText
ls
  ReadErr NonEmpty UnlinedText
le <> ReadSuccess NonEmpty UnlinedText
rs = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess NonEmpty UnlinedText
le NonEmpty UnlinedText
rs
  ReadErr NonEmpty UnlinedText
le <> ReadErrSuccess NonEmpty UnlinedText
re NonEmpty UnlinedText
rs = NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess (NonEmpty UnlinedText
le NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
re) NonEmpty UnlinedText
rs
  ReadErr NonEmpty UnlinedText
le <> ReadErr NonEmpty UnlinedText
re = NonEmpty UnlinedText -> ReadHandleResult
ReadErr (NonEmpty UnlinedText
le NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> NonEmpty UnlinedText
re)
  ReadHandleResult
l <> ReadHandleResult
ReadNoData = ReadHandleResult
l
  ReadHandleResult
ReadNoData <> ReadHandleResult
r = ReadHandleResult
r

instance Monoid ReadHandleResult where
  mempty :: ReadHandleResult
mempty = ReadHandleResult
ReadNoData

-- NOTE: [Completed vs. Partial Reads]
--
-- readHandle implements "complete vs. partial read detection" for the purposes
-- of making the file output's prettier (i.e. formatting). What follows is an
-- explanation.
--
-- First, we define a _complete_ read as a read that is newline terminated.
-- Otherwise we have a _partial_ read. Notice that we could have multiple
-- complete reads (i.e. multiple newlines in the same read) and a possible
-- partial read, if the entire result does not end in a newline.
--
-- Second, readHandle only implements this strategy when it receives an IORef
-- to store the partial result i.e. if its first param is 'Just'. Otherwise,
-- if it is 'Nothing', we implement the normal strategy which just returns
-- exactly what it reads, up to blockSize bytes.
--
-- Before we get to the implementation strategy, let's briefly look at what
-- we did _not_ do.
--
-- 1. One strategy (and possibly the most natural) is to stop unconditionally
--    appending newlines in the file log formatting, and instead just send
--    what the handle gives us. This would automatically do what we want, so
--    why not?
--
--    Consider what happens if the underlying program does not send _any_
--    newlines (e.g. programs that overwrite the same line). We will end up
--    building a single extremely long line. For this to be reasonable, we'd
--    want to implement some sort of cutoff e.g. "if we haven't read a newline
--    in some time or some data size, insert one".
--
-- 2. We also make no effort to make this sensible with multiple commands.
--    Because we log everything to a single file, there is no sensible way
--    to perform this formatting with multiple commands. To make this actually
--    work we would need to log each command to its own file, which is
--    possible, but would be a very invasive change, possibly with a
--    complicated implementation / interface.
--
-- Onto the implementation.
--
-- When we encounter a partial read, we save it in an IORef. In general, when
-- reading the handle, we check this ref, and if it is non-empty, we prepend
-- it to the first read in the handle. We implement a threshold cutoff, whereby
-- we print it anyway, so that we do not build up a massive string in memory.

type BufferParams =
  ( Tuple4
      (IORef (Maybe UnlinedText)) -- Previous read
      BufferLength -- Buffer length threshold
      BufferTimeout -- Buffer timeout threshold
      (IORef Double) -- Current time
  )

-- | Attempts to read from the handle.
readHandle ::
  ( CanRead p,
    HasCallStack,
    MonadCatch m,
    MonadHandleReader m,
    MonadIORef m,
    MonadTime m
  ) =>
  Maybe BufferParams ->
  Int ->
  Handle p ->
  m (Tuple2 Double ReadHandleResult)
readHandle :: forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m,
 MonadIORef m, MonadTime m) =>
Maybe BufferParams
-> Int -> Handle p -> m (Double, ReadHandleResult)
readHandle Maybe BufferParams
mBufferParams Int
blockSize Handle p
handle = do
  Double
readTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  (ReadHandleResult -> (Double, ReadHandleResult))
-> m ReadHandleResult -> m (Double, ReadHandleResult)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double
readTime,) (m ReadHandleResult -> m (Double, ReadHandleResult))
-> m ReadHandleResult -> m (Double, ReadHandleResult)
forall a b. (a -> b) -> a -> b
$ Int -> Handle p -> m (Either (NonEmpty UnlinedText) ByteString)
forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m) =>
Int -> Handle p -> m (Either (NonEmpty UnlinedText) ByteString)
readHandleRaw Int
blockSize Handle p
handle m (Either (NonEmpty UnlinedText) ByteString)
-> (Either (NonEmpty UnlinedText) ByteString -> m ReadHandleResult)
-> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left NonEmpty UnlinedText
err ->
      -- If we encountered an error but are holding onto a previous log,
      -- let's print it too.
      m ReadHandleResult
-> Maybe BufferParams
-> (BufferParams -> m ReadHandleResult)
-> m ReadHandleResult
forall b a. b -> Maybe a -> (a -> b) -> b
onJust (ReadHandleResult -> m ReadHandleResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ReadHandleResult -> m ReadHandleResult)
-> ReadHandleResult -> m ReadHandleResult
forall a b. (a -> b) -> a -> b
$ NonEmpty UnlinedText -> ReadHandleResult
ReadErr NonEmpty UnlinedText
err) Maybe BufferParams
mBufferParams ((BufferParams -> m ReadHandleResult) -> m ReadHandleResult)
-> (BufferParams -> m ReadHandleResult) -> m ReadHandleResult
forall a b. (a -> b) -> a -> b
$ \(IORef (Maybe UnlinedText)
prevReadRef, BufferLength
_, BufferTimeout
_, IORef Double
_) ->
        IORef (Maybe UnlinedText) -> m (Maybe UnlinedText)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe UnlinedText)
prevReadRef m (Maybe UnlinedText)
-> (Maybe UnlinedText -> m ReadHandleResult) -> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe UnlinedText
Nothing -> ReadHandleResult -> m ReadHandleResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ReadHandleResult -> m ReadHandleResult)
-> ReadHandleResult -> m ReadHandleResult
forall a b. (a -> b) -> a -> b
$ NonEmpty UnlinedText -> ReadHandleResult
ReadErr NonEmpty UnlinedText
err
          Just UnlinedText
prevRead -> do
            IORef (Maybe UnlinedText) -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadIORef m) =>
IORef (Maybe a) -> m ()
resetPrevReadRef IORef (Maybe UnlinedText)
prevReadRef
            pure $ NonEmpty UnlinedText -> NonEmpty UnlinedText -> ReadHandleResult
ReadErrSuccess NonEmpty UnlinedText
err (UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne UnlinedText
prevRead)
    Right ByteString
bs -> case Maybe BufferParams
mBufferParams of
      Maybe BufferParams
Nothing -> ReadHandleResult -> m ReadHandleResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ReadHandleResult -> m ReadHandleResult)
-> ReadHandleResult -> m ReadHandleResult
forall a b. (a -> b) -> a -> b
$ case ByteString
bs of
        ByteString
"" -> ReadHandleResult
ReadNoData
        -- Empty case probably impossible, for the same reasons in
        -- NOTE: [Non-Empty BS Read].
        ByteString
cs -> case Text -> [UnlinedText]
ShrunText.fromText (ByteString -> Text
decodeUtf8Lenient ByteString
cs) of
          [] -> ReadHandleResult
ReadNoData
          (UnlinedText
x : [UnlinedText]
xs) -> NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (UnlinedText
x UnlinedText -> [UnlinedText] -> NonEmpty UnlinedText
forall a. a -> [a] -> NonEmpty a
:| [UnlinedText]
xs)
      Just BufferParams
bufferParams -> BufferParams -> ByteString -> m ReadHandleResult
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m, MonadTime m) =>
BufferParams -> ByteString -> m ReadHandleResult
readAndUpdateRef BufferParams
bufferParams ByteString
bs
{-# INLINEABLE readHandle #-}

-- | Attempts to read from the handle. Returns Left error or Right
-- success.
readHandleRaw ::
  ( CanRead p,
    HasCallStack,
    MonadCatch m,
    MonadHandleReader m
  ) =>
  Int ->
  Handle p ->
  m (Either (NonEmpty UnlinedText) ByteString)
readHandleRaw :: forall (p :: HandleMode) (m :: Type -> Type).
(CanRead p, HasCallStack, MonadCatch m, MonadHandleReader m) =>
Int -> Handle p -> m (Either (NonEmpty UnlinedText) ByteString)
readHandleRaw Int
blockSize Handle p
handle = do
  -- The "nothingIfReady" check and reading step both need to go in the try as
  -- the former can also throw.
  m (Either (NonEmpty UnlinedText) ByteString)
-> m (Either
        SomeException (Either (NonEmpty UnlinedText) ByteString))
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryMySync m (Either (NonEmpty UnlinedText) ByteString)
readHandle' m (Either SomeException (Either (NonEmpty UnlinedText) ByteString))
-> (Either SomeException (Either (NonEmpty UnlinedText) ByteString)
    -> Either (NonEmpty UnlinedText) ByteString)
-> m (Either (NonEmpty UnlinedText) ByteString)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    -- unsafeFromTextNE safe because input text is non-empty
    Left SomeException
ex -> NonEmpty UnlinedText -> Either (NonEmpty UnlinedText) ByteString
forall a b. a -> Either a b
Left (NonEmpty UnlinedText -> Either (NonEmpty UnlinedText) ByteString)
-> NonEmpty UnlinedText -> Either (NonEmpty UnlinedText) ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> NonEmpty UnlinedText
Text -> NonEmpty UnlinedText
ShrunText.unsafeFromTextNE (Text -> NonEmpty UnlinedText) -> Text -> NonEmpty UnlinedText
forall a b. (a -> b) -> a -> b
$ Text
"HandleException: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptiont SomeException
ex
    Right Either (NonEmpty UnlinedText) ByteString
x -> Either (NonEmpty UnlinedText) ByteString
x
  where
    readHandle' :: m (Either (NonEmpty UnlinedText) ByteString)
readHandle' =
      m (Maybe Text)
nothingIfReady m (Maybe Text)
-> (Maybe Text -> m (Either (NonEmpty UnlinedText) ByteString))
-> m (Either (NonEmpty UnlinedText) ByteString)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- unsafeFromTextNE safe because nothingIfReady always returns non-empty.
        Just Text
err -> Either (NonEmpty UnlinedText) ByteString
-> m (Either (NonEmpty UnlinedText) ByteString)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either (NonEmpty UnlinedText) ByteString
 -> m (Either (NonEmpty UnlinedText) ByteString))
-> Either (NonEmpty UnlinedText) ByteString
-> m (Either (NonEmpty UnlinedText) ByteString)
forall a b. (a -> b) -> a -> b
$ NonEmpty UnlinedText -> Either (NonEmpty UnlinedText) ByteString
forall a b. a -> Either a b
Left (HasCallStack => Text -> NonEmpty UnlinedText
Text -> NonEmpty UnlinedText
ShrunText.unsafeFromTextNE Text
err)
        Maybe Text
Nothing ->
          -- NOTE: [Blocking / Streaming output]
          --
          -- hGetNonBlocking is suboptimal because we might take
          -- multiple lines of output, hence log them on a single line, which
          -- is quite ugly. Something like hGetLine would be ideal, but try
          -- as we might we cannot get this to stream properly (logs are
          -- buffered until the process finishes). Thus we have settled on
          -- a workaround: Use the following non blocking call which streams
          -- properly, and manually split the lines ourselves. The block size
          -- should be large enough that we are not likely to cut off a line
          -- prematurely, but obviously this is best-effort.
          ByteString -> Either (NonEmpty UnlinedText) ByteString
forall a b. b -> Either a b
Right (ByteString -> Either (NonEmpty UnlinedText) ByteString)
-> m ByteString -> m (Either (NonEmpty UnlinedText) ByteString)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle p -> Int -> m ByteString
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> Int -> m ByteString
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> Int -> m ByteString
hGetNonBlocking Handle p
handle Int
blockSize

    nothingIfReady :: m (Maybe Text)
nothingIfReady = do
      -- NOTE: This somewhat torturous logic exists for a reason. We want to
      -- check several conditions before attempting to read from our handle,
      -- but we have to do this in a specific order as some of these boolean
      -- functions will throw exceptions under some circumstances, which we
      -- would like to avoid.
      --
      -- Note that this description comes from experience and reading the
      -- GHC source, so it may not be completely accurate.

      -- hIsClosed does not explicitly throw exceptions so it can be first.
      Bool
isClosed <- Handle p -> m Bool
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> m Bool
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> m Bool
hIsClosed Handle p
handle
      if Bool
isClosed
        then Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Handle closed"
        else do
          -- hIsReadable _does_ throw an exception if the the handle is closed or
          -- "semi-closed". Thus it should go after the hIsClosed check
          -- (GHC explicitly does not export an hSemiClosed).
          Bool
isReadable <- Handle p -> m Bool
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> m Bool
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> m Bool
hIsReadable Handle p
handle
          if Bool -> Bool
not Bool
isReadable
            then Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Handle is not readable"
            else Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
{-# INLINEABLE readHandleRaw #-}

-- NOTE: [EOF / blocking error] We would like to check hIsEOF (definitely
-- causes errors at the end) and probably hReady as well, but these both
-- block and I have not found a way to invoke them while also streaming
-- the process output (blocks until everything gets dumped at the end).

-- | General handler for combining reads with previous read data.
readAndUpdateRef ::
  forall m.
  ( HasCallStack,
    MonadIORef m,
    MonadTime m
  ) =>
  -- | Buffer params.
  BufferParams ->
  -- | Current read.
  ByteString ->
  -- | Result.
  m ReadHandleResult
readAndUpdateRef :: forall (m :: Type -> Type).
(HasCallStack, MonadIORef m, MonadTime m) =>
BufferParams -> ByteString -> m ReadHandleResult
readAndUpdateRef (IORef (Maybe UnlinedText)
prevReadRef, BufferLength
bufferLength, BufferTimeout
bufferTimeout, IORef Double
bufferWriteTimeRef) =
  m ReadHandleResult
-> (UnlinedText -> m ReadHandleResult)
-> (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult)
-> IORef (Maybe UnlinedText)
-> ByteString
-> m ReadHandleResult
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
m ReadHandleResult
-> (UnlinedText -> m ReadHandleResult)
-> (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult)
-> IORef (Maybe UnlinedText)
-> ByteString
-> m ReadHandleResult
readByteStringPrevHandler
    m ReadHandleResult
onNoData
    UnlinedText -> m ReadHandleResult
onPartialRead
    NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
onCompletedAndPartialRead
    IORef (Maybe UnlinedText)
prevReadRef
  where
    -- 1. No data: Send the prevRead if it exists and breaks the thresholds.
    onNoData :: m ReadHandleResult
    onNoData :: m ReadHandleResult
onNoData =
      IORef (Maybe UnlinedText) -> m (Maybe UnlinedText)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe UnlinedText)
prevReadRef
        m (Maybe UnlinedText)
-> (Maybe UnlinedText -> m ReadHandleResult) -> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe UnlinedText
Nothing -> ReadHandleResult -> m ReadHandleResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ReadHandleResult
ReadNoData
          Just UnlinedText
prevRead ->
            Maybe UnlinedText -> ReadHandleResult
maybeToReadHandleResult
              (Maybe UnlinedText -> ReadHandleResult)
-> m (Maybe UnlinedText) -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnlinedText -> m ()) -> UnlinedText -> m (Maybe UnlinedText)
prepareSendIfExceedsThresholds (m () -> UnlinedText -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ())) UnlinedText
prevRead

    -- 2. Partial read: Send the data if it breaks the thresholds, prepending
    -- prevRead if it exists.
    onPartialRead :: UnlinedText -> m ReadHandleResult
    onPartialRead :: UnlinedText -> m ReadHandleResult
onPartialRead UnlinedText
finalPartialRead =
      IORef (Maybe UnlinedText) -> m (Maybe UnlinedText)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe UnlinedText)
prevReadRef m (Maybe UnlinedText)
-> (Maybe UnlinedText -> m ReadHandleResult) -> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe UnlinedText
Nothing ->
          Maybe UnlinedText -> ReadHandleResult
maybeToReadHandleResult
            (Maybe UnlinedText -> ReadHandleResult)
-> m (Maybe UnlinedText) -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnlinedText -> m ()) -> UnlinedText -> m (Maybe UnlinedText)
prepareSendIfExceedsThresholds UnlinedText -> m ()
updateRef UnlinedText
finalPartialRead
        Just UnlinedText
prevRead -> do
          let combinedRead :: UnlinedText
combinedRead = UnlinedText
prevRead UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
finalPartialRead
          Maybe UnlinedText -> ReadHandleResult
maybeToReadHandleResult
            (Maybe UnlinedText -> ReadHandleResult)
-> m (Maybe UnlinedText) -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnlinedText -> m ()) -> UnlinedText -> m (Maybe UnlinedText)
prepareSendIfExceedsThresholds UnlinedText -> m ()
updateRef UnlinedText
combinedRead

    -- 3. Completed reads and partial read.
    onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
    onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
onCompletedAndPartialRead NonEmpty UnlinedText
completedReads UnlinedText
finalPartialRead = do
      NonEmpty UnlinedText
completedReads' <- IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
mPrependPrevRead IORef (Maybe UnlinedText)
prevReadRef NonEmpty UnlinedText
completedReads
      Maybe UnlinedText
finalPartialResult <- (UnlinedText -> m ()) -> UnlinedText -> m (Maybe UnlinedText)
prepareSendIfExceedsThresholds UnlinedText -> m ()
updateRef UnlinedText
finalPartialRead

      -- We also check that the partial read does not immediately exceed our
      -- thresholds. If it does, no sense storing it, send it now. This is
      -- also consistent with how onPartialRead works.
      let totalRead :: NonEmpty UnlinedText
totalRead =
            case Maybe UnlinedText
finalPartialResult of
              Maybe UnlinedText
Nothing -> NonEmpty UnlinedText
completedReads'
              Just UnlinedText
finalRead -> NonEmpty UnlinedText
completedReads' NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne UnlinedText
finalRead
      ReadHandleResult -> m ReadHandleResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ReadHandleResult -> m ReadHandleResult)
-> ReadHandleResult -> m ReadHandleResult
forall a b. (a -> b) -> a -> b
$ NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess NonEmpty UnlinedText
totalRead

    -- Turns this text into Just text iff the buffer thresholds are
    -- exceeded.
    prepareSendIfExceedsThresholds ::
      -- Callback for __not__ sending any data. This is used by
      -- onPartialRead to update its IORef, since the reference will be new.
      -- onNoData does not need it since the reference is already up-to-date.
      (UnlinedText -> m ()) ->
      -- The data to check.
      UnlinedText ->
      m (Maybe UnlinedText)
    prepareSendIfExceedsThresholds :: (UnlinedText -> m ()) -> UnlinedText -> m (Maybe UnlinedText)
prepareSendIfExceedsThresholds UnlinedText -> m ()
onNoSend UnlinedText
readData = do
      Bool
exceeds <- UnlinedText -> m Bool
exceedsThreshold UnlinedText
readData
      if Bool
exceeds
        then do
          m ()
resetPrevReadRef'
          Double
currTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
          IORef Double -> Double -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef' IORef Double
bufferWriteTimeRef Double
currTime
          pure $ UnlinedText -> Maybe UnlinedText
forall a. a -> Maybe a
Just UnlinedText
readData
        else do
          UnlinedText -> m ()
onNoSend UnlinedText
readData
          pure Maybe UnlinedText
forall a. Maybe a
Nothing

    exceedsThreshold :: UnlinedText -> m Bool
    exceedsThreshold :: UnlinedText -> m Bool
exceedsThreshold UnlinedText
t =
      if UnlinedText -> Bool
bufferExceedsLength UnlinedText
t
        then Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
        else m Bool
bufferExceedsTime

    bufferExceedsLength :: UnlinedText -> Bool
    bufferExceedsLength :: UnlinedText -> Bool
bufferExceedsLength UnlinedText
t = Int
tLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bufLen
      where
        tLen :: Int
tLen = UnlinedText -> Int
ShrunText.length UnlinedText
t
        bufLen :: Int
bufLen = BufferLength
bufferLength BufferLength -> Optic' An_Iso NoIx BufferLength Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx BufferLength Int
#unBufferLength

    bufferExceedsTime :: m Bool
    bufferExceedsTime :: m Bool
bufferExceedsTime = do
      Double
currTime <- m Double
forall (m :: Type -> Type). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
      Double
bufferWriteTime <- IORef Double -> m Double
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef Double
bufferWriteTimeRef

      let diffTime :: Natural
diffTime = Double -> Natural
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
currTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
bufferWriteTime)

      Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Natural
diffTime Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
bufTimeout
      where
        bufTimeout :: Natural
bufTimeout = BufferTimeout
bufferTimeout BufferTimeout
-> Optic' An_Iso NoIx BufferTimeout Natural -> Natural
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic An_Iso NoIx BufferTimeout BufferTimeout Timeout Timeout
#unBufferTimeout Optic An_Iso NoIx BufferTimeout BufferTimeout Timeout Timeout
-> Optic An_Iso NoIx Timeout Timeout Natural Natural
-> Optic' An_Iso NoIx BufferTimeout Natural
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_Iso NoIx Timeout Timeout Natural Natural
#unTimeout

    resetPrevReadRef' :: m ()
resetPrevReadRef' = IORef (Maybe UnlinedText) -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadIORef m) =>
IORef (Maybe a) -> m ()
resetPrevReadRef IORef (Maybe UnlinedText)
prevReadRef

    updateRef :: UnlinedText -> m ()
updateRef = IORef (Maybe UnlinedText) -> Maybe UnlinedText -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef' IORef (Maybe UnlinedText)
prevReadRef (Maybe UnlinedText -> m ())
-> (UnlinedText -> Maybe UnlinedText) -> UnlinedText -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UnlinedText -> Maybe UnlinedText
forall a. a -> Maybe a
Just

    maybeToReadHandleResult :: Maybe UnlinedText -> ReadHandleResult
maybeToReadHandleResult Maybe UnlinedText
Nothing = ReadHandleResult
ReadNoData
    maybeToReadHandleResult (Just UnlinedText
read) = NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne UnlinedText
read)
{-# INLINEABLE readAndUpdateRef #-}

-- | Intended for a final read that handles previous read data.
readAndUpdateRefFinal ::
  forall m.
  ( HasCallStack,
    MonadIORef m
  ) =>
  -- | Previous read.
  IORef (Maybe UnlinedText) ->
  -- | Current read.
  ByteString ->
  -- | Result.
  m ReadHandleResult
readAndUpdateRefFinal :: forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText) -> ByteString -> m ReadHandleResult
readAndUpdateRefFinal IORef (Maybe UnlinedText)
prevReadRef =
  m ReadHandleResult
-> (UnlinedText -> m ReadHandleResult)
-> (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult)
-> IORef (Maybe UnlinedText)
-> ByteString
-> m ReadHandleResult
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
m ReadHandleResult
-> (UnlinedText -> m ReadHandleResult)
-> (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult)
-> IORef (Maybe UnlinedText)
-> ByteString
-> m ReadHandleResult
readByteStringPrevHandler
    m ReadHandleResult
onNoData
    UnlinedText -> m ReadHandleResult
onPartialRead
    NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
onCompletedAndPartialRead
    IORef (Maybe UnlinedText)
prevReadRef
  where
    -- 1. No data: Final read, so send off prevRead if it exists, and reset the ref.
    onNoData :: m ReadHandleResult
    onNoData :: m ReadHandleResult
onNoData =
      IORef (Maybe UnlinedText) -> m (Maybe UnlinedText)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe UnlinedText)
prevReadRef m (Maybe UnlinedText)
-> (Maybe UnlinedText -> m ReadHandleResult) -> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe UnlinedText
Nothing -> m ()
resetPrevReadRef' m () -> ReadHandleResult -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> ReadHandleResult
ReadNoData
        Just UnlinedText
prevRead -> m ()
resetPrevReadRef' m () -> ReadHandleResult -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne UnlinedText
prevRead)

    -- 2. Partial read: Combine if prevRead exists, send off result.
    onPartialRead :: UnlinedText -> m ReadHandleResult
    onPartialRead :: UnlinedText -> m ReadHandleResult
onPartialRead UnlinedText
finalPartialRead = do
      IORef (Maybe UnlinedText) -> m (Maybe UnlinedText)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe UnlinedText)
prevReadRef m (Maybe UnlinedText)
-> (Maybe UnlinedText -> m ReadHandleResult) -> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe UnlinedText
Nothing -> m ()
resetPrevReadRef' m () -> ReadHandleResult -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne UnlinedText
finalPartialRead)
        Just UnlinedText
prevRead -> m ()
resetPrevReadRef' m () -> ReadHandleResult -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne (UnlinedText -> NonEmpty UnlinedText)
-> UnlinedText -> NonEmpty UnlinedText
forall a b. (a -> b) -> a -> b
$ UnlinedText
prevRead UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
finalPartialRead)

    -- 3. Completed and partial reads: Combine, send off result.
    onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
    onCompletedAndPartialRead :: NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
onCompletedAndPartialRead NonEmpty UnlinedText
completedReads UnlinedText
finalPartialRead = do
      NonEmpty UnlinedText
completedReads' <- IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
mPrependPrevRead IORef (Maybe UnlinedText)
prevReadRef NonEmpty UnlinedText
completedReads
      m ()
resetPrevReadRef'
      pure $ NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess (NonEmpty UnlinedText -> ReadHandleResult)
-> NonEmpty UnlinedText -> ReadHandleResult
forall a b. (a -> b) -> a -> b
$ NonEmpty UnlinedText
completedReads' NonEmpty UnlinedText
-> NonEmpty UnlinedText -> NonEmpty UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText -> NonEmpty UnlinedText
forall a. a -> NonEmpty a
ne UnlinedText
finalPartialRead

    resetPrevReadRef' :: m ()
resetPrevReadRef' = IORef (Maybe UnlinedText) -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadIORef m) =>
IORef (Maybe a) -> m ()
resetPrevReadRef IORef (Maybe UnlinedText)
prevReadRef
{-# INLINEABLE readAndUpdateRefFinal #-}

mPrependPrevRead ::
  (HasCallStack, MonadIORef m) =>
  IORef (Maybe UnlinedText) ->
  NonEmpty UnlinedText ->
  m (NonEmpty UnlinedText)
mPrependPrevRead :: forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
mPrependPrevRead IORef (Maybe UnlinedText)
ref cr :: NonEmpty UnlinedText
cr@(UnlinedText
r :| [UnlinedText]
rs) =
  IORef (Maybe UnlinedText) -> m (Maybe UnlinedText)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe UnlinedText)
ref m (Maybe UnlinedText)
-> (Maybe UnlinedText -> m (NonEmpty UnlinedText))
-> m (NonEmpty UnlinedText)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe UnlinedText
Nothing -> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NonEmpty UnlinedText
cr
    Just UnlinedText
prevRead -> m ()
resetPrevReadRef' m () -> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> UnlinedText
prevRead UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
r UnlinedText -> [UnlinedText] -> NonEmpty UnlinedText
forall a. a -> [a] -> NonEmpty a
:| [UnlinedText]
rs
  where
    resetPrevReadRef' :: m ()
resetPrevReadRef' = IORef (Maybe UnlinedText) -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadIORef m) =>
IORef (Maybe a) -> m ()
resetPrevReadRef IORef (Maybe UnlinedText)
ref
{-# INLINEABLE mPrependPrevRead #-}

-- | Helper for reading a bytestring and handling a previous, partial read.
readByteStringPrevHandler ::
  forall m.
  ( HasCallStack,
    MonadIORef m
  ) =>
  -- | Callback for no data.
  m ReadHandleResult ->
  -- | Callback for a partial, final read.
  (UnlinedText -> m ReadHandleResult) ->
  -- | Callback for completed reads _and_ a partial, final read.
  (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult) ->
  -- | Reference that stores the previous, partial read.
  IORef (Maybe UnlinedText) ->
  -- | The bytestring for the current read.
  ByteString ->
  m ReadHandleResult
readByteStringPrevHandler :: forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
m ReadHandleResult
-> (UnlinedText -> m ReadHandleResult)
-> (NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult)
-> IORef (Maybe UnlinedText)
-> ByteString
-> m ReadHandleResult
readByteStringPrevHandler
  m ReadHandleResult
onNoData
  UnlinedText -> m ReadHandleResult
onPartialRead
  NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
onCompletedAndPartialRead
  IORef (Maybe UnlinedText)
prevReadRef
  ByteString
bs = case ByteString -> ([UnlinedText], Maybe UnlinedText)
readByteString ByteString
bs of
    ([], Maybe UnlinedText
Nothing) -> m ReadHandleResult
onNoData
    -- This case is always handled the same: Prepend the prevRead if it
    -- exists, and send all.
    (UnlinedText
c : [UnlinedText]
cs, Maybe UnlinedText
Nothing) -> do
      NonEmpty UnlinedText
completedReads <- IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
forall (m :: Type -> Type).
(HasCallStack, MonadIORef m) =>
IORef (Maybe UnlinedText)
-> NonEmpty UnlinedText -> m (NonEmpty UnlinedText)
mPrependPrevRead IORef (Maybe UnlinedText)
prevReadRef (UnlinedText
c UnlinedText -> [UnlinedText] -> NonEmpty UnlinedText
forall a. a -> [a] -> NonEmpty a
:| [UnlinedText]
cs)
      pure $ NonEmpty UnlinedText -> ReadHandleResult
ReadSuccess NonEmpty UnlinedText
completedReads
    ([], Just UnlinedText
finalPartialRead) -> UnlinedText -> m ReadHandleResult
onPartialRead UnlinedText
finalPartialRead
    (UnlinedText
c : [UnlinedText]
cs, Just UnlinedText
finalPartialRead) ->
      NonEmpty UnlinedText -> UnlinedText -> m ReadHandleResult
onCompletedAndPartialRead (UnlinedText
c UnlinedText -> [UnlinedText] -> NonEmpty UnlinedText
forall a. a -> [a] -> NonEmpty a
:| [UnlinedText]
cs) UnlinedText
finalPartialRead
{-# INLINEABLE readByteStringPrevHandler #-}

-- | Reads a bytestring, distinguishing between _complete_ and _partial_
-- reads. A bytestring is considered _complete_ iff it is terminated with a
-- newline. Otherwise it is _partial_.
--
-- The tuple's left element contains all completed reads. The right element
-- is the final, partial read, if it exists.
readByteString :: ByteString -> Tuple2 (List UnlinedText) (Maybe UnlinedText)
readByteString :: ByteString -> ([UnlinedText], Maybe UnlinedText)
readByteString ByteString
bs = case ByteString -> Maybe (ByteString, Word8)
BS.unsnoc ByteString
bs of
  -- 1. Empty: No output
  Maybe (ByteString, Word8)
Nothing -> ([], Maybe UnlinedText
forall a. Maybe a
Nothing)
  -- 2. Non-empty, ends with a newline: This means all reads end with a
  --    newline i.e. are complete.
  --
  -- NOTE: [Non-Empty BS Read]
  --
  -- Note that returning an empty list is __probably__ impossible here, since
  -- unsnoc has already proven that bs is non-empty, and T.lines
  -- (called by decodeRead) only gives an empty string when the input is empty.
  -- So the only possibly way this is empty is if decodeUtf8Lenient somehow
  -- turns non-empty bs into empty text. Probably impossible, but we have this
  -- check since it's better than a runtime error.
  Just (ByteString
_, Word8
10) -> (ByteString -> [UnlinedText]
decodeRead ByteString
bs, Maybe UnlinedText
forall a. Maybe a
Nothing)
  -- 3. Non-empty, does not end with a newline: This means the last (and
  --    possibly only) read is partial.
  --
  -- unsnoc will separate the (zero or more) completed read(s) from the final
  -- partial read, which is what we want:
  --
  --     List UnlinedText -> Maybe (List UnlinedText, UnlinedText)
  --
  -- sequenceA will then swap the effects so that we always return the
  -- completed reads(s) and possibly empty final partial read:
  --
  --     Maybe (List UnlinedText, UnlinedText) -> (List UnlinedText, Maybe UnlinedText)
  --
  -- Strictly speaking, the final partial read should always exist, since we
  -- proved the string ends in a non-newline with the case analysis i.e. this
  -- should always return (completed, Just partial).
  --
  -- Unfortunately we cannot prove this to the type system at the moment,
  -- since we need to keep the bytestring together for decoding (hence cannot
  -- use the case-analysis evidence).
  Just (ByteString
_, Word8
_) -> Maybe ([UnlinedText], UnlinedText)
-> ([UnlinedText], Maybe UnlinedText)
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: Type -> Type) a.
Applicative f =>
Maybe (f a) -> f (Maybe a)
sequenceA (Maybe ([UnlinedText], UnlinedText)
 -> ([UnlinedText], Maybe UnlinedText))
-> Maybe ([UnlinedText], UnlinedText)
-> ([UnlinedText], Maybe UnlinedText)
forall a b. (a -> b) -> a -> b
$ [UnlinedText] -> Maybe ([UnlinedText], UnlinedText)
forall a. [a] -> Maybe ([a], a)
unsnoc ([UnlinedText] -> Maybe ([UnlinedText], UnlinedText))
-> [UnlinedText] -> Maybe ([UnlinedText], UnlinedText)
forall a b. (a -> b) -> a -> b
$ ByteString -> [UnlinedText]
decodeRead ByteString
bs
  where
    decodeRead :: ByteString -> [UnlinedText]
decodeRead = Text -> [UnlinedText]
ShrunText.fromText (Text -> [UnlinedText])
-> (ByteString -> Text) -> ByteString -> [UnlinedText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
decodeUtf8Lenient

resetPrevReadRef :: (HasCallStack, MonadIORef m) => IORef (Maybe a) -> m ()
resetPrevReadRef :: forall (m :: Type -> Type) a.
(HasCallStack, MonadIORef m) =>
IORef (Maybe a) -> m ()
resetPrevReadRef IORef (Maybe a)
prevReadRef = IORef (Maybe a) -> Maybe a -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef' IORef (Maybe a)
prevReadRef Maybe a
forall a. Maybe a
Nothing
{-# INLINEABLE resetPrevReadRef #-}

-- TODO: Remove once we are past GHC 9.6
unsnoc :: List a -> Maybe (List a, a)

#if MIN_VERSION_base (4, 19, 0)

unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc = [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
L.unsnoc

#else

-- The lazy pattern ~(a, b) is important to be productive on infinite lists
-- and not to be prone to stack overflows.
-- Expressing the recursion via 'foldr' provides for list fusion.
unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
{-# INLINEABLE unsnoc #-}

#endif

ne :: a -> NonEmpty a
ne :: forall a. a -> NonEmpty a
ne a
x = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []