{-# LANGUAGE Rank2Types #-}

module Data.Binary.Machine
  ( -- * Get
    processGet,
    processDecoder,
    processGetL,
    stackGet,
    streamGet,
    streamGetL,

    -- * Put
    processPut,

    -- * Types
    DecodingError (..),
  )
where

import Data.Binary.Get (ByteOffset, Decoder (..), Get, pushChunk, runGetIncremental)
import Data.Binary.Put (Put, runPut)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy
import Data.Machine (Is (Refl), MachineT (..), Plan, Process, ProcessT, Step (Await, Yield), auto, echo, repeatedly, stopped, yield)
import Data.Machine.Stack (Stack (..), pop, push, stack)

processPut :: Monad m => (a -> Put) -> ProcessT m a ByteString
processPut :: (a -> Put) -> ProcessT m a ByteString
processPut a -> Put
f = (a -> ByteString) -> Process a ByteString
forall (k :: * -> * -> *) a b. Automaton k => k a b -> Process a b
auto ((a -> ByteString) -> Process a ByteString)
-> (a -> ByteString) -> Process a ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Lazy.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
f

processGet :: Monad m => Get a -> ProcessT m ByteString (Either String a)
processGet :: Get a -> ProcessT m ByteString (Either String a)
processGet Get a
getA = Decoder a -> ProcessT m ByteString (Either String a)
forall (m :: * -> *) a.
Monad m =>
Decoder a -> ProcessT m ByteString (Either String a)
processDecoder (Get a -> Decoder a
forall a. Get a -> Decoder a
runGetIncremental Get a
getA)

processDecoder :: Monad m => Decoder a -> ProcessT m ByteString (Either String a)
processDecoder :: Decoder a -> ProcessT m ByteString (Either String a)
processDecoder Decoder a
decA = Decoder a
-> ProcessT m ByteString (Either String a)
-> ProcessT m ByteString (Either String a)
forall (m :: * -> *) a.
Monad m =>
Decoder a
-> ProcessT m ByteString (Either String a)
-> ProcessT m ByteString (Either String a)
processDecoder' Decoder a
decA ProcessT m ByteString (Either String a)
forall (k :: * -> *) b. Machine k b
stopped

processDecoder' :: Monad m => Decoder a -> ProcessT m ByteString (Either String a) -> ProcessT m ByteString (Either String a)
processDecoder' :: Decoder a
-> ProcessT m ByteString (Either String a)
-> ProcessT m ByteString (Either String a)
processDecoder' Decoder a
decA ProcessT m ByteString (Either String a)
r = m (Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a)))
-> ProcessT m ByteString (Either String a)
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (m (Step
      (Is ByteString)
      (Either String a)
      (ProcessT m ByteString (Either String a)))
 -> ProcessT m ByteString (Either String a))
-> (Step
      (Is ByteString)
      (Either String a)
      (ProcessT m ByteString (Either String a))
    -> m (Step
            (Is ByteString)
            (Either String a)
            (ProcessT m ByteString (Either String a))))
-> Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a))
-> ProcessT m ByteString (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step
  (Is ByteString)
  (Either String a)
  (ProcessT m ByteString (Either String a))
-> m (Step
        (Is ByteString)
        (Either String a)
        (ProcessT m ByteString (Either String a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   (Is ByteString)
   (Either String a)
   (ProcessT m ByteString (Either String a))
 -> ProcessT m ByteString (Either String a))
-> Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a))
-> ProcessT m ByteString (Either String a)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ProcessT m ByteString (Either String a))
-> Is ByteString ByteString
-> ProcessT m ByteString (Either String a)
-> Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a))
forall (k :: * -> *) o r t. (t -> r) -> k t -> r -> Step k o r
Await ByteString -> ProcessT m ByteString (Either String a)
f Is ByteString ByteString
forall a. Is a a
Refl ProcessT m ByteString (Either String a)
forall (k :: * -> *) b. Machine k b
stopped
  where
    f :: ByteString -> ProcessT m ByteString (Either String a)
f ByteString
xs = case Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
pushChunk Decoder a
decA ByteString
xs of
      Fail ByteString
_ ByteOffset
_ String
e -> Either String a -> ProcessT m ByteString (Either String a)
yield' (Either String a -> ProcessT m ByteString (Either String a))
-> Either String a -> ProcessT m ByteString (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left String
e
      Done ByteString
_ ByteOffset
_ a
a -> Either String a -> ProcessT m ByteString (Either String a)
yield' (Either String a -> ProcessT m ByteString (Either String a))
-> Either String a -> ProcessT m ByteString (Either String a)
forall a b. (a -> b) -> a -> b
$ a -> Either String a
forall a b. b -> Either a b
Right a
a
      Decoder a
decA' -> Decoder a
-> ProcessT m ByteString (Either String a)
-> ProcessT m ByteString (Either String a)
forall (m :: * -> *) a.
Monad m =>
Decoder a
-> ProcessT m ByteString (Either String a)
-> ProcessT m ByteString (Either String a)
processDecoder' Decoder a
decA' ProcessT m ByteString (Either String a)
r
    yield' :: Either String a -> ProcessT m ByteString (Either String a)
yield' Either String a
ea = m (Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a)))
-> ProcessT m ByteString (Either String a)
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (m (Step
      (Is ByteString)
      (Either String a)
      (ProcessT m ByteString (Either String a)))
 -> ProcessT m ByteString (Either String a))
-> (Step
      (Is ByteString)
      (Either String a)
      (ProcessT m ByteString (Either String a))
    -> m (Step
            (Is ByteString)
            (Either String a)
            (ProcessT m ByteString (Either String a))))
-> Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a))
-> ProcessT m ByteString (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step
  (Is ByteString)
  (Either String a)
  (ProcessT m ByteString (Either String a))
-> m (Step
        (Is ByteString)
        (Either String a)
        (ProcessT m ByteString (Either String a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
   (Is ByteString)
   (Either String a)
   (ProcessT m ByteString (Either String a))
 -> ProcessT m ByteString (Either String a))
-> Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a))
-> ProcessT m ByteString (Either String a)
forall a b. (a -> b) -> a -> b
$ Either String a
-> ProcessT m ByteString (Either String a)
-> Step
     (Is ByteString)
     (Either String a)
     (ProcessT m ByteString (Either String a))
forall (k :: * -> *) o r. o -> r -> Step k o r
Yield Either String a
ea ProcessT m ByteString (Either String a)
r

--------------------------------------------------------------------------

-- |
-- Construct a Plan that run a 'Get' until it fails or it return a parsed result.
-- This plan automatically manages the pushback of unused input.
--
-- You can use this function to construct a machine and run a 'Get' on the
-- provided input.
-- With 'stack' you can convert the created machine to a normal machine
--
-- @
-- -- construct the machine
-- myMachine :: 'Machine' ('Stack' ByteString) (Either DecodingError Word8)
-- myMachine = 'construct' $ 'stackGet' 'getWord8'
--
-- -- run the machine
-- run $ 'stack' ('source' ["abc", "d", "efgh"]) myMachine
-- @
--
-- You can combine machines created in this way with the facilities provided by
-- the machines package.
--
-- @
-- --run m2 after m1
-- myMachine = m1 <> m2
--   where
--     m1 = construct $ stackGet (getByteString 5)
--     m2 = construct $ stackGet (getByteString 1)
--
-- run $ stack (source ["abc", "d", "efgh"]) myMachine
-- > [Right "abcde",Right "f"]
-- @
stackGet :: Get a -> Plan (Stack ByteString) (Either DecodingError a) ()
stackGet :: Get a -> Plan (Stack ByteString) (Either DecodingError a) ()
stackGet Get a
getA = Get a
-> Plan
     (Stack ByteString)
     (Either DecodingError a)
     (Either DecodingError (ByteOffset, a))
forall a o.
Get a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_getPlan Get a
getA PlanT
  (Stack ByteString)
  (Either DecodingError a)
  m
  (Either DecodingError (ByteOffset, a))
-> (Either DecodingError (ByteOffset, a)
    -> PlanT
         (Stack ByteString)
         (Either DecodingError a)
         m
         (Either DecodingError a))
-> PlanT
     (Stack ByteString)
     (Either DecodingError a)
     m
     (Either DecodingError a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either DecodingError a
-> PlanT
     (Stack ByteString)
     (Either DecodingError a)
     m
     (Either DecodingError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodingError a
 -> PlanT
      (Stack ByteString)
      (Either DecodingError a)
      m
      (Either DecodingError a))
-> (Either DecodingError (ByteOffset, a) -> Either DecodingError a)
-> Either DecodingError (ByteOffset, a)
-> PlanT
     (Stack ByteString)
     (Either DecodingError a)
     m
     (Either DecodingError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteOffset, a) -> a)
-> Either DecodingError (ByteOffset, a) -> Either DecodingError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteOffset, a) -> a
forall a b. (a, b) -> b
snd PlanT
  (Stack ByteString)
  (Either DecodingError a)
  m
  (Either DecodingError a)
-> (Either DecodingError a
    -> PlanT (Stack ByteString) (Either DecodingError a) m ())
-> PlanT (Stack ByteString) (Either DecodingError a) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either DecodingError a
-> PlanT (Stack ByteString) (Either DecodingError a) m ()
forall o (k :: * -> *). o -> Plan k o ()
yield

-- | Same as 'stackGet' with additional information about the number
-- of bytes consumed by the 'Get'
processGetL :: Get a -> Plan (Stack ByteString) (Either DecodingError (ByteOffset, a)) ()
processGetL :: Get a
-> Plan
     (Stack ByteString) (Either DecodingError (ByteOffset, a)) ()
processGetL Get a
getA = Get a
-> Plan
     (Stack ByteString)
     (Either DecodingError (ByteOffset, a))
     (Either DecodingError (ByteOffset, a))
forall a o.
Get a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_getPlan Get a
getA PlanT
  (Stack ByteString)
  (Either DecodingError (ByteOffset, a))
  m
  (Either DecodingError (ByteOffset, a))
-> (Either DecodingError (ByteOffset, a)
    -> PlanT
         (Stack ByteString) (Either DecodingError (ByteOffset, a)) m ())
-> PlanT
     (Stack ByteString) (Either DecodingError (ByteOffset, a)) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either DecodingError (ByteOffset, a)
-> PlanT
     (Stack ByteString) (Either DecodingError (ByteOffset, a)) m ()
forall o (k :: * -> *). o -> Plan k o ()
yield

-- | Run a 'Get' multiple times and stream its results
--
-- @
-- run $ source ["abc", "d", "efgh"] ~> streamGet (getByteString 2)
-- > [Right "ab",Right "cd",Right "ef",Right "gh"]
-- @
streamGet :: Get a -> Process ByteString (Either DecodingError a)
streamGet :: Get a -> Process ByteString (Either DecodingError a)
streamGet Get a
getA = MachineT m (Is ByteString) ByteString
-> MachineT m (Stack ByteString) (Either DecodingError a)
-> MachineT m (Is ByteString) (Either DecodingError a)
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
stack MachineT m (Is ByteString) ByteString
forall a. Process a a
echo (PlanT (Stack ByteString) (Either DecodingError a) m ()
-> MachineT m (Stack ByteString) (Either DecodingError a)
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT (Stack ByteString) (Either DecodingError a) m ()
 -> MachineT m (Stack ByteString) (Either DecodingError a))
-> PlanT (Stack ByteString) (Either DecodingError a) m ()
-> MachineT m (Stack ByteString) (Either DecodingError a)
forall a b. (a -> b) -> a -> b
$ Get a -> Plan (Stack ByteString) (Either DecodingError a) ()
forall a.
Get a -> Plan (Stack ByteString) (Either DecodingError a) ()
stackGet Get a
getA)

-- | Same as 'streamGet' with additional information about the number
-- of bytes consumed by the 'Get'
streamGetL :: Get a -> Process ByteString (Either DecodingError (ByteOffset, a))
streamGetL :: Get a -> Process ByteString (Either DecodingError (ByteOffset, a))
streamGetL Get a
getA = MachineT m (Is ByteString) ByteString
-> MachineT
     m (Stack ByteString) (Either DecodingError (ByteOffset, a))
-> MachineT
     m (Is ByteString) (Either DecodingError (ByteOffset, a))
forall (m :: * -> *) (k :: * -> *) a o.
Monad m =>
MachineT m k a -> MachineT m (Stack a) o -> MachineT m k o
stack MachineT m (Is ByteString) ByteString
forall a. Process a a
echo (PlanT
  (Stack ByteString) (Either DecodingError (ByteOffset, a)) m ()
-> MachineT
     m (Stack ByteString) (Either DecodingError (ByteOffset, a))
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
repeatedly (PlanT
   (Stack ByteString) (Either DecodingError (ByteOffset, a)) m ()
 -> MachineT
      m (Stack ByteString) (Either DecodingError (ByteOffset, a)))
-> PlanT
     (Stack ByteString) (Either DecodingError (ByteOffset, a)) m ()
-> MachineT
     m (Stack ByteString) (Either DecodingError (ByteOffset, a))
forall a b. (a -> b) -> a -> b
$ Get a
-> Plan
     (Stack ByteString) (Either DecodingError (ByteOffset, a)) ()
forall a.
Get a
-> Plan
     (Stack ByteString) (Either DecodingError (ByteOffset, a)) ()
processGetL Get a
getA)

-- | A 'Get' decoding error.
data DecodingError = DecodingError
  { -- | Number of bytes consumed before the error
    DecodingError -> ByteOffset
deConsumed :: {-# UNPACK #-} !ByteOffset,
    -- | Error message
    DecodingError -> String
deMessage :: !String
  }
  deriving (Int -> DecodingError -> ShowS
[DecodingError] -> ShowS
DecodingError -> String
(Int -> DecodingError -> ShowS)
-> (DecodingError -> String)
-> ([DecodingError] -> ShowS)
-> Show DecodingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodingError] -> ShowS
$cshowList :: [DecodingError] -> ShowS
show :: DecodingError -> String
$cshow :: DecodingError -> String
showsPrec :: Int -> DecodingError -> ShowS
$cshowsPrec :: Int -> DecodingError -> ShowS
Show, ReadPrec [DecodingError]
ReadPrec DecodingError
Int -> ReadS DecodingError
ReadS [DecodingError]
(Int -> ReadS DecodingError)
-> ReadS [DecodingError]
-> ReadPrec DecodingError
-> ReadPrec [DecodingError]
-> Read DecodingError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DecodingError]
$creadListPrec :: ReadPrec [DecodingError]
readPrec :: ReadPrec DecodingError
$creadPrec :: ReadPrec DecodingError
readList :: ReadS [DecodingError]
$creadList :: ReadS [DecodingError]
readsPrec :: Int -> ReadS DecodingError
$creadsPrec :: Int -> ReadS DecodingError
Read, DecodingError -> DecodingError -> Bool
(DecodingError -> DecodingError -> Bool)
-> (DecodingError -> DecodingError -> Bool) -> Eq DecodingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodingError -> DecodingError -> Bool
$c/= :: DecodingError -> DecodingError -> Bool
== :: DecodingError -> DecodingError -> Bool
$c== :: DecodingError -> DecodingError -> Bool
Eq)

--------------------------------------------------------------------------
-- Internals
_decoderPlan :: Decoder a -> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_decoderPlan :: Decoder a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_decoderPlan Decoder a
decA = do
  ByteString
xs <- PlanT (Stack ByteString) o m ByteString
forall a b. Plan (Stack a) b a
pop
  case Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
pushChunk Decoder a
decA ByteString
xs of
    Fail ByteString
leftovers ByteOffset
consumed String
e -> ByteString -> Plan (Stack ByteString) o ()
forall a b. a -> Plan (Stack a) b ()
push ByteString
leftovers PlanT (Stack ByteString) o m ()
-> PlanT
     (Stack ByteString) o m (Either DecodingError (ByteOffset, a))
-> PlanT
     (Stack ByteString) o m (Either DecodingError (ByteOffset, a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either DecodingError (ByteOffset, a)
-> PlanT
     (Stack ByteString) o m (Either DecodingError (ByteOffset, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DecodingError -> Either DecodingError (ByteOffset, a)
forall a b. a -> Either a b
Left (ByteOffset -> String -> DecodingError
DecodingError ByteOffset
consumed String
e))
    Done ByteString
leftovers ByteOffset
consumed a
a -> ByteString -> Plan (Stack ByteString) o ()
forall a b. a -> Plan (Stack a) b ()
push ByteString
leftovers PlanT (Stack ByteString) o m ()
-> PlanT
     (Stack ByteString) o m (Either DecodingError (ByteOffset, a))
-> PlanT
     (Stack ByteString) o m (Either DecodingError (ByteOffset, a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either DecodingError (ByteOffset, a)
-> PlanT
     (Stack ByteString) o m (Either DecodingError (ByteOffset, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteOffset, a) -> Either DecodingError (ByteOffset, a)
forall a b. b -> Either a b
Right (ByteOffset
consumed, a
a))
    Decoder a
decA' -> Decoder a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
forall a o.
Decoder a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_decoderPlan Decoder a
decA'

_getPlan :: Get a -> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_getPlan :: Get a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_getPlan Get a
getA = Decoder a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
forall a o.
Decoder a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
_decoderPlan (Decoder a
 -> Plan
      (Stack ByteString) o (Either DecodingError (ByteOffset, a)))
-> Decoder a
-> Plan (Stack ByteString) o (Either DecodingError (ByteOffset, a))
forall a b. (a -> b) -> a -> b
$ Get a -> Decoder a
forall a. Get a -> Decoder a
runGetIncremental Get a
getA

--------------------------------------------------------------------------