module DomainCereal.TH where

import qualified Data.Serialize as Cereal
import qualified Data.Serialize.LEB128.Lenient as Leb128
import DomainCereal.Prelude
import qualified DomainCore.Model as Model
import qualified DomainCore.TH as DomainTH
import Language.Haskell.TH.Syntax
import THLego.Helpers
import qualified THLego.Lambdas as Lambdas
import qualified TemplateHaskell.Compat.V0208 as Compat

-- *

serializeInstanceD :: Model.TypeDec -> Dec
serializeInstanceD :: TypeDec -> Dec
serializeInstanceD (Model.TypeDec Text
typeName TypeDef
typeDef) =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
headType [Dec
putFunD, Dec
getFunD]
  where
    headType :: Type
headType =
      Type -> Type -> Type
AppT (Name -> Type
ConT ''Cereal.Serialize) (Name -> Type
ConT (Text -> Name
textName Text
typeName))
    (Dec
putFunD, Dec
getFunD) =
      case TypeDef
typeDef of
        Model.SumTypeDef [(Text, [Type])]
members ->
          ([(Name, Int)] -> Dec
sumPutFunD [(Name, Int)]
preparedMembers, [(Name, Int)] -> Dec
sumGetFunD [(Name, Int)]
preparedMembers)
          where
            preparedMembers :: [(Name, Int)]
preparedMembers =
              ((Text, [Type]) -> (Name, Int))
-> [(Text, [Type])] -> [(Name, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, [Type]) -> (Name, Int)
prepare [(Text, [Type])]
members
              where
                prepare :: (Text, [Type]) -> (Name, Int)
prepare (Text
memberName, [Type]
memberComponentTypes) =
                  ( Text -> Text -> Name
DomainTH.sumConstructorName Text
typeName Text
memberName,
                    [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
memberComponentTypes
                  )
        Model.ProductTypeDef [(Text, Type)]
members ->
          (Name -> Int -> Dec
productPutFunD Name
conName Int
components, Name -> Int -> Dec
productGetFunD Name
conName Int
components)
          where
            conName :: Name
conName =
              Text -> Name
textName Text
typeName
            components :: Int
components =
              [(Text, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Type)]
members

-- *

sumPutFunD :: [(Name, Int)] -> Dec
sumPutFunD :: [(Name, Int)] -> Dec
sumPutFunD [(Name, Int)]
members =
  Name -> [Clause] -> Dec
FunD 'Cereal.put [Clause]
clauses
  where
    clauses :: [Clause]
clauses =
      ((Name, Int) -> Integer -> Clause)
-> [(Name, Int)] -> [Integer] -> [Clause]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Int) -> Integer -> Clause
forall a. Integral a => (Name, Int) -> a -> Clause
memberClause [(Name, Int)]
members [Integer
0 ..]
      where
        memberClause :: (Name, Int) -> a -> Clause
memberClause (Name
conName, Int
components) a
conIdx =
          [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName [Pat]
componentPList] (Exp -> Body
NormalB Exp
body) []
          where
            componentNameList :: [Name]
componentNameList = Int -> [Name]
enumAlphabeticNames Int
components
            componentPList :: [Pat]
componentPList = [Name]
componentNameList [Name] -> ([Name] -> [Pat]) -> [Pat]
forall a b. a -> (a -> b) -> b
& (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP
            body :: Exp
body = [Exp] -> Exp
mconcatE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Exp
tagE Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
namePutE [Name]
componentNameList
              where
                tagE :: Exp
tagE = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Leb128.putLEB128) Exp
conIdxLitE
                  where
                    conIdxLitE :: Exp
conIdxLitE = Exp -> Exp
signedAsWord32E (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
conIdx

productPutFunD :: Name -> Int -> Dec
productPutFunD :: Name -> Int -> Dec
productPutFunD Name
conName Int
components =
  Name -> [Clause] -> Dec
FunD 'Cereal.put [Clause
clause]
  where
    clause :: Clause
clause =
      [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName [Pat]
componentPList] (Exp -> Body
NormalB Exp
body) []
      where
        componentNameList :: [Name]
componentNameList = Int -> [Name]
enumAlphabeticNames Int
components
        componentPList :: [Pat]
componentPList = [Name]
componentNameList [Name] -> ([Name] -> [Pat]) -> [Pat]
forall a b. a -> (a -> b) -> b
& (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP
        body :: Exp
body = [Name] -> Exp
nameListPutE [Name]
componentNameList

sumGetFunD :: [(Name, Int)] -> Dec
sumGetFunD :: [(Name, Int)] -> Dec
sumGetFunD [(Name, Int)]
members =
  Name -> [Clause] -> Dec
FunD 'Cereal.get [Clause
clause]
  where
    clause :: Clause
clause =
      [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []
      where
        body :: Exp
body =
          Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(>>=)) Exp
word32GetLEB128E) Exp
tagMatchE
          where
            tagMatchE :: Exp
tagMatchE = [Match] -> Exp
Lambdas.matcher ([Match] -> Exp) -> [Match] -> Exp
forall a b. (a -> b) -> a -> b
$ ((Name, Int) -> Integer -> Match)
-> [(Name, Int)] -> [Integer] -> [Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Int) -> Integer -> Match
memberMatch [(Name, Int)]
members [Integer
0 ..] [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> [Match
defaultMatch]
              where
                memberMatch :: (Name, Int) -> Integer -> Match
memberMatch (Name
conName, Int
components) Integer
conIdx =
                  Pat -> Body -> [Dec] -> Match
Match (Lit -> Pat
LitP (Integer -> Lit
IntegerL Integer
conIdx)) (Exp -> Body
NormalB Exp
body) []
                  where
                    body :: Exp
body = Exp -> [Exp] -> Exp
applicativeChainE (Name -> Exp
ConE Name
conName) (Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
components (Name -> Exp
VarE 'Cereal.get))
                defaultMatch :: Match
defaultMatch =
                  Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
body) []
                  where
                    body :: Exp
body = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fail) (Lit -> Exp
LitE (String -> Lit
StringL String
"Unsupported tag"))

productGetFunD :: Name -> Int -> Dec
productGetFunD :: Name -> Int -> Dec
productGetFunD Name
conName Int
components =
  Name -> [Clause] -> Dec
FunD 'Cereal.get [Clause
clause]
  where
    clause :: Clause
clause =
      [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []
      where
        body :: Exp
body =
          Exp -> [Exp] -> Exp
applicativeChainE (Name -> Exp
ConE Name
conName) (Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
components (Name -> Exp
VarE 'Cereal.get))

-- *

mconcatE :: [Exp] -> Exp
mconcatE :: [Exp] -> Exp
mconcatE = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Exp] -> Exp
ListE

nameListPutE :: [Name] -> Exp
nameListPutE :: [Name] -> Exp
nameListPutE = [Exp] -> Exp
mconcatE ([Exp] -> Exp) -> ([Name] -> [Exp]) -> [Name] -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
namePutE

namePutE :: Name -> Exp
namePutE :: Name -> Exp
namePutE Name
name = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Cereal.put) (Name -> Exp
VarE Name
name)

signedAsWord32E :: Exp -> Exp
signedAsWord32E :: Exp -> Exp
signedAsWord32E Exp
exp = Exp -> Type -> Exp
SigE Exp
exp (Name -> Type
ConT ''Word32)

word32GetLEB128E :: Exp
word32GetLEB128E :: Exp
word32GetLEB128E = Exp -> Type -> Exp
SigE (Name -> Exp
VarE 'Leb128.getLEB128) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Cereal.Get) (Name -> Type
ConT ''Word32))