module Codec.Borsh.Incremental.Monad (
    -- * Definition
    Incr(..)
  , runIncr
    -- * Operations supported by the monad
  , liftIncr
  , needChunk
  , decodeFail
    -- * (Partial) results
  , IDecode(..)
  , DeserialiseFailure(..)
  , runIDecode
  ) where

import Control.Monad
import Control.Monad.ST
import Control.Exception

import qualified Data.ByteString      as S
import qualified Data.ByteString.Lazy as L

import Codec.Borsh.Incremental.Located

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Monad for incremental decoding
--
-- Think of 'Incr' as the monad we use for processing the full input, whereas
-- 'Decoder' is the monad used for processing a single chunk of the input.
newtype Incr s a = Incr {
      forall s a.
Incr s a
-> forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r)
getIncr :: forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r)
    }

runIncr :: Incr s (LocatedChunk, a) -> ST s (IDecode s a)
runIncr :: forall s a. Incr s (LocatedChunk, a) -> ST s (IDecode s a)
runIncr (Incr forall r.
((LocatedChunk, a) -> ST s (IDecode s r)) -> ST s (IDecode s r)
f) = forall r.
((LocatedChunk, a) -> ST s (IDecode s r)) -> ST s (IDecode s r)
f forall a b. (a -> b) -> a -> b
$ \(LocatedChunk
chunk, a
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. LocatedChunk -> a -> IDecode s a
IDecodeDone LocatedChunk
chunk a
x

{-------------------------------------------------------------------------------
  Monad instance
-------------------------------------------------------------------------------}

instance Functor (Incr s) where
  fmap :: forall a b. (a -> b) -> Incr s a -> Incr s b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (Incr s) where
  pure :: forall a. a -> Incr s a
pure a
x = forall s a.
(forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r))
-> Incr s a
Incr (forall a b. (a -> b) -> a -> b
$ a
x)
  <*> :: forall a b. Incr s (a -> b) -> Incr s a -> Incr s b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (Incr s) where
  return :: forall a. a -> Incr s a
return  = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Incr s a
m >>= :: forall a b. Incr s a -> (a -> Incr s b) -> Incr s b
>>= a -> Incr s b
f = forall s a.
(forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r))
-> Incr s a
Incr forall a b. (a -> b) -> a -> b
$ \b -> ST s (IDecode s r)
k -> forall s a.
Incr s a
-> forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r)
getIncr Incr s a
m forall a b. (a -> b) -> a -> b
$ \a
x -> forall s a.
Incr s a
-> forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r)
getIncr (a -> Incr s b
f a
x) b -> ST s (IDecode s r)
k

{-------------------------------------------------------------------------------
  Operations supported by the monad
-------------------------------------------------------------------------------}

liftIncr :: ST s a -> Incr s a
liftIncr :: forall s a. ST s a -> Incr s a
liftIncr ST s a
action = forall s a.
(forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r))
-> Incr s a
Incr (ST s a
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)

needChunk :: Incr s (Maybe S.ByteString)
needChunk :: forall s. Incr s (Maybe ByteString)
needChunk = forall s a.
(forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r))
-> Incr s a
Incr forall a b. (a -> b) -> a -> b
$ \Maybe ByteString -> ST s (IDecode s r)
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. (Maybe ByteString -> ST s (IDecode s a)) -> IDecode s a
IDecodePartial forall a b. (a -> b) -> a -> b
$ \Maybe ByteString
mbs -> Maybe ByteString -> ST s (IDecode s r)
k Maybe ByteString
mbs

decodeFail :: LocatedChunk -> String -> Incr s a
decodeFail :: forall s a. LocatedChunk -> String -> Incr s a
decodeFail chunk :: LocatedChunk
chunk@(L ByteString
_ ByteOffset
off) String
e = forall s a.
(forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r))
-> Incr s a
Incr forall a b. (a -> b) -> a -> b
$ \a -> ST s (IDecode s r)
_ ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a. LocatedChunk -> DeserialiseFailure -> IDecode s a
IDecodeFail LocatedChunk
chunk (ByteOffset -> String -> DeserialiseFailure
DeserialiseFailure ByteOffset
off String
e)

{-------------------------------------------------------------------------------
  (Partial) results
-------------------------------------------------------------------------------}

data IDecode s a =
    IDecodePartial (Maybe S.ByteString -> ST s (IDecode s a))
  | IDecodeDone !LocatedChunk a
  | IDecodeFail !LocatedChunk DeserialiseFailure

-- | Error type for deserialisation.
data DeserialiseFailure =
    DeserialiseFailure
      ByteOffset -- ^ The position of the decoder when the failure occurred
      String     -- ^ Message explaining the failure
  deriving stock (DeserialiseFailure -> DeserialiseFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeserialiseFailure -> DeserialiseFailure -> Bool
$c/= :: DeserialiseFailure -> DeserialiseFailure -> Bool
== :: DeserialiseFailure -> DeserialiseFailure -> Bool
$c== :: DeserialiseFailure -> DeserialiseFailure -> Bool
Eq, Int -> DeserialiseFailure -> ShowS
[DeserialiseFailure] -> ShowS
DeserialiseFailure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeserialiseFailure] -> ShowS
$cshowList :: [DeserialiseFailure] -> ShowS
show :: DeserialiseFailure -> String
$cshow :: DeserialiseFailure -> String
showsPrec :: Int -> DeserialiseFailure -> ShowS
$cshowsPrec :: Int -> DeserialiseFailure -> ShowS
Show)
  deriving anyclass (Show DeserialiseFailure
Typeable DeserialiseFailure
SomeException -> Maybe DeserialiseFailure
DeserialiseFailure -> String
DeserialiseFailure -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: DeserialiseFailure -> String
$cdisplayException :: DeserialiseFailure -> String
fromException :: SomeException -> Maybe DeserialiseFailure
$cfromException :: SomeException -> Maybe DeserialiseFailure
toException :: DeserialiseFailure -> SomeException
$ctoException :: DeserialiseFailure -> SomeException
Exception)

runIDecode ::
     (forall s. ST s (IDecode s a))
  -> L.ByteString
  -> Either DeserialiseFailure (L.ByteString, ByteOffset, a)
runIDecode :: forall a.
(forall s. ST s (IDecode s a))
-> ByteString
-> Either DeserialiseFailure (ByteString, ByteOffset, a)
runIDecode forall s. ST s (IDecode s a)
d ByteString
lbs =
    forall a. (forall s. ST s a) -> a
runST (forall s a.
[ByteString]
-> IDecode s a
-> ST s (Either DeserialiseFailure (ByteString, ByteOffset, a))
go (ByteString -> [ByteString]
L.toChunks ByteString
lbs) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. ST s (IDecode s a)
d)
  where
    go :: [S.ByteString]
       -> IDecode s a
       -> ST s (Either DeserialiseFailure (L.ByteString, ByteOffset, a))
    go :: forall s a.
[ByteString]
-> IDecode s a
-> ST s (Either DeserialiseFailure (ByteString, ByteOffset, a))
go [ByteString]
chunks = \case
        IDecodeFail LocatedChunk
_ DeserialiseFailure
err ->
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left DeserialiseFailure
err)
        IDecodeDone (L ByteString
bs ByteOffset
off) a
x ->
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ([ByteString] -> ByteString
L.fromChunks forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> [ByteString]
prepend ByteString
bs [ByteString]
chunks, ByteOffset
off, a
x))
        IDecodePartial Maybe ByteString -> ST s (IDecode s a)
k ->
          case [ByteString]
chunks of
            []         -> Maybe ByteString -> ST s (IDecode s a)
k forall a. Maybe a
Nothing   forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s a.
[ByteString]
-> IDecode s a
-> ST s (Either DeserialiseFailure (ByteString, ByteOffset, a))
go []
            ByteString
bs:[ByteString]
chunks' -> Maybe ByteString -> ST s (IDecode s a)
k (forall a. a -> Maybe a
Just ByteString
bs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s a.
[ByteString]
-> IDecode s a
-> ST s (Either DeserialiseFailure (ByteString, ByteOffset, a))
go [ByteString]
chunks'

    prepend :: S.ByteString -> [S.ByteString] -> [S.ByteString]
    prepend :: ByteString -> [ByteString] -> [ByteString]
prepend ByteString
bs [ByteString]
bss
      | ByteString -> Bool
S.null ByteString
bs = [ByteString]
bss
      | Bool
otherwise = ByteString
bs forall a. a -> [a] -> [a]
: [ByteString]
bss