{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}

-- |Strict encoder
module Flat.Encoder.Strict where

import qualified Data.ByteString         as B
import qualified Data.ByteString.Lazy    as L
import           Flat.Encoder.Prim
import qualified Flat.Encoder.Size  as S
import           Flat.Encoder.Types
import           Flat.Memory
import           Flat.Types
import           Data.Foldable

-- import           Data.Semigroup
-- import           Data.Semigroup          (Semigroup (..))

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup          (Semigroup (..))
#endif

#ifdef ETA_VERSION
-- import Data.Function(trampoline)
import           GHC.IO                  (trampolineIO)
trampolineEncoding :: Encoding -> Encoding
trampolineEncoding (Encoding op) = Encoding (\s -> trampolineIO (op s))
#else

-- trampolineIO = id
#endif

-- |Strict encoder
strictEncoder :: NumBits -> Encoding -> B.ByteString
strictEncoder :: NumBits -> Encoding -> ByteString
strictEncoder NumBits
numBits (Encoding Prim
op) =
  let bufSize :: NumBits
bufSize = NumBits -> NumBits
S.bitsToBytes NumBits
numBits
   in (ByteString, ()) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ()) -> ByteString) -> (ByteString, ()) -> ByteString
forall a b. (a -> b) -> a -> b
$
      NumBits -> (Ptr Word8 -> IO (NumBits, ())) -> (ByteString, ())
forall a.
NumBits -> (Ptr Word8 -> IO (NumBits, a)) -> (ByteString, a)
unsafeCreateUptoN' NumBits
bufSize ((Ptr Word8 -> IO (NumBits, ())) -> (ByteString, ()))
-> (Ptr Word8 -> IO (NumBits, ())) -> (ByteString, ())
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
        (S Ptr Word8
ptr' Word8
0 NumBits
0) <- Prim
op (Ptr Word8 -> Word8 -> NumBits -> S
S Ptr Word8
ptr Word8
0 NumBits
0)
        (NumBits, ()) -> IO (NumBits, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8
ptr' Ptr Word8 -> Ptr Word8 -> NumBits
forall a b. Ptr a -> Ptr b -> NumBits
`minusPtr` Ptr Word8
ptr, ())

newtype Encoding =
  Encoding
    { Encoding -> Prim
run :: Prim
    }

instance Show Encoding where
  show :: Encoding -> String
show Encoding
_ = String
"Encoding"

instance Semigroup Encoding where
  {-# INLINE (<>) #-}
  <> :: Encoding -> Encoding -> Encoding
(<>) = Encoding -> Encoding -> Encoding
forall a. Monoid a => a -> a -> a
mappend

instance Monoid Encoding where
  {-# INLINE mempty #-}
  mempty :: Encoding
mempty = Prim -> Encoding
Encoding Prim
forall (m :: * -> *) a. Monad m => a -> m a
return
  {-# INLINE mappend #-}
  -- mappend (Encoding f) (Encoding g) = Encoding (f >=> g)
  mappend :: Encoding -> Encoding -> Encoding
mappend (Encoding Prim
f) (Encoding Prim
g) = Prim -> Encoding
Encoding Prim
m
    where
      m :: Prim
m s :: S
s@(S !Ptr Word8
_ !Word8
_ !NumBits
_) = do
        !S
s1 <- Prim
f S
s
        Prim
g S
s1
  {-# INLINE mconcat #-}
  mconcat :: [Encoding] -> Encoding
mconcat = (Encoding -> Encoding -> Encoding)
-> Encoding -> [Encoding] -> Encoding
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Encoding -> Encoding -> Encoding
forall a. Monoid a => a -> a -> a
mappend Encoding
forall a. Monoid a => a
mempty

-- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists)
-- TODO: check with newest GHC versions
{-# RULES
"encodersSN" forall h t . encodersS (h : t) =
             h `mappend` encodersS t
"encodersS0" encodersS [] = mempty
 #-}

{-# NOINLINE encodersS #-}
encodersS :: [Encoding] -> Encoding
-- without the explicit parameter the rules won't fire
encodersS :: [Encoding] -> Encoding
encodersS [Encoding]
ws = (Encoding -> Encoding -> Encoding)
-> Encoding -> [Encoding] -> Encoding
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Encoding -> Encoding -> Encoding
forall a. Monoid a => a -> a -> a
mappend Encoding
forall a. Monoid a => a
mempty [Encoding]
ws

-- encodersS ws = error $ unwords ["encodersS CALLED",show ws]
{-# INLINE encodeListWith #-}
-- |Encode as a List
encodeListWith :: (t -> Encoding) -> [t] -> Encoding
encodeListWith :: (t -> Encoding) -> [t] -> Encoding
encodeListWith t -> Encoding
enc = [t] -> Encoding
go
  where
    go :: [t] -> Encoding
go []     = Encoding
eFalse
    go (t
x:[t]
xs) = Encoding
eTrue Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
enc t
x Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [t] -> Encoding
go [t]
xs
 
-- {-# INLINE encodeList #-}
-- encodeList :: (Foldable t, Flat a) => t a -> Encoding
-- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse
-- {-# INLINE encodeList2 #-}
-- encodeList2 :: (Foldable t, Flat a) => t a -> Encoding
-- encodeList2 l = foldr (\a acc -> eTrue <> encode a <> acc) mempty l <> eFalse
{-# INLINE encodeArrayWith #-}
-- |Encode as Array
encodeArrayWith :: (t -> Encoding) -> [t] -> Encoding
encodeArrayWith :: (t -> Encoding) -> [t] -> Encoding
encodeArrayWith t -> Encoding
_ [] = Word8 -> Encoding
eWord8 Word8
0
encodeArrayWith t -> Encoding
f [t]
ws = Prim -> Encoding
Encoding (Prim -> Encoding) -> Prim -> Encoding
forall a b. (a -> b) -> a -> b
$ [t] -> Prim
go [t]
ws
  where
    go :: [t] -> Prim
go [t]
l S
s = do
      S
s' <- Word8 -> Prim
eWord8F Word8
0 S
s
      (Word8
n, S
s'', [t]
l) <- [t] -> Word8 -> S -> IO (Word8, S, [t])
forall t. (Eq t, Num t) => [t] -> t -> S -> IO (t, S, [t])
gol [t]
l Word8
0 S
s'
      S
_ <- Word8 -> Prim
eWord8F Word8
n S
s
      if [t] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t]
l
        then Word8 -> Prim
eWord8F Word8
0 S
s''
        else [t] -> Prim
go [t]
l S
s''
    gol :: [t] -> t -> S -> IO (t, S, [t])
gol [] !t
n !S
s = (t, S, [t]) -> IO (t, S, [t])
forall (m :: * -> *) a. Monad m => a -> m a
return (t
n, S
s, [])
    gol l :: [t]
l@(t
x:[t]
xs) !t
n !S
s
      | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
255 = (t, S, [t]) -> IO (t, S, [t])
forall (m :: * -> *) a. Monad m => a -> m a
return (t
255, S
s, [t]
l)
      | Bool
otherwise = Encoding -> Prim
run (t -> Encoding
f t
x) S
s IO S -> (S -> IO (t, S, [t])) -> IO (t, S, [t])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [t] -> t -> S -> IO (t, S, [t])
gol [t]
xs (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

-- Encoding primitives
{-# INLINE eChar #-}
{-# INLINE eUTF8 #-}
{-# INLINE eNatural #-}
{-# INLINE eFloat #-}
{-# INLINE eDouble #-}
{-# INLINE eInteger #-}
{-# INLINE eInt64 #-}
{-# INLINE eInt32 #-}
{-# INLINE eInt16 #-}
{-# INLINE eInt8 #-}
{-# INLINE eInt #-}
{-# INLINE eWord64 #-}
{-# INLINE eWord32 #-}
{-# INLINE eWord16 #-}
{-# INLINE eWord8 #-}
{-# INLINE eWord #-}
{-# INLINE eBits #-}
{-# INLINE eFiller #-}
{-# INLINE eBool #-}
{-# INLINE eTrue #-}
{-# INLINE eFalse #-}
eChar :: Char -> Encoding
eChar :: Char -> Encoding
eChar = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Char -> Prim) -> Char -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Prim
eCharF
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
{-# INLINE eUTF16 #-}
eUTF16 :: Text -> Encoding
eUTF16 :: Text -> Encoding
eUTF16 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Text -> Prim) -> Text -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Prim
eUTF16F
#endif
eUTF8 :: Text -> Encoding
eUTF8 :: Text -> Encoding
eUTF8 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Text -> Prim) -> Text -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Prim
eUTF8F

eBytes :: B.ByteString -> Encoding
eBytes :: ByteString -> Encoding
eBytes = Prim -> Encoding
Encoding (Prim -> Encoding)
-> (ByteString -> Prim) -> ByteString -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Prim
eBytesF

eLazyBytes :: L.ByteString -> Encoding
eLazyBytes :: ByteString -> Encoding
eLazyBytes = Prim -> Encoding
Encoding (Prim -> Encoding)
-> (ByteString -> Prim) -> ByteString -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Prim
eLazyBytesF

eShortBytes :: ShortByteString -> Encoding
eShortBytes :: ShortByteString -> Encoding
eShortBytes = Prim -> Encoding
Encoding (Prim -> Encoding)
-> (ShortByteString -> Prim) -> ShortByteString -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Prim
eShortBytesF

eNatural :: Natural -> Encoding
eNatural :: Natural -> Encoding
eNatural = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Natural -> Prim) -> Natural -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Prim
eNaturalF

eFloat :: Float -> Encoding
eFloat :: Float -> Encoding
eFloat = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Float -> Prim) -> Float -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Prim
eFloatF

eDouble :: Double -> Encoding
eDouble :: Double -> Encoding
eDouble = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Double -> Prim) -> Double -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Prim
eDoubleF

eInteger :: Integer -> Encoding
eInteger :: Integer -> Encoding
eInteger = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Integer -> Prim) -> Integer -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Prim
eIntegerF

eInt64 :: Int64 -> Encoding
eInt64 :: Int64 -> Encoding
eInt64 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Int64 -> Prim) -> Int64 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Prim
eInt64F

eInt32 :: Int32 -> Encoding
eInt32 :: Int32 -> Encoding
eInt32 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Int32 -> Prim) -> Int32 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Prim
eInt32F

eInt16 :: Int16 -> Encoding
eInt16 :: Int16 -> Encoding
eInt16 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Int16 -> Prim) -> Int16 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Prim
eInt16F

eInt8 :: Int8 -> Encoding
eInt8 :: Int8 -> Encoding
eInt8 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Int8 -> Prim) -> Int8 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Prim
eInt8F

eInt :: Int -> Encoding
eInt :: NumBits -> Encoding
eInt = Prim -> Encoding
Encoding (Prim -> Encoding) -> (NumBits -> Prim) -> NumBits -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumBits -> Prim
eIntF

eWord64 :: Word64 -> Encoding
eWord64 :: Word64 -> Encoding
eWord64 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Word64 -> Prim) -> Word64 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Prim
eWord64F

eWord32 :: Word32 -> Encoding
eWord32 :: Word32 -> Encoding
eWord32 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Word32 -> Prim) -> Word32 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Prim
eWord32F

eWord16 :: Word16 -> Encoding
eWord16 :: Word16 -> Encoding
eWord16 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Word16 -> Prim) -> Word16 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Prim
eWord16F

eWord8 :: Word8 -> Encoding
eWord8 :: Word8 -> Encoding
eWord8 = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Word8 -> Prim) -> Word8 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Prim
eWord8F

eWord :: Word -> Encoding
eWord :: Word -> Encoding
eWord = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Word -> Prim) -> Word -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Prim
eWordF

eBits16 :: NumBits -> Word16 -> Encoding
eBits16 :: NumBits -> Word16 -> Encoding
eBits16 NumBits
n Word16
f = Prim -> Encoding
Encoding (Prim -> Encoding) -> Prim -> Encoding
forall a b. (a -> b) -> a -> b
$ NumBits -> Word16 -> Prim
eBits16F NumBits
n Word16
f

eBits :: NumBits -> Word8 -> Encoding
eBits :: NumBits -> Word8 -> Encoding
eBits NumBits
n Word8
f = Prim -> Encoding
Encoding (Prim -> Encoding) -> Prim -> Encoding
forall a b. (a -> b) -> a -> b
$ NumBits -> Word8 -> Prim
eBitsF NumBits
n Word8
f

eFiller :: Encoding
eFiller :: Encoding
eFiller = Prim -> Encoding
Encoding Prim
eFillerF

eBool :: Bool -> Encoding
eBool :: Bool -> Encoding
eBool = Prim -> Encoding
Encoding (Prim -> Encoding) -> (Bool -> Prim) -> Bool -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Prim
eBoolF

eTrue :: Encoding
eTrue :: Encoding
eTrue = Prim -> Encoding
Encoding Prim
eTrueF

eFalse :: Encoding
eFalse :: Encoding
eFalse = Prim -> Encoding
Encoding Prim
eFalseF

-- Size Primitives
-- Variable size
{-# INLINE vsize #-}
vsize :: (t -> NumBits) -> t -> NumBits -> NumBits
vsize :: (t -> NumBits) -> t -> NumBits -> NumBits
vsize !t -> NumBits
f !t
t !NumBits
n = t -> NumBits
f t
t NumBits -> NumBits -> NumBits
forall a. Num a => a -> a -> a
+ NumBits
n

-- Constant size
{-# INLINE csize #-}
csize :: NumBits -> t -> NumBits -> NumBits
csize :: NumBits -> t -> NumBits -> NumBits
csize !NumBits
n t
_ !NumBits
s = NumBits
n NumBits -> NumBits -> NumBits
forall a. Num a => a -> a -> a
+ NumBits
s

sChar :: Size Char
sChar :: Size Char
sChar = (Char -> NumBits) -> Size Char
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Char -> NumBits
S.sChar

sInt64 :: Size Int64
sInt64 :: Size Int64
sInt64 = (Int64 -> NumBits) -> Size Int64
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Int64 -> NumBits
S.sInt64

sInt32 :: Size Int32
sInt32 :: Size Int32
sInt32 = (Int32 -> NumBits) -> Size Int32
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Int32 -> NumBits
S.sInt32

sInt16 :: Size Int16
sInt16 :: Size Int16
sInt16 = (Int16 -> NumBits) -> Size Int16
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Int16 -> NumBits
S.sInt16

sInt8 :: Size Int8
sInt8 :: Size Int8
sInt8 = NumBits -> Size Int8
forall t. NumBits -> t -> NumBits -> NumBits
csize NumBits
S.sInt8

sInt :: Size Int
sInt :: NumBits -> NumBits -> NumBits
sInt = (NumBits -> NumBits) -> NumBits -> NumBits -> NumBits
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize NumBits -> NumBits
S.sInt

sWord64 :: Size Word64
sWord64 :: Size Word64
sWord64 = (Word64 -> NumBits) -> Size Word64
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Word64 -> NumBits
S.sWord64

sWord32 :: Size Word32
sWord32 :: Size Word32
sWord32 = (Word32 -> NumBits) -> Size Word32
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Word32 -> NumBits
S.sWord32

sWord16 :: Size Word16
sWord16 :: Size Word16
sWord16 = (Word16 -> NumBits) -> Size Word16
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Word16 -> NumBits
S.sWord16

sWord8 :: Size Word8
sWord8 :: Size Word8
sWord8 = NumBits -> Size Word8
forall t. NumBits -> t -> NumBits -> NumBits
csize NumBits
S.sWord8

sWord :: Size Word
sWord :: Size Word
sWord = (Word -> NumBits) -> Size Word
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Word -> NumBits
S.sWord

sFloat :: Size Float
sFloat :: Size Float
sFloat = NumBits -> Size Float
forall t. NumBits -> t -> NumBits -> NumBits
csize NumBits
S.sFloat

sDouble :: Size Double
sDouble :: Size Double
sDouble = NumBits -> Size Double
forall t. NumBits -> t -> NumBits -> NumBits
csize NumBits
S.sDouble

sBytes :: Size B.ByteString
sBytes :: Size ByteString
sBytes = (ByteString -> NumBits) -> Size ByteString
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize ByteString -> NumBits
S.sBytes

sLazyBytes :: Size L.ByteString
sLazyBytes :: Size ByteString
sLazyBytes = (ByteString -> NumBits) -> Size ByteString
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize ByteString -> NumBits
S.sLazyBytes

sShortBytes :: Size ShortByteString
sShortBytes :: Size ShortByteString
sShortBytes = (ShortByteString -> NumBits) -> Size ShortByteString
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize ShortByteString -> NumBits
S.sShortBytes

sNatural :: Size Natural
sNatural :: Size Natural
sNatural = (Natural -> NumBits) -> Size Natural
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Natural -> NumBits
S.sNatural

sInteger :: Size Integer
sInteger :: Size Integer
sInteger = (Integer -> NumBits) -> Size Integer
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Integer -> NumBits
S.sInteger

-- sUTF8 = vsize S.sUTF8
sUTF8Max :: Size Text
sUTF8Max :: Size Text
sUTF8Max = (Text -> NumBits) -> Size Text
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Text -> NumBits
S.sUTF8Max
#ifndef ghcjs_HOST_OS
sUTF16 :: Size Text
sUTF16 :: Size Text
sUTF16 = (Text -> NumBits) -> Size Text
forall t. (t -> NumBits) -> t -> NumBits -> NumBits
vsize Text -> NumBits
S.sUTF16
#endif
sFillerMax :: Size a
sFillerMax :: Size a
sFillerMax = NumBits -> Size a
forall t. NumBits -> t -> NumBits -> NumBits
csize NumBits
S.sFillerMax

sBool :: Size Bool
sBool :: Size Bool
sBool = NumBits -> Size Bool
forall t. NumBits -> t -> NumBits -> NumBits
csize NumBits
S.sBool