{-# LANGUAGE BangPatterns  #-}
{-# LANGUAGE CPP           #-}
{-# LANGUAGE DeriveFunctor #-}

-- |Strict Decoder Types
module Flat.Decoder.Types
  (
    Get(..)
  , S(..)
  , GetResult(..)
  , Decoded
  , DecodeException(..)
  , notEnoughSpace
  , tooMuchSpace
  , badEncoding
  , badOp
  ) where

import           Control.DeepSeq    (NFData (..))
import           Control.Exception  (Exception, throwIO)
import           Data.Word          (Word8)
import           Foreign            (Ptr)

#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif

{- |
A decoder.

Given:

* end of input buffer

* current position in input buffer

Returns:

* decoded value

* new position in input buffer
-}
newtype Get a =
  Get
    { forall a. Get a -> Ptr Word8 -> S -> IO (GetResult a)
runGet ::
      Ptr Word8
      -> S
      -> IO (GetResult a)
    }

-- Seems to give better performance than the derived version
instance Functor Get where
  fmap :: forall a b. (a -> b) -> Get a -> Get b
fmap a -> b
f Get a
g =
    forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
s -> do
      GetResult S
s' a
a <- forall a. Get a -> Ptr Word8 -> S -> IO (GetResult a)
runGet Get a
g Ptr Word8
end S
s
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. S -> a -> GetResult a
GetResult S
s' (a -> b
f a
a)
  {-# INLINE fmap #-}

-- Is this correct?
instance NFData (Get a) where
  rnf :: Get a -> ()
rnf !Get a
_ = ()

instance Show (Get a) where
  show :: Get a -> String
show Get a
_ = String
"Get"

instance Applicative Get where
  pure :: forall a. a -> Get a
pure a
x = forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get (\Ptr Word8
_ S
ptr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. S -> a -> GetResult a
GetResult S
ptr a
x)
  {-# INLINE pure #-}
  Get Ptr Word8 -> S -> IO (GetResult (a -> b))
f <*> :: forall a b. Get (a -> b) -> Get a -> Get b
<*> Get Ptr Word8 -> S -> IO (GetResult a)
g =
    forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
ptr1 -> do
      GetResult S
ptr2 a -> b
f' <- Ptr Word8 -> S -> IO (GetResult (a -> b))
f Ptr Word8
end S
ptr1
      GetResult S
ptr3 a
g' <- Ptr Word8 -> S -> IO (GetResult a)
g Ptr Word8
end S
ptr2
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. S -> a -> GetResult a
GetResult S
ptr3 (a -> b
f' a
g')
  {-# INLINE (<*>) #-}
  Get Ptr Word8 -> S -> IO (GetResult a)
f *> :: forall a b. Get a -> Get b -> Get b
*> Get Ptr Word8 -> S -> IO (GetResult b)
g =
    forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
ptr1 -> do
      GetResult S
ptr2 a
_ <- Ptr Word8 -> S -> IO (GetResult a)
f Ptr Word8
end S
ptr1
      Ptr Word8 -> S -> IO (GetResult b)
g Ptr Word8
end S
ptr2
  {-# INLINE (*>) #-}

instance Monad Get where
  return :: forall a. a -> Get a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  >> :: forall a b. Get a -> Get b -> Get b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  {-# INLINE (>>) #-}
  Get Ptr Word8 -> S -> IO (GetResult a)
x >>= :: forall a b. Get a -> (a -> Get b) -> Get b
>>= a -> Get b
f =
    forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
s -> do
      GetResult S
s' a
x' <- Ptr Word8 -> S -> IO (GetResult a)
x Ptr Word8
end S
s
      forall a. Get a -> Ptr Word8 -> S -> IO (GetResult a)
runGet (a -> Get b
f a
x') Ptr Word8
end S
s'
  {-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
  fail = failGet
#endif

#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail Get where
  fail :: forall a. String -> Get a
fail = forall a. String -> Get a
failGet
#endif
{-# INLINE failGet #-}
failGet :: String -> Get a
failGet :: forall a. String -> Get a
failGet String
msg = forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
s -> forall a. Ptr Word8 -> S -> String -> IO a
badEncoding Ptr Word8
end S
s String
msg

-- |Decoder state
data S =
  S
    { S -> Ptr Word8
currPtr  :: {-# UNPACK #-}!(Ptr Word8)
    , S -> Int
usedBits :: {-# UNPACK #-}!Int
    }
  deriving (Int -> S -> ShowS
[S] -> ShowS
S -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S] -> ShowS
$cshowList :: [S] -> ShowS
show :: S -> String
$cshow :: S -> String
showsPrec :: Int -> S -> ShowS
$cshowsPrec :: Int -> S -> ShowS
Show, S -> S -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: S -> S -> Bool
$c/= :: S -> S -> Bool
== :: S -> S -> Bool
$c== :: S -> S -> Bool
Eq, Eq S
S -> S -> Bool
S -> S -> Ordering
S -> S -> S
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: S -> S -> S
$cmin :: S -> S -> S
max :: S -> S -> S
$cmax :: S -> S -> S
>= :: S -> S -> Bool
$c>= :: S -> S -> Bool
> :: S -> S -> Bool
$c> :: S -> S -> Bool
<= :: S -> S -> Bool
$c<= :: S -> S -> Bool
< :: S -> S -> Bool
$c< :: S -> S -> Bool
compare :: S -> S -> Ordering
$ccompare :: S -> S -> Ordering
Ord)

data GetResult a =
  GetResult {-# UNPACK #-}!S !a
  deriving (forall a b. a -> GetResult b -> GetResult a
forall a b. (a -> b) -> GetResult a -> GetResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GetResult b -> GetResult a
$c<$ :: forall a b. a -> GetResult b -> GetResult a
fmap :: forall a b. (a -> b) -> GetResult a -> GetResult b
$cfmap :: forall a b. (a -> b) -> GetResult a -> GetResult b
Functor)

-- |A decoded value
type Decoded a = Either DecodeException a

-- |An exception during decoding
data DecodeException
  = NotEnoughSpace Env
  | TooMuchSpace Env
  | BadEncoding Env String
  | BadOp String
  deriving (Int -> DecodeException -> ShowS
[DecodeException] -> ShowS
DecodeException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodeException] -> ShowS
$cshowList :: [DecodeException] -> ShowS
show :: DecodeException -> String
$cshow :: DecodeException -> String
showsPrec :: Int -> DecodeException -> ShowS
$cshowsPrec :: Int -> DecodeException -> ShowS
Show, DecodeException -> DecodeException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeException -> DecodeException -> Bool
$c/= :: DecodeException -> DecodeException -> Bool
== :: DecodeException -> DecodeException -> Bool
$c== :: DecodeException -> DecodeException -> Bool
Eq, Eq DecodeException
DecodeException -> DecodeException -> Bool
DecodeException -> DecodeException -> Ordering
DecodeException -> DecodeException -> DecodeException
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DecodeException -> DecodeException -> DecodeException
$cmin :: DecodeException -> DecodeException -> DecodeException
max :: DecodeException -> DecodeException -> DecodeException
$cmax :: DecodeException -> DecodeException -> DecodeException
>= :: DecodeException -> DecodeException -> Bool
$c>= :: DecodeException -> DecodeException -> Bool
> :: DecodeException -> DecodeException -> Bool
$c> :: DecodeException -> DecodeException -> Bool
<= :: DecodeException -> DecodeException -> Bool
$c<= :: DecodeException -> DecodeException -> Bool
< :: DecodeException -> DecodeException -> Bool
$c< :: DecodeException -> DecodeException -> Bool
compare :: DecodeException -> DecodeException -> Ordering
$ccompare :: DecodeException -> DecodeException -> Ordering
Ord)

type Env = (Ptr Word8, S)

notEnoughSpace :: Ptr Word8 -> S -> IO a
notEnoughSpace :: forall a. Ptr Word8 -> S -> IO a
notEnoughSpace Ptr Word8
endPtr S
s = forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Env -> DecodeException
NotEnoughSpace (Ptr Word8
endPtr, S
s)

tooMuchSpace :: Ptr Word8 -> S -> IO a
tooMuchSpace :: forall a. Ptr Word8 -> S -> IO a
tooMuchSpace Ptr Word8
endPtr S
s = forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Env -> DecodeException
TooMuchSpace (Ptr Word8
endPtr, S
s)

badEncoding :: Ptr Word8 -> S -> String -> IO a
badEncoding :: forall a. Ptr Word8 -> S -> String -> IO a
badEncoding Ptr Word8
endPtr S
s String
msg = forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Env -> String -> DecodeException
BadEncoding (Ptr Word8
endPtr, S
s) String
msg

badOp :: String -> IO a
badOp :: forall a. String -> IO a
badOp String
msg = forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> DecodeException
BadOp String
msg

instance Exception DecodeException