{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Streamly.Internal.Data.Serialize.TH.Bottom
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
module Streamly.Internal.Data.Serialize.TH.Bottom
    (
    -- ** Config
      SerializeConfig(..)
    , serializeConfig
    , inlineAddSizeTo
    , inlineSerializeAt
    , inlineDeserializeAt
    , encodeConstrNames
    , encodeRecordFields

    -- ** Other Utilities
    , TypeOfType(..)
    , typeOfType
    , SimpleDataCon(..)
    , simplifyDataCon
    , Field
    , mkFieldName
    , isUnitType
    , isRecordSyntax
    , c2w
    , wListToString
    , xorCmp
    , serializeW8List
    , litIntegral
    , litProxy
    , matchConstructor
    , openConstructor
    , makeI
    , makeN
    , makeA
    , int_w8
    , int_w32
    , w32_int
    , w8_int
    , _acc
    , _arr
    , _endOffset
    , _initialOffset
    , _x
    , _tag
    , _val
    , errorUnsupported
    , errorUnimplemented
    ) where

import Data.Maybe (isJust)
import Data.Char (chr, ord)
import Data.List (foldl')
import Data.Word (Word16, Word32, Word64, Word8)
import Data.Bits (Bits, (.|.), shiftL, zeroBits, xor)
import Streamly.Internal.System.IO (unsafeInlineIO)
import Streamly.Internal.Data.Unbox (Unbox)
import Data.Proxy (Proxy)

import Language.Haskell.TH
import Streamly.Internal.Data.Serialize.Type

import qualified Streamly.Internal.Data.Unbox as Unbox

import Streamly.Internal.Data.Unbox.TH (DataCon(..))

--------------------------------------------------------------------------------
-- Config
--------------------------------------------------------------------------------

-- NOTE: 'Nothing' is not eqvivalant to 'Just Inlinable'. Ie. Having no inline
-- specific pragma and having an Inlinable pragma are different. Having an
-- Inlinable pragma makes GHC put the code in the interface file whereas having
-- no inline specific pragma let's GHC decide whether to put the code in
-- interface file or not.

-- | Configuration to control how the 'Serialize' instance is generated. The
-- configuration is opaque and is modified by composing config modifier
-- functions, for example:
--
-- >>> (inlineSerializeAt (Just NoInline)) . (inlineSerializeAt (Just Inlinable))
--
-- The default configuration settings are:
--
-- * 'inlineAddSizeTo' Nothing
-- * 'inlineSerializeAt' (Just Inline)
-- * 'inlineDeserializeAt' (Just Inline)
--
-- The following experimental options are also available:
--
-- * 'encodeConstrNames' False
-- * 'encodeRecordFields' False
--
data SerializeConfig =
    SerializeConfig
        { SerializeConfig -> Maybe Inline
cfgInlineSize :: Maybe Inline
        , SerializeConfig -> Maybe Inline
cfgInlineSerialize :: Maybe Inline
        , SerializeConfig -> Maybe Inline
cfgInlineDeserialize :: Maybe Inline
        , SerializeConfig -> Bool
cfgConstructorTagAsString :: Bool
        , SerializeConfig -> Bool
cfgRecordSyntaxWithHeader :: Bool
        }

-- | How should we inline the 'addSizeTo' function? The default is 'Nothing'
-- which means left to the compiler. Forcing inline on @addSizeTo@ function
-- actually worsens some benchmarks and improves none.
inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineAddSizeTo Maybe Inline
v SerializeConfig
cfg = SerializeConfig
cfg {cfgInlineSize :: Maybe Inline
cfgInlineSize = Maybe Inline
v}

-- XXX Should we make the default Inlinable instead?

-- | How should we inline the 'serialize' function? The default 'Just Inline'.
-- However, aggressive inlining can bloat the code and increase in compilation
-- times when there are big functions and too many nesting levels so you can
-- change it accordingly. A 'Nothing' value leaves the decision to the
-- compiler.
inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineSerializeAt Maybe Inline
v SerializeConfig
cfg = SerializeConfig
cfg {cfgInlineSerialize :: Maybe Inline
cfgInlineSerialize = Maybe Inline
v}

-- XXX Should we make the default Inlinable instead?

-- | How should we inline the 'deserialize' function? See guidelines in
-- 'inlineSerializeAt'.
inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineDeserializeAt Maybe Inline
v SerializeConfig
cfg = SerializeConfig
cfg {cfgInlineDeserialize :: Maybe Inline
cfgInlineDeserialize = Maybe Inline
v}

-- | __Experimental__
--
-- In sum types, use Latin-1 encoded original constructor names rather than
-- binary values to identify constructors. This option is not applicable to
-- product types.
--
-- This option enables the following behavior:
--
-- * __Reordering__: Order of the fields can be changed without affecting
-- serialization.
-- * __Addition__: If a field is added in the new version, the old version of
-- the data type can still be deserialized by the new version. The new value
-- would never occur in the old one.
-- * __Deletion__: If a field is deleted in the new version, deserialization
-- of the old version will result in an error. TBD: We can possibly designate a
-- catch-all case to handle this scenario.
--
-- Note that if you change a type, change the semantics of a type, or delete a
-- field and add a new field with the same name, deserialization of old data
-- may result in silent unexpected behavior.
--
-- This option has to be the same on both encoding and decoding side.
--
-- The default is 'False'.
--
encodeConstrNames :: Bool -> SerializeConfig -> SerializeConfig
encodeConstrNames :: Bool -> SerializeConfig -> SerializeConfig
encodeConstrNames Bool
v SerializeConfig
cfg = SerializeConfig
cfg {cfgConstructorTagAsString :: Bool
cfgConstructorTagAsString = Bool
v}

-- XXX We can deserialize each field to Either, so if there is a
-- deserialization error in any field it can handled independently. Also, a
-- unique type/version identifier of the field (based on the versions of the
-- packages, full module name space + type identifier) can be serialized along
-- with the value for stricter compatibility, semantics checking. Or we can
-- store a type hash.

-- | __Experimental__
--
-- In explicit record types, use Latin-1 encoded record field names rather than
-- binary values to identify the record fields. Note that this option is not
-- applicable to sum types. Also, it does not work on a product type which is
-- not a record, because there are no field names to begin with.
--
-- This option enables the following behavior:
--
-- * __Reordering__: Order of the fields can be changed without affecting
-- serialization.
-- * __Addition__: If a 'Maybe' type field is added in the new version, the old
-- version of the data type can still be deserialized by the new version, the
-- field value in the older version is assumed to be 'Nothing'. If any other
-- type of field is added, deserialization of the older version results in an
-- error but only when that field is actually accessed in the deserialized
-- record.
-- * __Deletion__: If a field is deleted in the new version and it is
-- encountered in a previously serialized version then the field is discarded.
--
-- This option has to be the same on both encoding and decoding side.
--
-- There is a constant performance overhead proportional to the total length of
-- the record field names and the number of record fields.
--
-- The default is 'False'.
--
encodeRecordFields :: Bool -> SerializeConfig -> SerializeConfig
encodeRecordFields :: Bool -> SerializeConfig -> SerializeConfig
encodeRecordFields Bool
v SerializeConfig
cfg = SerializeConfig
cfg {cfgRecordSyntaxWithHeader :: Bool
cfgRecordSyntaxWithHeader = Bool
v}

serializeConfig :: SerializeConfig
serializeConfig :: SerializeConfig
serializeConfig =
    SerializeConfig :: Maybe Inline
-> Maybe Inline -> Maybe Inline -> Bool -> Bool -> SerializeConfig
SerializeConfig
        { cfgInlineSize :: Maybe Inline
cfgInlineSize = Maybe Inline
forall a. Maybe a
Nothing
        , cfgInlineSerialize :: Maybe Inline
cfgInlineSerialize = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
Inline
        , cfgInlineDeserialize :: Maybe Inline
cfgInlineDeserialize = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
Inline
        , cfgConstructorTagAsString :: Bool
cfgConstructorTagAsString = Bool
False
        , cfgRecordSyntaxWithHeader :: Bool
cfgRecordSyntaxWithHeader = Bool
False
        }

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

type Field = (Maybe Name, Type)

_x :: Name
_x :: Name
_x = String -> Name
mkName String
"x"

_acc :: Name
_acc :: Name
_acc = String -> Name
mkName String
"acc"

_arr :: Name
_arr :: Name
_arr = String -> Name
mkName String
"arr"

_tag :: Name
_tag :: Name
_tag = String -> Name
mkName String
"tag"

_initialOffset :: Name
_initialOffset :: Name
_initialOffset = String -> Name
mkName String
"initialOffset"

_endOffset :: Name
_endOffset :: Name
_endOffset = String -> Name
mkName String
"endOffset"

_val :: Name
_val :: Name
_val = String -> Name
mkName String
"val"

mkFieldName :: Int -> Name
mkFieldName :: Int -> Name
mkFieldName Int
i = String -> Name
mkName (String
"field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)

makeI :: Int -> Name
makeI :: Int -> Name
makeI Int
i = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

makeN :: Int -> Name
makeN :: Int -> Name
makeN Int
i = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

makeA :: Int -> Name
makeA :: Int -> Name
makeA Int
i = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

--------------------------------------------------------------------------------
-- Domain specific helpers
--------------------------------------------------------------------------------

openConstructor :: Name -> Int -> Q Pat
openConstructor :: Name -> Int -> Q Pat
openConstructor Name
cname Int
numFields =
    Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cname ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ((Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
mkFieldName [Int
0 .. (Int
numFields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]))

matchConstructor :: Name -> Int -> Q Exp -> Q Match
matchConstructor :: Name -> Int -> Q Exp -> Q Match
matchConstructor Name
cname Int
numFields Q Exp
exp0 =
    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> Int -> Q Pat
openConstructor Name
cname Int
numFields) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
exp0) []

--------------------------------------------------------------------------------
-- Constructor types
--------------------------------------------------------------------------------

data SimpleDataCon =
    SimpleDataCon Name [Field]
    deriving (SimpleDataCon -> SimpleDataCon -> Bool
(SimpleDataCon -> SimpleDataCon -> Bool)
-> (SimpleDataCon -> SimpleDataCon -> Bool) -> Eq SimpleDataCon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleDataCon -> SimpleDataCon -> Bool
$c/= :: SimpleDataCon -> SimpleDataCon -> Bool
== :: SimpleDataCon -> SimpleDataCon -> Bool
$c== :: SimpleDataCon -> SimpleDataCon -> Bool
Eq)

simplifyDataCon :: DataCon -> SimpleDataCon
simplifyDataCon :: DataCon -> SimpleDataCon
simplifyDataCon (DataCon Name
cname [Name]
_ Cxt
_ [Field]
fields) = Name -> [Field] -> SimpleDataCon
SimpleDataCon Name
cname [Field]
fields

data TypeOfType
    = UnitType Name             -- 1 constructor and 1 field
    | TheType SimpleDataCon      -- 1 constructor and 1+ fields
    | MultiType [SimpleDataCon] -- 1+ constructors
    deriving (TypeOfType -> TypeOfType -> Bool
(TypeOfType -> TypeOfType -> Bool)
-> (TypeOfType -> TypeOfType -> Bool) -> Eq TypeOfType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeOfType -> TypeOfType -> Bool
$c/= :: TypeOfType -> TypeOfType -> Bool
== :: TypeOfType -> TypeOfType -> Bool
$c== :: TypeOfType -> TypeOfType -> Bool
Eq)

typeOfType :: Type -> [DataCon] -> TypeOfType
typeOfType :: Type -> [DataCon] -> TypeOfType
typeOfType Type
headTy [] =
    String -> TypeOfType
forall a. HasCallStack => String -> a
error
        (String
"Attempting to get size with no constructors (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
         (Type -> String
forall a. Ppr a => a -> String
pprint Type
headTy) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
typeOfType Type
_ [DataCon Name
cname [Name]
_ Cxt
_ []] = Name -> TypeOfType
UnitType Name
cname
typeOfType Type
_ [con :: DataCon
con@(DataCon Name
_ [Name]
_ Cxt
_ [Field]
_)] = SimpleDataCon -> TypeOfType
TheType (SimpleDataCon -> TypeOfType) -> SimpleDataCon -> TypeOfType
forall a b. (a -> b) -> a -> b
$ DataCon -> SimpleDataCon
simplifyDataCon DataCon
con
typeOfType Type
_ [DataCon]
cons = [SimpleDataCon] -> TypeOfType
MultiType ([SimpleDataCon] -> TypeOfType) -> [SimpleDataCon] -> TypeOfType
forall a b. (a -> b) -> a -> b
$ (DataCon -> SimpleDataCon) -> [DataCon] -> [SimpleDataCon]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> SimpleDataCon
simplifyDataCon [DataCon]
cons

isUnitType :: [DataCon] -> Bool
isUnitType :: [DataCon] -> Bool
isUnitType [DataCon Name
_ [Name]
_ Cxt
_ []] = Bool
True
isUnitType [DataCon]
_ = Bool
False

isRecordSyntax :: SimpleDataCon -> Bool
isRecordSyntax :: SimpleDataCon -> Bool
isRecordSyntax (SimpleDataCon Name
_ [Field]
fields) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> (Field -> Maybe Name) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Maybe Name
forall a b. (a, b) -> a
fst (Field -> Bool) -> [Field] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field]
fields)

--------------------------------------------------------------------------------
-- Type casting
--------------------------------------------------------------------------------

int_w8 :: Int -> Word8
int_w8 :: Int -> Word8
int_w8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

int_w32 :: Int -> Word32
int_w32 :: Int -> Word32
int_w32 = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

w8_w16 :: Word8 -> Word16
w8_w16 :: Word8 -> Word16
w8_w16 = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

w8_w32 :: Word8 -> Word32
w8_w32 :: Word8 -> Word32
w8_w32 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

w8_w64 :: Word8 -> Word64
w8_w64 :: Word8 -> Word64
w8_w64 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

w8_int :: Word8 -> Int
w8_int :: Word8 -> Int
w8_int = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

w32_int :: Word32 -> Int
w32_int :: Word32 -> Int
w32_int = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

c2w :: Char -> Word8
c2w :: Char -> Word8
c2w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

wListToString :: [Word8] -> String
wListToString :: [Word8] -> String
wListToString = (Word8 -> Char) -> [Word8] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

--------------------------------------------------------------------------------
-- Bit manipulation
--------------------------------------------------------------------------------

shiftAdd :: Bits a => (b -> a) -> [b] -> a
shiftAdd :: forall a b. Bits a => (b -> a) -> [b] -> a
shiftAdd b -> a
conv [b]
xs =
    (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Bits a => a -> a -> a
(.|.) a
forall a. Bits a => a
zeroBits ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$
    ((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
j, a
x) -> a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftL a
x (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) ([(Int, a)] -> [a]) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ([a] -> [(Int, a)]) -> [a] -> [(Int, a)]
forall a b. (a -> b) -> a -> b
$ (b -> a) -> [b] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map b -> a
conv [b]
xs

-- Note: This only works in little endian machines
-- TODO:
-- Instead of generating this via TH can't we write it directly in Haskell and
-- use that? Creating one comparison function for each deserialization may be
-- too much code and may not be necessary.
-- Benchmark both the implementations and check.
xorCmp :: [Word8] -> Name -> Name -> Q Exp
xorCmp :: [Word8] -> Name -> Name -> Q Exp
xorCmp [Word8]
tag Name
off Name
arr =
    case Int
tagLen of
        Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -> [|$(go8 0) == zeroBits|]
        Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> [|$(go16 0) == zeroBits|]
        Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 -> [|$(go32 0) == zeroBits|]
        Int
_ -> [|$(go64 0) == zeroBits|]
  where
    tagLen :: Int
tagLen = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
tag
    go8 :: Int -> Q Exp
go8 Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tagLen = [|zeroBits|]
    go8 Int
i = do
        let wIntegral :: Q Exp
wIntegral = Int -> Q Exp
forall a. Integral a => a -> Q Exp
litIntegral Int
i
        [|xor (unsafeInlineIO
                   (Unbox.peekAt
                        ($(varE off) + $(litIntegral i))
                        $(varE arr)))
              ($(wIntegral) :: Word8) .|.
          $(go8 (i + 1))|]
    go16 :: Int -> Q Exp
go16 Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tagLen = [|zeroBits|]
    go16 Int
i
        | Int
tagLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Int -> Q Exp
go16 (Int
tagLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
    go16 Int
i = do
        let wIntegral :: Q Exp
wIntegral =
                Word16 -> Q Exp
forall a. Integral a => a -> Q Exp
litIntegral
                    ((Word8 -> Word16) -> [Word8] -> Word16
forall a b. Bits a => (b -> a) -> [b] -> a
shiftAdd Word8 -> Word16
w8_w16 [[Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! Int
i, [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)] :: Word16)
        [|xor (unsafeInlineIO
                   (Unbox.peekAt
                        ($(varE off) + $(litIntegral i))
                        $(varE arr)))
              ($(wIntegral) :: Word16) .|.
          $(go16 (i + 2))|]
    go32 :: Int -> Q Exp
go32 Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tagLen = [|zeroBits|]
    go32 Int
i
        | Int
tagLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 = Int -> Q Exp
go32 (Int
tagLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
    go32 Int
i = do
        let wIntegral :: Q Exp
wIntegral =
                Word32 -> Q Exp
forall a. Integral a => a -> Q Exp
litIntegral
                    ((Word8 -> Word32) -> [Word8] -> Word32
forall a b. Bits a => (b -> a) -> [b] -> a
shiftAdd
                         Word8 -> Word32
w8_w32
                         [ [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! Int
i
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                         ] :: Word32)
        [|xor (unsafeInlineIO
                   (Unbox.peekAt
                        ($(varE off) + $(litIntegral i))
                        $(varE arr)))
              ($(wIntegral) :: Word32) .|.
          $(go32 (i + 4))|]
    go64 :: Int -> Q Exp
go64 Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tagLen = [|zeroBits|]
    go64 Int
i
        | Int
tagLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 = Int -> Q Exp
go64 (Int
tagLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)
    go64 Int
i = do
        let wIntegral :: Q Exp
wIntegral =
                Word64 -> Q Exp
forall a. Integral a => a -> Q Exp
litIntegral
                    ((Word8 -> Word64) -> [Word8] -> Word64
forall a b. Bits a => (b -> a) -> [b] -> a
shiftAdd
                         Word8 -> Word64
w8_w64
                         [ [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! Int
i
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6)
                         , [Word8]
tag [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7)
                         ])
        [|xor (unsafeInlineIO
                   (Unbox.peekAt
                        ($(varE off) + $(litIntegral i))
                        $(varE arr)))
              ($(wIntegral) :: Word64) .|.
          $(go64 (i + 8))|]

--------------------------------------------------------------------------------
-- Primitive serialization
--------------------------------------------------------------------------------

-- TODO:
-- Will this be too much of a code bloat?
-- Loop with the loop body unrolled?
-- Serialize this in batches similar to batch comparision in xorCmp?
serializeW8List :: Name -> Name -> [Word8] -> Q Exp
serializeW8List :: Name -> Name -> [Word8] -> Q Exp
serializeW8List Name
off Name
arr [Word8]
w8List = do
    [|let $(varP (makeN 0)) = $(varE off)
       in $(doE (fmap makeBind [0 .. (lenW8List - 1)] ++
                 [noBindS ([|pure $(varE (makeN lenW8List))|])]))|]

    where

    lenW8List :: Int
lenW8List = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
w8List
    makeBind :: Int -> Q Stmt
makeBind Int
i =
        Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS
            (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Int -> Name
makeN (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)))
            [|$(varE 'serializeAt)
                  $(varE (makeN i))
                  $(varE arr)
                  ($(litIntegral (w8List !! i)) :: Word8)|]

--------------------------------------------------------------------------------
-- TH Helpers
--------------------------------------------------------------------------------

litIntegral :: Integral a => a -> Q Exp
litIntegral :: forall a. Integral a => a -> Q Exp
litIntegral = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (a -> Lit) -> a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (a -> Integer) -> a -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

litProxy :: Unbox a => Proxy a -> Q Exp
litProxy :: forall a. Unbox a => Proxy a -> Q Exp
litProxy = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (Proxy a -> Lit) -> Proxy a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Proxy a -> Integer) -> Proxy a -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Proxy a -> Int) -> Proxy a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Int
forall a. Unbox a => Proxy a -> Int
Unbox.sizeOf

--------------------------------------------------------------------------------
-- Error codes
--------------------------------------------------------------------------------

errorUnsupported :: String -> a
errorUnsupported :: forall a. String -> a
errorUnsupported String
err =
    String -> a
forall a. HasCallStack => String -> a
error
        (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
              [ String
"Unsupported"
              , String
"==========="
              , String
"This is improper use of the library."
              , String
"This case is unsupported."
              , String
"Please contact the developer if this case is of interest."
              , String
""
              , String
"Message"
              , String
"-------"
              , String
err
              ]

errorUnimplemented :: a
errorUnimplemented :: forall a. a
errorUnimplemented =
    String -> a
forall a. HasCallStack => String -> a
error
        (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
              [ String
"Unimplemented"
              , String
"============="
              , String
"Please contact the developer if this case is of interest."
              ]