{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Streamly.Internal.Data.Serialize.TH.RecHeader
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
module Streamly.Internal.Data.Serialize.TH.RecHeader
    ( mkRecSerializeExpr
    , mkRecDeserializeExpr
    , mkRecSizeOfExpr
    , conUpdateFuncDec
    , mkDeserializeKeysDec
    ) where

--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

import Control.Monad (void)
import Data.List (foldl')
import Data.Word (Word32, Word8)
import Data.Maybe (fromJust)
import Language.Haskell.TH
import Streamly.Internal.Data.Serialize.Type (Serialize(..))
import Data.Foldable (foldlM)
import Streamly.Internal.Data.MutByteArray.Type (MutByteArray)
import Data.Proxy (Proxy(..))

import qualified Streamly.Internal.Data.Unbox as Unbox

import Streamly.Internal.Data.Serialize.TH.Bottom
import Streamly.Internal.Data.Serialize.TH.Common

--------------------------------------------------------------------------------
-- Notes
--------------------------------------------------------------------------------

-- Compatibility Algorithm
-- =======================
--
-- The algorithm is written without any low level implementation details. See
-- the code for any low level implementation details.
--
-- Serialization:
-- --------------
--
-- To serialize the data,
--
-- * Get the list of keys for the record as @keyList@.
-- * Serialize the @keyList@.
-- * Serialize the @fields@ one-by-one after serializing the @keyList@.
--
-- Deserialization:
-- ----------------
--
-- To deserialize the data to type @T@,
--
-- __Checking for type match__:
--
-- * Get the list of keys for type @T@ as @targetKeyList@.
-- * Get the list of keys encoded as @encodedKeyList@.
-- * If @targetKeyList == encodedKeyList@ see the __Type Match__ section else
--   see the __No Type Match__ section.
--
-- __Type Match__:
--
-- * Decode the fields one-by-one and construct the type @T@ in the end.
--
-- __No Type Match__:
--
-- * Decode the list of keys encoded into @encodedKeyList@.
-- * Get the list of keys for type @T@ as @targetKeyList@.
-- * Loop through @encodedKeyList@ and start deserializing the encoded data.
-- * If the key is present in @encodedKeyList@ and not in @targetKeyList@
--   then skip parsing the corresponding value.
-- * If the key is present in @targetKeyList@ and not in @encodedKeyList@
--   then set the value for that key as @Nothing@.
-- * If the key is present in both @encodedKeyList@ and in @targetKeyList@
--   parse the value.
-- * Construct @T@ after parsing all the data.

-- Developer Notes
-- ===============
--
-- * Record update syntax is not robust across language extensions and common
--   record plugins (like record-dot-processor, large-records, etc.).

--------------------------------------------------------------------------------
-- Compact lists
--------------------------------------------------------------------------------

-- Like haskell list but the maximum length of the list is 255
newtype CompactList a =
    CompactList
        { forall a. CompactList a -> [a]
unCompactList :: [a]
        }

-- We use 'Word8' to encode the length, hence the maximim number of elements in
-- the list is 255.
instance forall a. Serialize a => Serialize (CompactList a) where

    -- {-# INLINE addSizeTo #-}
    addSizeTo :: Int -> CompactList a -> Int
addSizeTo Int
acc (CompactList [a]
xs) =
        (Int -> a -> Int) -> Int -> [a] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> a -> Int
forall a. Serialize a => Int -> a -> Int
addSizeTo (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Proxy Word8 -> Int
forall a. Unbox a => Proxy a -> Int
Unbox.sizeOf (Proxy Word8
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word8))) [a]
xs

    -- Inlining this causes large compilation times for tests
    {-# INLINABLE deserializeAt #-}
    deserializeAt :: Int -> MutByteArray -> Int -> IO (Int, CompactList a)
deserializeAt Int
off MutByteArray
arr Int
sz = do
        (Int
off1, Word8
len8) <- Int -> MutByteArray -> Int -> IO (Int, Word8)
forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt Int
off MutByteArray
arr Int
sz :: IO (Int, Word8)
        let len :: Int
len = Word8 -> Int
w8_int Word8
len8
            peekList :: ([a] -> c) -> Int -> a -> IO (Int, c)
peekList [a] -> c
f Int
o a
i | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
3 = do
              -- Unfold the loop three times
              (Int
o1, a
x1) <- Int -> MutByteArray -> Int -> IO (Int, a)
forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt Int
o MutByteArray
arr Int
sz
              (Int
o2, a
x2) <- Int -> MutByteArray -> Int -> IO (Int, a)
forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt Int
o1 MutByteArray
arr Int
sz
              (Int
o3, a
x3) <- Int -> MutByteArray -> Int -> IO (Int, a)
forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt Int
o2 MutByteArray
arr Int
sz
              ([a] -> c) -> Int -> a -> IO (Int, c)
peekList ([a] -> c
f ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[a]
xs -> a
x1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
x3a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)) Int
o3 (a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
3)
            peekList [a] -> c
f Int
o a
0 = (Int, c) -> IO (Int, c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
o, [a] -> c
f [])
            peekList [a] -> c
f Int
o a
i = do
              (Int
o1, a
x) <- Int -> MutByteArray -> Int -> IO (Int, a)
forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt Int
o MutByteArray
arr Int
sz
              ([a] -> c) -> Int -> a -> IO (Int, c)
peekList ([a] -> c
f ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) Int
o1 (a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
        (Int
nextOff, [a]
lst) <- ([a] -> [a]) -> Int -> Int -> IO (Int, [a])
forall {a} {a} {c}.
(Ord a, Num a, Serialize a) =>
([a] -> c) -> Int -> a -> IO (Int, c)
peekList [a] -> [a]
forall a. a -> a
id Int
off1 Int
len
        (Int, CompactList a) -> IO (Int, CompactList a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nextOff, [a] -> CompactList a
forall a. [a] -> CompactList a
CompactList [a]
lst)

    -- Inlining this causes large compilation times for tests
    {-# INLINABLE serializeAt #-}
    serializeAt :: Int -> MutByteArray -> CompactList a -> IO Int
serializeAt Int
off MutByteArray
arr (CompactList [a]
val) = do
        IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> MutByteArray -> Word8 -> IO Int
forall a. Serialize a => Int -> MutByteArray -> a -> IO Int
serializeAt Int
off MutByteArray
arr (Int -> Word8
int_w8 ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
val) :: Word8)
        let off1 :: Int
off1 = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy Word8 -> Int
forall a. Unbox a => Proxy a -> Int
Unbox.sizeOf (Proxy Word8
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word8)
        let pokeList :: Int -> [a] -> IO Int
pokeList Int
o [] = Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
o
            pokeList Int
o (a
x:[a]
xs) = do
              Int
o1 <- Int -> MutByteArray -> a -> IO Int
forall a. Serialize a => Int -> MutByteArray -> a -> IO Int
serializeAt Int
o MutByteArray
arr a
x
              Int -> [a] -> IO Int
pokeList Int
o1 [a]
xs
        Int -> [a] -> IO Int
forall {a}. Serialize a => Int -> [a] -> IO Int
pokeList Int
off1 [a]
val

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

fieldToNameBase :: Field -> String
fieldToNameBase :: Field -> String
fieldToNameBase = Name -> String
nameBase (Name -> String) -> (Field -> Name) -> Field -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Name -> Name
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Name -> Name) -> (Field -> Maybe Name) -> Field -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Maybe Name
forall a b. (a, b) -> a
fst

isMaybeType :: Type -> Bool
isMaybeType :: Type -> Bool
isMaybeType (AppT (ConT Name
m) Type
_) = Name
m Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe
isMaybeType Type
_ = Bool
False

--------------------------------------------------------------------------------
-- Size
--------------------------------------------------------------------------------

-- We add 4 here because we use 'serializeWithSize' for serializing.
exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
exprGetSize Q Exp
acc (Int
i, Type
_) =
    [|addSizeTo $(acc) $(varE (mkFieldName i)) + 4|]

sizeOfHeader :: SimpleDataCon -> Int
sizeOfHeader :: SimpleDataCon -> Int
sizeOfHeader (SimpleDataCon Name
_ [Field]
fields) =
    Int
sizeForFinalOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeForHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeForNumFields
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Field -> Int) -> [Field] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeForFieldLen) (Int -> Int) -> (Field -> Int) -> Field -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (Field -> String) -> Field -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> String
fieldToNameBase) [Field]
fields)

    where

    sizeForFinalOff :: Int
sizeForFinalOff = Int
4
    sizeForHeaderLength :: Int
sizeForHeaderLength = Int
4 -- Max header length is (255 * (255 + 1) + 1) and
                            -- hence 2 bytes is enough to store it. But we still
                            -- use 4 bytes as using 2 bytes introduces
                            -- regression.
    sizeForNumFields :: Int
sizeForNumFields = Int
1 -- At max 255 fields in the record constructor
    sizeForFieldLen :: Int
sizeForFieldLen = Int
1  -- At max 255 letters in the key

mkRecSizeOfExpr :: SimpleDataCon -> Q Exp
mkRecSizeOfExpr :: SimpleDataCon -> Q Exp
mkRecSizeOfExpr SimpleDataCon
con = do
    Name
n_acc <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"acc"
    Name
n_x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    ([Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
         [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n_acc, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n_x]
         [|$(litIntegral hlen) +
            $(caseE (varE n_x) [matchCons (varE n_acc) con])|])

    where

    hlen :: Int
hlen = SimpleDataCon -> Int
sizeOfHeader SimpleDataCon
con
    sizeOfFields :: Q Exp -> [Type] -> Q Exp
sizeOfFields Q Exp
acc [Type]
fields = (Q Exp -> (Int, Type) -> Q Exp) -> Q Exp -> [(Int, Type)] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> (Int, Type) -> Q Exp
exprGetSize Q Exp
acc ([(Int, Type)] -> Q Exp) -> [(Int, Type)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Type]
fields
    matchCons :: Q Exp -> SimpleDataCon -> Q Match
matchCons Q Exp
acc (SimpleDataCon Name
cname [Field]
fields) =
        let expr :: Q Exp
expr = Q Exp -> [Type] -> Q Exp
sizeOfFields Q Exp
acc ((Field -> Type) -> [Field] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Type
forall a b. (a, b) -> b
snd [Field]
fields)
         in Name -> Int -> Q Exp -> Q Match
matchConstructor Name
cname ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fields) Q Exp
expr

--------------------------------------------------------------------------------
-- Header
--------------------------------------------------------------------------------

headerValue :: SimpleDataCon -> [Word8]
headerValue :: SimpleDataCon -> [Word8]
headerValue (SimpleDataCon Name
_ [Field]
fields) =
    Int -> Word8
int_w8 Int
numFields Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Field -> [Word8]) -> [Field] -> [[Word8]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Field -> [Word8]
lengthPrependedFieldEncoding [Field]
fields)

    where

    -- Error out if the number of fields or the length of key is >= 256. We use
    -- Word8 for encoding the info and hence the max value is 255.
    numFields :: Int
numFields =
        let lenFields :: Int
lenFields = [Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fields
         in if Int
lenFields Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255
            then Int
lenFields
            else String -> Int
forall a. String -> a
errorUnsupported
                     String
"Number of fields in the record should be <= 255."
    lengthPrependedFieldEncoding :: Field -> [Word8]
lengthPrependedFieldEncoding Field
field =
        let fEnc :: [Word8]
fEnc =
                let fEnc_ :: [Word8]
fEnc_ = (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
c2w (Field -> String
fieldToNameBase Field
field)
                    lenFEnc :: Int
lenFEnc = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
fEnc_
                 in if Int
lenFEnc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255
                    then [Word8]
fEnc_
                    else
                        String -> [Word8]
forall a. String -> a
errorUnsupported
                            String
"Length of any key should be <= 255."
         in (Int -> Word8
int_w8 ([Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
fEnc)) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
fEnc

--------------------------------------------------------------------------------
-- Peek
--------------------------------------------------------------------------------

-- Encoding the size is required if we want to skip the field without knowing
-- its type. We encode the size as 'Word32' hence there is a 4 bytes increase
-- in size.
{-# INLINE serializeWithSize #-}
serializeWithSize :: Serialize a => Int -> MutByteArray -> a -> IO Int
serializeWithSize :: forall a. Serialize a => Int -> MutByteArray -> a -> IO Int
serializeWithSize Int
off MutByteArray
arr a
val = do
    Int
off1 <- Int -> MutByteArray -> a -> IO Int
forall a. Serialize a => Int -> MutByteArray -> a -> IO Int
serializeAt (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) MutByteArray
arr a
val
    Int -> MutByteArray -> Word32 -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
Unbox.pokeAt Int
off MutByteArray
arr (Int -> Word32
int_w32 (Int
off1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) :: Word32)
    Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
off1

mkRecSerializeExpr :: Name -> SimpleDataCon -> Q Exp
mkRecSerializeExpr :: Name -> SimpleDataCon -> Q Exp
mkRecSerializeExpr Name
initialOffset (con :: SimpleDataCon
con@(SimpleDataCon Name
cname [Field]
fields)) = do
    Name
afterHLen <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"afterHLen"
    -- Encoding the header length is required.
    -- We first compare the header length encoded and the current header
    -- length. Only if the header lengths match, we compare the headers.
    [|do $(varP afterHLen) <-
             serializeAt
                 ($(varE initialOffset) + 4)
                 $(varE _arr)
                 ($(litIntegral hlen) :: Word32)
         $(varP (makeI 0)) <- $(serializeW8List afterHLen _arr hval)
         let $(openConstructor cname (length fields)) = $(varE _val)
         finalOff <- $(mkSerializeExprFields 'serializeWithSize fields)
         Unbox.pokeAt
             $(varE initialOffset)
             $(varE _arr)
             ((fromIntegral :: Int -> Word32)
                  (finalOff - $(varE initialOffset)))
         pure finalOff|]

    where

    hval :: [Word8]
hval = SimpleDataCon -> [Word8]
headerValue SimpleDataCon
con
    hlen :: Int
hlen = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
hval

--------------------------------------------------------------------------------
-- Poke
--------------------------------------------------------------------------------

{-# INLINE deserializeWithSize #-}
deserializeWithSize ::
       Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeWithSize :: forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeWithSize Int
off MutByteArray
arr Int
endOff = Int -> MutByteArray -> Int -> IO (Int, a)
forall a. Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) MutByteArray
arr Int
endOff

conUpdateFuncDec :: Name -> [Field] -> Q [Dec]
conUpdateFuncDec :: Name -> [Field] -> Q [Dec]
conUpdateFuncDec Name
funcName [Field]
fields = do
    Name
prevAcc <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"prevAcc"
    Name
curOff <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"curOff"
    Name
endOff <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"endOff"
    Name
arr <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"arr"
    Name
key <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"key"
    Exp
method <-
        (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
             (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
key)
             ([[Q Match]] -> [Q Match]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  [ (Name -> Q Match) -> [Name] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> (Name, Name) -> Name -> Q Match
matchField Name
arr Name
endOff (Name
prevAcc, Name
curOff)) [Name]
fnames
                  , [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                          Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP
                          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                               [|do (valOff, valLen :: Word32) <-
                                        deserializeAt
                                            $(varE curOff)
                                            $(varE arr)
                                            $(varE endOff)
                                    pure
                                        ( $(varE prevAcc)
                                        , valOff + w32_int valLen)|])
                          []
                    ]
                  ]))
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
funcName Inline
NoInline RuleMatch
FunLike Phases
AllPhases)
        , Name -> [Clause] -> Dec
FunD
              Name
funcName
              [ [Pat] -> Body -> [Dec] -> Clause
Clause
                    [ Name -> Pat
VarP Name
arr
                    , Name -> Pat
VarP Name
endOff
                    , [Pat] -> Pat
TupP [Name -> Pat
VarP Name
prevAcc, Name -> Pat
VarP Name
curOff]
                    , Name -> Pat
VarP Name
key
                    ]
                    (Exp -> Body
NormalB Exp
method)
                    []
              ]
        ]

    where

    fnames :: [Name]
fnames = (Field -> Name) -> [Field] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Name -> Name
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Name -> Name) -> (Field -> Maybe Name) -> Field -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Maybe Name
forall a b. (a, b) -> a
fst) [Field]
fields
    matchField :: Name -> Name -> (Name, Name) -> Name -> Q Match
    matchField :: Name -> Name -> (Name, Name) -> Name -> Q Match
matchField Name
arr Name
endOff (Name
acc, Name
currOff) Name
fname = do
        let fnameLit :: Lit
fnameLit = String -> Lit
StringL (Name -> String
nameBase Name
fname)
        Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
            (Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP Lit
fnameLit)
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                 [|do (valOff, valLen :: Word32) <-
                        deserializeAt
                            $(varE currOff)
                            $(varE arr)
                            $(varE endOff)
                      pure
                          ( ($(litE fnameLit), $(varE currOff)) : $(varE acc)
                          , valOff + w32_int valLen)|])
            []

mkDeserializeKeysDec :: Name -> Name -> SimpleDataCon -> Q [Dec]
mkDeserializeKeysDec :: Name -> Name -> SimpleDataCon -> Q [Dec]
mkDeserializeKeysDec Name
funcName Name
updateFunc (SimpleDataCon Name
cname [Field]
fields) = do
    Name
hOff <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"hOff"
    Name
finalOff <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"finalOff"
    Name
arr <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"arr"
    Name
endOff <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"endOff"
    Name
kvEncoded <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"kvEncoded"
    Name
finalRec <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"finalRec"
    let deserializeFieldExpr :: Field -> m Exp
deserializeFieldExpr (Just Name
name, Type
ty) = do
            let nameLit :: m Exp
nameLit = Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL (Name -> String
nameBase Name
name))
            [|case lookup $(nameLit) $(varE kvEncoded) of
                  Nothing -> $(emptyTy name ty)
                  Just off -> do
                      val <- deserializeWithSize off $(varE arr) $(varE endOff)
                      pure $ snd val|]
        deserializeFieldExpr Field
_ =
            String -> m Exp
forall a. String -> a
errorUnsupported String
"The datatype should use record syntax."
    Exp
method <-
        [|do (dataOff, hlist :: CompactList (CompactList Word8)) <-
                 deserializeAt $(varE hOff) $(varE arr) $(varE endOff)
             let keys = wListToString . unCompactList <$> unCompactList hlist
             ($(varP kvEncoded), _) <-
                 foldlM
                     ($(varE updateFunc) $(varE arr) $(varE endOff))
                     ([], dataOff)
                     keys
             $(varP finalRec) <-
                 $(foldl
                       (\acc i ->
                            [|$(acc) <*>
                              $(deserializeFieldExpr i)|])
                       [|pure $(conE cname)|]
                       fields)
             pure ($(varE finalOff), $(varE finalRec))|]
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
funcName Inline
NoInline RuleMatch
FunLike Phases
AllPhases)
        , Name -> [Clause] -> Dec
FunD
              Name
funcName
              [ [Pat] -> Body -> [Dec] -> Clause
Clause
                    [ Name -> Pat
VarP Name
hOff
                    , Name -> Pat
VarP Name
finalOff
                    , Name -> Pat
VarP Name
arr
                    , Name -> Pat
VarP Name
endOff
                    ]
                    (Exp -> Body
NormalB Exp
method)
                    []
              ]
        ]

    where

    emptyTy :: Name -> Type -> m Exp
emptyTy Name
k Type
ty =
        if Type -> Bool
isMaybeType Type
ty
            then [|pure Nothing|]
            else [|error $(litE (StringL (nameBase k ++ " is not found.")))|]


mkRecDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp
mkRecDeserializeExpr :: Name -> Name -> Name -> SimpleDataCon -> Q Exp
mkRecDeserializeExpr Name
initialOff Name
endOff Name
deserializeWithKeys SimpleDataCon
con = do
    Name
hOff <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"hOff"
    let  sizeForFinalOff :: Int
sizeForFinalOff = Int
4     -- Word32
         sizeForHeaderLength :: Int
sizeForHeaderLength = Int
4 -- Word32
         sizePreData :: Int
sizePreData = Int
sizeForFinalOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeForHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hlen
    [|do (hlenOff, encLen :: Word32) <-
             deserializeAt $(varE initialOff) $(varE _arr) $(varE endOff)
         ($(varP hOff), hlen1 :: Word32) <-
             deserializeAt hlenOff $(varE _arr) $(varE endOff)
         if (hlen1 == $(litIntegral hlen)) && $(xorCmp hval hOff _arr)
         then do
             let $(varP (makeI 0)) =
                     $(varE initialOff) +
                     $(litIntegral sizePreData)
             $(mkDeserializeExprOne 'deserializeWithSize con)
         else $(varE deserializeWithKeys)
                  $(varE hOff)
                  ($(varE initialOff) + w32_int encLen)
                  $(varE _arr)
                  $(varE endOff)|]

    where

    hval :: [Word8]
hval = SimpleDataCon -> [Word8]
headerValue SimpleDataCon
con
    hlen :: Int
hlen = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
hval