{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Streamly.Internal.Data.Serialize.TH
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
module Streamly.Internal.Data.Serialize.TH
    (
    -- Deriving
      deriveSerialize
    , deriveSerializeWith

    -- Utilities
    , module Streamly.Internal.Data.Serialize.TH.Bottom
    -- ** Common
    , module Streamly.Internal.Data.Serialize.TH.Common
    -- ** RecHeader
    , module Streamly.Internal.Data.Serialize.TH.RecHeader
    ) where

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

import Data.List (foldl')
import Data.Word (Word16, Word32, Word64, Word8)

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

import Streamly.Internal.Data.Unbox.TH
    ( DataCon(..)
    , DataType(..)
    , reifyDataType
    )

import qualified Streamly.Internal.Data.Serialize.TH.RecHeader as RecHeader

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

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

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))|]

getTagSize :: Int -> Int
getTagSize :: Int -> Int
getTagSize Int
numConstructors
    | Int
numConstructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
0
    | Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = Int
1
    | Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = Int
2
    | Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = Int
4
    | Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = Int
8
    | Bool
otherwise = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Too many constructors"

getTagType :: Int -> Name
getTagType :: Int -> Name
getTagType Int
numConstructors
    | Int
numConstructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"No tag for 1 constructor"
    | Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = ''Word8
    | Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = ''Word16
    | Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = ''Word32
    | Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numConstructors = ''Word64
    | Bool
otherwise = [Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"Too many constructors"

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

getNameBaseLen :: Name -> Word8
getNameBaseLen :: Name -> Word8
getNameBaseLen Name
cname =
    let x :: Int
x = [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Name -> [Char]
nameBase Name
cname)
     in if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
63
        then [Char] -> Word8
forall a. HasCallStack => [Char] -> a
error [Char]
"Max Constructor Len: 63 characters"
        else Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x

conEncLen :: Name -> Word8
conEncLen :: Name -> Word8
conEncLen Name
cname = Name -> Word8
getNameBaseLen Name
cname Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
1

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

mkSizeOfExpr :: Bool -> Bool -> TypeOfType -> Q Exp
mkSizeOfExpr :: Bool -> Bool -> TypeOfType -> Q Exp
mkSizeOfExpr Bool
True Bool
False TypeOfType
tyOfTy =
    case TypeOfType
tyOfTy of
        UnitType Name
cname ->
            [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
_acc, Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP]
                [|$(varE _acc) + $(litIntegral (conEncLen cname))|]
        TheType SimpleDataCon
con ->
            [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
_acc, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_x]
                (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
_x) [Q Exp -> SimpleDataCon -> Q Match
matchCons (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_acc) SimpleDataCon
con])
        MultiType [SimpleDataCon]
constructors -> [SimpleDataCon] -> Q Exp
sizeOfHeadDt [SimpleDataCon]
constructors

    where

    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 a :: Q Exp
a = Word8 -> Q Exp
forall a. Integral a => a -> Q Exp
litIntegral (Name -> Word8
conEncLen Name
cname)
            b :: Q Exp
b = 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)
            expr :: Q Exp
expr = [|$(a) + $(b)|]
         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

    sizeOfHeadDt :: [SimpleDataCon] -> Q Exp
sizeOfHeadDt [SimpleDataCon]
cons =
        let acc :: Q Exp
acc = [|$(varE _acc)|]
         in [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
_acc, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_x]
                (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
_x) ((SimpleDataCon -> Q Match) -> [SimpleDataCon] -> [Q Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Q Exp -> SimpleDataCon -> Q Match
matchCons Q Exp
acc) [SimpleDataCon]
cons))

mkSizeOfExpr Bool
False Bool
False TypeOfType
tyOfTy =
    case TypeOfType
tyOfTy of
        UnitType Name
_ -> [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
_acc, Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP] [|$(varE _acc) + 1|]
        TheType SimpleDataCon
con ->
            [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
_acc, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_x]
                (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
_x) [Q Exp -> SimpleDataCon -> Q Match
matchCons (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_acc) SimpleDataCon
con])
        MultiType [SimpleDataCon]
constructors -> [SimpleDataCon] -> Q Exp
sizeOfHeadDt [SimpleDataCon]
constructors

    where

    tagSizeExp :: Int -> m Exp
tagSizeExp Int
numConstructors =
        Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
IntegerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int
getTagSize Int
numConstructors)))

    -- XXX fields of the same type can be folded together, will reduce the code
    -- size when there are many fields of the same type.
    -- XXX const size fields can be calculated statically.
    -- XXX This can result in large compilation times due to nesting when there
    -- are many constructors. We can create a list and sum the list at run time
    -- to avoid that depending on the number of constructors. Or using a let
    -- statement for each case may help?
    -- appE (varE 'sum) (listE (acc : map (exprGetSize (litE (IntegerL 0))) (zip [0..] fields)))
    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

    -- XXX We fix VarSize for simplicity. Should be changed later.
    sizeOfHeadDt :: [SimpleDataCon] -> Q Exp
sizeOfHeadDt [SimpleDataCon]
cons =
        let numCons :: Int
numCons = [SimpleDataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SimpleDataCon]
cons
            acc :: Q Exp
acc = [|$(varE _acc) + $(tagSizeExp numCons)|]
         in [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
_acc, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_x]
                (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
_x) ((SimpleDataCon -> Q Match) -> [SimpleDataCon] -> [Q Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Q Exp -> SimpleDataCon -> Q Match
matchCons Q Exp
acc) [SimpleDataCon]
cons))

mkSizeOfExpr Bool
False Bool
True (TheType SimpleDataCon
con) = SimpleDataCon -> Q Exp
RecHeader.mkRecSizeOfExpr SimpleDataCon
con

mkSizeOfExpr Bool
_ Bool
_ TypeOfType
_ = Q Exp
forall a. a
errorUnimplemented

mkSizeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkSizeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkSizeDec (SerializeConfig {Bool
Maybe Inline
cfgRecordSyntaxWithHeader :: SerializeConfig -> Bool
cfgConstructorTagAsString :: SerializeConfig -> Bool
cfgInlineDeserialize :: SerializeConfig -> Maybe Inline
cfgInlineSerialize :: SerializeConfig -> Maybe Inline
cfgInlineSize :: SerializeConfig -> Maybe Inline
cfgRecordSyntaxWithHeader :: Bool
cfgConstructorTagAsString :: Bool
cfgInlineDeserialize :: Maybe Inline
cfgInlineSerialize :: Maybe Inline
cfgInlineSize :: Maybe Inline
..}) Type
headTy [DataCon]
cons = do
    -- INLINE on sizeOf actually worsens some benchmarks, and improves none
    Exp
sizeOfMethod <-
        Bool -> Bool -> TypeOfType -> Q Exp
mkSizeOfExpr
            Bool
cfgConstructorTagAsString
            Bool
cfgRecordSyntaxWithHeader
            (Type -> [DataCon] -> TypeOfType
typeOfType Type
headTy [DataCon]
cons)
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [Dec] -> (Inline -> [Dec]) -> Maybe Inline -> [Dec]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            (\Inline
x -> [Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'addSizeTo Inline
x RuleMatch
FunLike Phases
AllPhases)])
            Maybe Inline
cfgInlineSize
         [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Name -> [Clause] -> Dec
FunD 'addSizeTo [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
sizeOfMethod) []]]
        )

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

mkDeserializeExpr :: Bool -> Bool -> Type -> TypeOfType -> Q Exp
mkDeserializeExpr :: Bool -> Bool -> Type -> TypeOfType -> Q Exp
mkDeserializeExpr Bool
True Bool
False Type
headTy TypeOfType
tyOfTy =
    case TypeOfType
tyOfTy of
        UnitType Name
cname -> [SimpleDataCon] -> Q Exp
deserializeConsExpr [Name -> [Field] -> SimpleDataCon
SimpleDataCon Name
cname []]
        TheType SimpleDataCon
con -> [SimpleDataCon] -> Q Exp
deserializeConsExpr [SimpleDataCon
con]
        MultiType [SimpleDataCon]
cons -> [SimpleDataCon] -> Q Exp
deserializeConsExpr [SimpleDataCon]
cons

  where

    deserializeConsExpr :: [SimpleDataCon] -> Q Exp
deserializeConsExpr [SimpleDataCon]
cons = do
        Name
conLen <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"conLen"
        Name
off1 <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"off1"
        [|do ($(varP off1), $(varP conLen) :: Word8) <-
                 deserializeAt
                     $(varE _initialOffset)
                     $(varE _arr)
                     $(varE _endOffset)
             $(multiIfE (map (guardCon conLen off1) cons ++ [catchAll]))|]

    catchAll :: Q (Guard, Exp)
catchAll =
        Q Exp -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE
            [|True|]
            [|error
               ("Found invalid tag while peeking (" ++
                   $(lift (pprint headTy)) ++ ")")|]

    guardCon :: Name -> Name -> SimpleDataCon -> Q (Guard, Exp)
guardCon Name
conLen Name
off con :: SimpleDataCon
con@(SimpleDataCon Name
cname [Field]
_) = do
        let lenCname :: Word8
lenCname = Name -> Word8
getNameBaseLen Name
cname
            tag :: [Word8]
tag = (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
c2w (Name -> [Char]
nameBase Name
cname)
        Q Exp -> Q Exp -> Q (Guard, Exp)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE
            [|($(litIntegral lenCname) == $(varE conLen))
                   && $(xorCmp tag off _arr)|]
            [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
               in $(mkDeserializeExprOne 'deserializeAt con)|]

mkDeserializeExpr Bool
False Bool
False Type
headTy TypeOfType
tyOfTy =
    case TypeOfType
tyOfTy of
        -- Unit constructor
        -- XXX Should we peek and check if the byte value is 0?
        UnitType Name
cname ->
            [|pure ($(varE _initialOffset) + 1, $(conE cname))|]
        -- Product type
        TheType SimpleDataCon
con ->
            [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE
                [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Char] -> Name
mkName [Char]
"i0")) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_initialOffset)) []]
                (Name -> SimpleDataCon -> Q Exp
mkDeserializeExprOne 'deserializeAt SimpleDataCon
con)
        -- Sum type
        MultiType [SimpleDataCon]
cons -> do
            let lenCons :: Int
lenCons = [SimpleDataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SimpleDataCon]
cons
                tagType :: Name
tagType = Int -> Name
getTagType Int
lenCons
            [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE
                [ Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS
                      ([Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Char] -> Name
mkName [Char]
"i0"), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
_tag])
                      [|deserializeAt $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|]
                , Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS
                      (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                           (Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_tag) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tagType))
                           (((Integer, SimpleDataCon) -> Q Match)
-> [(Integer, SimpleDataCon)] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, SimpleDataCon) -> Q Match
peekMatch ([Integer] -> [SimpleDataCon] -> [(Integer, SimpleDataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] [SimpleDataCon]
cons) [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Match
peekErr]))
                ]
  where
    peekMatch :: (Integer, SimpleDataCon) -> Q Match
peekMatch (Integer
i, SimpleDataCon
con) =
        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 (Integer -> Lit
IntegerL Integer
i))
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> SimpleDataCon -> Q Exp
mkDeserializeExprOne 'deserializeAt SimpleDataCon
con)) []
    peekErr :: Q Match
peekErr =
        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
                -- XXX Print the tag
                 [|error
                       ("Found invalid tag while peeking (" ++
                        $(lift (pprint headTy)) ++ ")")|])
            []

mkDeserializeExpr Bool
False Bool
True Type
_ (TheType con :: SimpleDataCon
con@(SimpleDataCon Name
_ [Field]
fields)) = do
    Name
deserializeWithKeys <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"deserializeWithKeys"
    Name
updateFunc <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"updateFunc"
    [Dec]
updateFuncDec <- Name -> [Field] -> Q [Dec]
RecHeader.conUpdateFuncDec Name
updateFunc [Field]
fields
    [Dec]
deserializeWithKeysDec <-
        Name -> Name -> SimpleDataCon -> Q [Dec]
RecHeader.mkDeserializeKeysDec Name
deserializeWithKeys Name
updateFunc SimpleDataCon
con
    [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE
        (Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Dec]
deserializeWithKeysDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
updateFuncDec))
        (Name -> Name -> Name -> SimpleDataCon -> Q Exp
RecHeader.mkRecDeserializeExpr
             Name
_initialOffset
             Name
_endOffset
             Name
deserializeWithKeys
             SimpleDataCon
con)

mkDeserializeExpr Bool
_ Bool
_ Type
_ TypeOfType
_ = Q Exp
forall a. a
errorUnimplemented

mkDeserializeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkDeserializeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkDeserializeDec (SerializeConfig {Bool
Maybe Inline
cfgRecordSyntaxWithHeader :: Bool
cfgConstructorTagAsString :: Bool
cfgInlineDeserialize :: Maybe Inline
cfgInlineSerialize :: Maybe Inline
cfgInlineSize :: Maybe Inline
cfgRecordSyntaxWithHeader :: SerializeConfig -> Bool
cfgConstructorTagAsString :: SerializeConfig -> Bool
cfgInlineDeserialize :: SerializeConfig -> Maybe Inline
cfgInlineSerialize :: SerializeConfig -> Maybe Inline
cfgInlineSize :: SerializeConfig -> Maybe Inline
..}) Type
headTy [DataCon]
cons = do
    Exp
peekMethod <-
        Bool -> Bool -> Type -> TypeOfType -> Q Exp
mkDeserializeExpr
            Bool
cfgConstructorTagAsString
            Bool
cfgRecordSyntaxWithHeader
            Type
headTy
            (Type -> [DataCon] -> TypeOfType
typeOfType Type
headTy [DataCon]
cons)
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [Dec] -> (Inline -> [Dec]) -> Maybe Inline -> [Dec]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            (\Inline
x -> [Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'deserializeAt Inline
x RuleMatch
FunLike Phases
AllPhases)])
            Maybe Inline
cfgInlineDeserialize
         [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
            [ Name -> [Clause] -> Dec
FunD
              'deserializeAt
              [ [Pat] -> Body -> [Dec] -> Clause
Clause
                    (if [DataCon] -> Bool
isUnitType [DataCon]
cons Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cfgConstructorTagAsString
                         then [Name -> Pat
VarP Name
_initialOffset, Pat
WildP, Pat
WildP]
                         else [Name -> Pat
VarP Name
_initialOffset, Name -> Pat
VarP Name
_arr, Name -> Pat
VarP Name
_endOffset])
                    (Exp -> Body
NormalB Exp
peekMethod)
                    []
              ]
            ]
        )

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

mkSerializeExprTag :: Name -> Int -> Q Exp
mkSerializeExprTag :: Name -> Int -> Q Exp
mkSerializeExprTag Name
tagType Int
tagVal =
    [|serializeAt
          $(varE _initialOffset)
          $(varE _arr)
          $((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]

mkSerializeExpr :: Bool -> Bool -> TypeOfType -> Q Exp
mkSerializeExpr :: Bool -> Bool -> TypeOfType -> Q Exp
mkSerializeExpr Bool
True Bool
False TypeOfType
tyOfTy =
    case TypeOfType
tyOfTy of
        -- Unit type
        UnitType Name
cname ->
            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
_val)
                [SimpleDataCon -> Q Match
serializeDataCon (Name -> [Field] -> SimpleDataCon
SimpleDataCon Name
cname [])]
        -- Product type
        (TheType SimpleDataCon
con) ->
            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
_val)
                [SimpleDataCon -> Q Match
serializeDataCon SimpleDataCon
con]
        -- Sum type
        (MultiType [SimpleDataCon]
cons) ->
            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
_val)
                ((SimpleDataCon -> Q Match) -> [SimpleDataCon] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map SimpleDataCon -> Q Match
serializeDataCon [SimpleDataCon]
cons)

    where

    serializeDataCon :: SimpleDataCon -> Q Match
serializeDataCon (SimpleDataCon Name
cname [Field]
fields) = do
        let tagLen8 :: Word8
tagLen8 = Name -> Word8
getNameBaseLen Name
cname
            conEnc :: [Word8]
conEnc = Word8
tagLen8 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
c2w (Name -> [Char]
nameBase Name
cname)
        Name -> Int -> Q Exp -> Q Match
matchConstructor
            Name
cname
            ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fields)
            ([Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [ 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 ([Char] -> Name
mkName [Char]
"i0"))
                       (Name -> Name -> [Word8] -> Q Exp
serializeW8List Name
_initialOffset Name
_arr [Word8]
conEnc)
                 , Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Name -> [Field] -> Q Exp
mkSerializeExprFields 'serializeAt [Field]
fields)
                 ])

mkSerializeExpr Bool
False Bool
False TypeOfType
tyOfTy =
    case TypeOfType
tyOfTy of
        -- Unit type
        UnitType Name
_ ->
            [|serializeAt $(varE _initialOffset) $(varE _arr) (0 :: Word8)|]
        -- Product type
        (TheType (SimpleDataCon Name
cname [Field]
fields)) ->
            [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE
                [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Char] -> Name
mkName [Char]
"i0")) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
_initialOffset)) []]
                (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
_val)
                     [ Name -> Int -> Q Exp -> Q Match
matchConstructor
                           Name
cname
                           ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fields)
                           (Name -> [Field] -> Q Exp
mkSerializeExprFields 'serializeAt [Field]
fields)
                     ])
        -- Sum type
        (MultiType [SimpleDataCon]
cons) -> do
            let lenCons :: Int
lenCons = [SimpleDataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SimpleDataCon]
cons
                tagType :: Name
tagType = Int -> Name
getTagType Int
lenCons
            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
_val)
                (((Int, SimpleDataCon) -> Q Match)
-> [(Int, SimpleDataCon)] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
tagVal, (SimpleDataCon Name
cname [Field]
fields)) ->
                          Name -> Int -> Q Exp -> Q Match
matchConstructor
                              Name
cname
                              ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
fields)
                              ([Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE [ 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 ([Char] -> Name
mkName [Char]
"i0"))
                                         (Name -> Int -> Q Exp
mkSerializeExprTag Name
tagType Int
tagVal)
                                   , Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS
                                         (Name -> [Field] -> Q Exp
mkSerializeExprFields
                                              'serializeAt
                                              [Field]
fields)
                                   ]))
                     ([Int] -> [SimpleDataCon] -> [(Int, SimpleDataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [SimpleDataCon]
cons))

mkSerializeExpr Bool
False Bool
True (TheType SimpleDataCon
con) =
    Name -> SimpleDataCon -> Q Exp
RecHeader.mkRecSerializeExpr Name
_initialOffset SimpleDataCon
con

mkSerializeExpr Bool
_ Bool
_ TypeOfType
_ = Q Exp
forall a. a
errorUnimplemented

mkSerializeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkSerializeDec :: SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkSerializeDec (SerializeConfig {Bool
Maybe Inline
cfgRecordSyntaxWithHeader :: Bool
cfgConstructorTagAsString :: Bool
cfgInlineDeserialize :: Maybe Inline
cfgInlineSerialize :: Maybe Inline
cfgInlineSize :: Maybe Inline
cfgRecordSyntaxWithHeader :: SerializeConfig -> Bool
cfgConstructorTagAsString :: SerializeConfig -> Bool
cfgInlineDeserialize :: SerializeConfig -> Maybe Inline
cfgInlineSerialize :: SerializeConfig -> Maybe Inline
cfgInlineSize :: SerializeConfig -> Maybe Inline
..}) Type
headTy [DataCon]
cons = do
    Exp
pokeMethod <-
        Bool -> Bool -> TypeOfType -> Q Exp
mkSerializeExpr
            Bool
cfgConstructorTagAsString
            Bool
cfgRecordSyntaxWithHeader
            (Type -> [DataCon] -> TypeOfType
typeOfType Type
headTy [DataCon]
cons)
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [Dec] -> (Inline -> [Dec]) -> Maybe Inline -> [Dec]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            (\Inline
x -> [Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'serializeAt Inline
x RuleMatch
FunLike Phases
AllPhases)])
            Maybe Inline
cfgInlineSerialize
         [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
            [Name -> [Clause] -> Dec
FunD
                  'serializeAt
                  [ [Pat] -> Body -> [Dec] -> Clause
Clause
                        (if [DataCon] -> Bool
isUnitType [DataCon]
cons Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cfgConstructorTagAsString
                             then [Name -> Pat
VarP Name
_initialOffset, Name -> Pat
VarP Name
_arr, Pat
WildP]
                             else [Name -> Pat
VarP Name
_initialOffset, Name -> Pat
VarP Name
_arr, Name -> Pat
VarP Name
_val])
                        (Exp -> Body
NormalB Exp
pokeMethod)
                        []
                  ]
            ]
        )

--------------------------------------------------------------------------------
-- Main
--------------------------------------------------------------------------------

-- | A general function to derive Serialize instances where you can control
-- which Constructors of the datatype to consider and what the Context for the
-- 'Serialize' instance would be.
--
-- Consider the datatype:
-- @
-- data CustomDataType a b
--     = CDTConstructor1
--     | CDTConstructor2 Bool
--     | CDTConstructor3 Bool b
--     deriving (Show, Eq)
-- @
--
-- Usage:
-- @
-- $(deriveSerializeInternal
--       serializeConfig
--       [AppT (ConT ''Serialize) (VarT (mkName "b"))]
--       (AppT
--            (AppT (ConT ''CustomDataType) (VarT (mkName "a")))
--            (VarT (mkName "b")))
--       [ DataCon 'CDTConstructor1 [] [] []
--       , DataCon 'CDTConstructor2 [] [] [(Nothing, (ConT ''Bool))]
--       , DataCon
--             'CDTConstructor3
--             []
--             []
--             [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))]
--       ])
-- @
deriveSerializeInternal ::
       SerializeConfig -> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
deriveSerializeInternal :: SerializeConfig
-> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
deriveSerializeInternal SerializeConfig
conf Type
headTy [DataCon]
cons [Dec] -> Q [Dec]
next = do
    [Dec]
sizeDec <- SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkSizeDec SerializeConfig
conf Type
headTy [DataCon]
cons
    [Dec]
peekDec <- SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkDeserializeDec SerializeConfig
conf Type
headTy [DataCon]
cons
    [Dec]
pokeDec <- SerializeConfig -> Type -> [DataCon] -> Q [Dec]
mkSerializeDec SerializeConfig
conf Type
headTy [DataCon]
cons
    let methods :: [Dec]
methods = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
sizeDec, [Dec]
peekDec, [Dec]
pokeDec]
    [Dec] -> Q [Dec]
next [Dec]
methods

-- | @deriveSerializeWith config-modifier instance-dec@ generates a template
-- Haskell splice consisting of a declaration of a 'Serialize' instance.
-- @instance-dec@ is a template Haskell declaration splice consisting of a
-- standard Haskell instance declaration without the type class methods (e.g.
-- @[d|instance Serialize a => Serialize (Maybe a)|]@).
--
-- The type class methods for the given instance are generated according to the
-- supplied @config-modifier@ parameter. See 'SerializeConfig' for default
-- configuration settings.
--
-- Usage:
--
-- @
-- \$(deriveSerializeWith
--       ( inlineSerializeAt (Just NoInline)
--       . inlineDeserializeAt (Just NoInline)
--       )
--       [d|instance Serialize a => Serialize (Maybe a)|])
-- @
deriveSerializeWith ::
    (SerializeConfig -> SerializeConfig) -> Q [Dec] -> Q [Dec]
deriveSerializeWith :: (SerializeConfig -> SerializeConfig) -> Q [Dec] -> Q [Dec]
deriveSerializeWith SerializeConfig -> SerializeConfig
modifier Q [Dec]
mDecs = do
    [Dec]
dec <- Q [Dec]
mDecs
    case [Dec]
dec of
        [InstanceD Maybe Overlap
mo [Type]
preds Type
headTyWC []] -> do
            let headTy :: Type
headTy = [Dec] -> Type -> Type
forall {a}. Ppr a => a -> Type -> Type
unwrap [Dec]
dec Type
headTyWC
            DataType
dt <- Name -> Q DataType
reifyDataType ([Dec] -> Type -> Name
forall {p}. Ppr p => p -> Type -> Name
getMainTypeName [Dec]
dec Type
headTy)
            let cons :: [DataCon]
cons = DataType -> [DataCon]
dtCons DataType
dt
            SerializeConfig
-> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
deriveSerializeInternal
                (SerializeConfig -> SerializeConfig
modifier SerializeConfig
serializeConfig) Type
headTy [DataCon]
cons (Maybe Overlap -> [Type] -> Type -> [Dec] -> Q [Dec]
forall {f :: * -> *}.
Applicative f =>
Maybe Overlap -> [Type] -> Type -> [Dec] -> f [Dec]
next Maybe Overlap
mo [Type]
preds Type
headTyWC)
        [Dec]
_ -> [Dec] -> Q [Dec]
forall {a} {a}. Ppr a => a -> a
errorMessage [Dec]
dec

    where

    next :: Maybe Overlap -> [Type] -> Type -> [Dec] -> f [Dec]
next Maybe Overlap
mo [Type]
preds Type
headTyWC [Dec]
methods = [Dec] -> f [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
mo [Type]
preds Type
headTyWC [Dec]
methods]

    errorMessage :: a -> a
errorMessage a
dec =
        [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
            [ [Char]
"Error: deriveSerializeWith:"
            , [Char]
""
            , [Char]
">> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Ppr a => a -> [Char]
pprint a
dec
            , [Char]
""
            , [Char]
"The supplied declaration is not a valid instance declaration."
            , [Char]
"Provide a valid Haskell instance declaration without a body."
            , [Char]
""
            , [Char]
"Examples:"
            , [Char]
"instance Serialize (Proxy a)"
            , [Char]
"instance Serialize a => Serialize (Identity a)"
            , [Char]
"instance Serialize (TableT Identity)"
            ]

    unwrap :: a -> Type -> Type
unwrap a
_ (AppT (ConT Name
_) Type
r) = Type
r
    unwrap a
dec Type
_ = a -> Type
forall {a} {a}. Ppr a => a -> a
errorMessage a
dec

    getMainTypeName :: p -> Type -> Name
getMainTypeName p
dec = Type -> Name
go

        where

        go :: Type -> Name
go (ConT Name
nm) = Name
nm
        go (AppT Type
l Type
_) = Type -> Name
go Type
l
        go Type
_ = p -> Name
forall {a} {a}. Ppr a => a -> a
errorMessage p
dec

-- | Given an 'Serialize' instance declaration splice without the methods (e.g.
-- @[d|instance Serialize a => Serialize (Maybe a)|]@), generate an instance
-- declaration including all the type class method implementations.
--
-- >>> deriveSerialize = deriveSerializeWith id
--
-- Usage:
--
-- @
-- \$(deriveSerialize
--       [d|instance Serialize a => Serialize (Maybe a)|])
-- @
deriveSerialize :: Q [Dec] -> Q [Dec]
deriveSerialize :: Q [Dec] -> Q [Dec]
deriveSerialize = (SerializeConfig -> SerializeConfig) -> Q [Dec] -> Q [Dec]
deriveSerializeWith SerializeConfig -> SerializeConfig
forall a. a -> a
id