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 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 = 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, 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 = 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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith 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 forall a b. a -> (a -> b) -> b & forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Name -> Pat VarP body :: Exp body = [Exp] -> Exp mconcatE forall a b. (a -> b) -> a -> b $ Exp tagE forall a. a -> [a] -> [a] : 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 forall a b. (a -> b) -> a -> b $ Lit -> Exp LitE forall a b. (a -> b) -> a -> b $ Integer -> Lit IntegerL forall a b. (a -> b) -> a -> b $ 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 forall a b. a -> (a -> b) -> b & 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 forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (Name, Int) -> Integer -> Match memberMatch [(Name, Int)] members [Integer 0 ..] 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) (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) (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) 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . 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))