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

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

import Control.DeepSeq ( NFData(..) )
import Control.Exception ( throwIO, Exception )
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
    { Get a -> Ptr Word8 -> S -> IO (GetResult a)
runGet :: 
      Ptr Word8 
      -> S      
      -> IO (GetResult a)
    } -- deriving (Functor)

-- Seems to give better performance than the derived version
instance Functor Get where
  fmap :: (a -> b) -> Get a -> Get b
fmap a -> b
f Get a
g =
    (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get ((Ptr Word8 -> S -> IO (GetResult b)) -> Get b)
-> (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
s -> do
      GetResult S
s' a
a <- Get a -> Ptr Word8 -> S -> IO (GetResult a)
forall a. Get a -> Ptr Word8 -> S -> IO (GetResult a)
runGet Get a
g Ptr Word8
end S
s
      GetResult b -> IO (GetResult b)
forall (m :: * -> *) a. Monad m => a -> m a
return (GetResult b -> IO (GetResult b))
-> GetResult b -> IO (GetResult b)
forall a b. (a -> b) -> a -> b
$ S -> b -> GetResult 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 :: a -> Get a
pure a
x = (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get (\Ptr Word8
_ S
ptr -> GetResult a -> IO (GetResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (GetResult a -> IO (GetResult a))
-> GetResult a -> IO (GetResult a)
forall a b. (a -> b) -> a -> b
$ S -> a -> GetResult a
forall a. S -> a -> GetResult a
GetResult S
ptr a
x)
  {-# INLINE pure #-}
  Get Ptr Word8 -> S -> IO (GetResult (a -> b))
f <*> :: Get (a -> b) -> Get a -> Get b
<*> Get Ptr Word8 -> S -> IO (GetResult a)
g =
    (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get ((Ptr Word8 -> S -> IO (GetResult b)) -> Get b)
-> (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
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
      GetResult b -> IO (GetResult b)
forall (m :: * -> *) a. Monad m => a -> m a
return (GetResult b -> IO (GetResult b))
-> GetResult b -> IO (GetResult b)
forall a b. (a -> b) -> a -> b
$ S -> b -> GetResult b
forall a. S -> a -> GetResult a
GetResult S
ptr3 (a -> b
f' a
g')
  {-# INLINE (<*>) #-}
  Get Ptr Word8 -> S -> IO (GetResult a)
f *> :: Get a -> Get b -> Get b
*> Get Ptr Word8 -> S -> IO (GetResult b)
g =
    (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get ((Ptr Word8 -> S -> IO (GetResult b)) -> Get b)
-> (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
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 :: a -> Get a
return = a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  >> :: Get a -> Get b -> Get 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 >>= :: Get a -> (a -> Get b) -> Get b
>>= a -> Get b
f =
    (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get ((Ptr Word8 -> S -> IO (GetResult b)) -> Get b)
-> (Ptr Word8 -> S -> IO (GetResult b)) -> Get b
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
      Get b -> Ptr Word8 -> S -> IO (GetResult b)
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
                 -- base < 4.13
#endif

#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail Get where
  fail :: String -> Get a
fail = String -> Get a
forall a. String -> Get a
failGet
#endif
{-# INLINE failGet #-}
failGet :: String -> Get a
failGet :: String -> Get a
failGet String
msg = (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get ((Ptr Word8 -> S -> IO (GetResult a)) -> Get a)
-> (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
s -> Ptr Word8 -> S -> String -> IO (GetResult a)
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
(Int -> S -> ShowS) -> (S -> String) -> ([S] -> ShowS) -> Show S
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
(S -> S -> Bool) -> (S -> S -> Bool) -> Eq S
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
Eq S
-> (S -> S -> Ordering)
-> (S -> S -> Bool)
-> (S -> S -> Bool)
-> (S -> S -> Bool)
-> (S -> S -> Bool)
-> (S -> S -> S)
-> (S -> S -> S)
-> Ord 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
$cp1Ord :: Eq S
Ord)

data GetResult a =
  GetResult {-# UNPACK #-}!S !a
  deriving (a -> GetResult b -> GetResult a
(a -> b) -> GetResult a -> GetResult b
(forall a b. (a -> b) -> GetResult a -> GetResult b)
-> (forall a b. a -> GetResult b -> GetResult a)
-> Functor GetResult
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
<$ :: a -> GetResult b -> GetResult a
$c<$ :: forall a b. a -> GetResult b -> GetResult a
fmap :: (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
  deriving (Int -> DecodeException -> ShowS
[DecodeException] -> ShowS
DecodeException -> String
(Int -> DecodeException -> ShowS)
-> (DecodeException -> String)
-> ([DecodeException] -> ShowS)
-> Show DecodeException
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
(DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> Bool)
-> Eq DecodeException
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
Eq DecodeException
-> (DecodeException -> DecodeException -> Ordering)
-> (DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> DecodeException)
-> (DecodeException -> DecodeException -> DecodeException)
-> Ord 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
$cp1Ord :: Eq DecodeException
Ord)

type Env = (Ptr Word8, S)

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

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

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

instance Exception DecodeException