packages feed

domain-cereal (empty) → 0.1

raw patch · 6 files changed

+348/−0 lines, 6 filesdep +basedep +cerealdep +cereal-text

Dependencies added: base, cereal, cereal-text, domain, domain-cereal, domain-core, leb128-cereal, rerebase, template-haskell, template-haskell-compat-v0208, text, th-lego

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2021 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ demo/Main.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import qualified Data.ByteString as ByteString+import qualified Data.Serialize as Cereal+import Data.Serialize.Text ()+import Domain+import DomainCereal+import Prelude++declare+  Nothing+  (serializeDeriver <> genericDeriver <> eqDeriver)+  [schema|++    ServiceAddress:+      sum:+        network: NetworkAddress+        local: FilePath++    NetworkAddress:+      product:+        protocol: TransportProtocol+        host: Host+        port: Word16++    TransportProtocol:+      enum:+        - tcp+        - udp++    Host:+      sum:+        ip: Ip+        name: Text++    Ip:+      sum:+        v4: Word32+        v6: Word128++    Word128:+      product:+        part1: Word64+        part2: Word64++    |]++main :: IO ()+main = do+  let value =+        NetworkServiceAddress $+          NetworkAddress+            TcpTransportProtocol+            (IpHost (V4Ip 123))+            456+  let encoded = Cereal.encode value+  putStrLn $ "Encoded size: " <> show (ByteString.length encoded)+  case Cereal.decode encoded of+    Left err -> fail err+    Right res ->+      if value == res+        then putStrLn "Success! Decoded value does equal the original"+        else fail "Failure! Decoded valued doesn't equal the original"
+ domain-cereal.cabal view
@@ -0,0 +1,48 @@+cabal-version: 3.0++name: domain-cereal+version: 0.1+synopsis: Integration of domain with cereal+homepage: https://github.com/nikita-volkov/domain-cereal+bug-reports: https://github.com/nikita-volkov/domain-cereal/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2021 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple++source-repository head+  type: git+  location: git://github.com/nikita-volkov/domain-cereal.git++library+  hs-source-dirs: library+  default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DerivingVia, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedLabels, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples+  default-language: Haskell2010+  exposed-modules:+    DomainCereal+  other-modules:+    DomainCereal.TH+    DomainCereal.Prelude+  build-depends:+    base >=4.12 && <5,+    cereal >=0.5 && <0.6,+    domain-core >=0.1 && <0.2,+    leb128-cereal >=1.2 && <1.3,+    text >=1 && <3,+    template-haskell >=2.14 && <3,+    template-haskell-compat-v0208 >=0.1.7 && <0.2,+    th-lego >=0.3 && <0.4,++test-suite demo+  type: exitcode-stdio-1.0+  hs-source-dirs: demo+  main-is: Main.hs+  default-language: Haskell2010+  build-depends:+    cereal,+    cereal-text >=0.1.0.2 && <0.2,+    domain,+    domain-cereal,+    rerebase >=1.9 && <2,
+ library/DomainCereal.hs view
@@ -0,0 +1,9 @@+module DomainCereal where++import DomainCereal.Prelude+import qualified DomainCereal.TH as TH+import qualified DomainCore.Deriver as Deriver++serializeDeriver :: Deriver.Deriver+serializeDeriver =+  Deriver.effectless (pure . TH.serializeInstanceD)
+ library/DomainCereal/Prelude.hs view
@@ -0,0 +1,78 @@+module DomainCereal.Prelude+  ( module Exports,+    showAsText,+  )+where++import Control.Applicative as Exports hiding (WrappedArrow (..))+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Compose as Exports+import Data.Functor.Contravariant as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Alt)+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports hiding ((%))+import Data.STRef as Exports+import Data.String as Exports+import Data.Text as Exports (Text)+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import GHC.OverloadedLabels as Exports+import Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (%), (.))++showAsText :: Show a => a -> Text+showAsText = show >>> fromString
+ library/DomainCereal/TH.hs view
@@ -0,0 +1,118 @@+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 (Model.TypeDec typeName typeDef) =+  InstanceD Nothing [] headType [putFunD, getFunD]+  where+    headType =+      AppT (ConT ''Cereal.Serialize) (ConT (textName typeName))+    (putFunD, getFunD) =+      case typeDef of+        Model.SumTypeDef members ->+          (sumPutFunD preparedMembers, sumGetFunD preparedMembers)+          where+            preparedMembers =+              fmap prepare members+              where+                prepare (memberName, memberComponentTypes) =+                  ( DomainTH.sumConstructorName typeName memberName,+                    length memberComponentTypes+                  )+        Model.ProductTypeDef members ->+          (productPutFunD conName components, productGetFunD conName components)+          where+            conName =+              textName typeName+            components =+              length members++-- *++sumPutFunD :: [(Name, Int)] -> Dec+sumPutFunD members =+  FunD 'Cereal.put clauses+  where+    clauses =+      zipWith memberClause members [0 ..]+      where+        memberClause (conName, components) conIdx =+          Clause [Compat.conp conName componentPList] (NormalB body) []+          where+            componentNameList = enumAlphabeticNames components+            componentPList = componentNameList & fmap VarP+            body = mconcatE $ tagE : fmap namePutE componentNameList+              where+                tagE = AppE (VarE 'Leb128.putLEB128) conIdxLitE+                  where+                    conIdxLitE = signedAsWord32E $ LitE $ IntegerL $ fromIntegral conIdx++productPutFunD :: Name -> Int -> Dec+productPutFunD conName components =+  FunD 'Cereal.put [clause]+  where+    clause =+      Clause [Compat.conp conName componentPList] (NormalB body) []+      where+        componentNameList = enumAlphabeticNames components+        componentPList = componentNameList & fmap VarP+        body = nameListPutE componentNameList++sumGetFunD :: [(Name, Int)] -> Dec+sumGetFunD members =+  FunD 'Cereal.get [clause]+  where+    clause =+      Clause [] (NormalB body) []+      where+        body =+          AppE (AppE (VarE '(>>=)) word32GetLEB128E) tagMatchE+          where+            tagMatchE = Lambdas.matcher $ zipWith memberMatch members [0 ..] <> [defaultMatch]+              where+                memberMatch (conName, components) conIdx =+                  Match (LitP (IntegerL conIdx)) (NormalB body) []+                  where+                    body = applicativeChainE (ConE conName) (replicate components (VarE 'Cereal.get))+                defaultMatch =+                  Match WildP (NormalB body) []+                  where+                    body = AppE (VarE 'fail) (LitE (StringL "Unsupported tag"))++productGetFunD :: Name -> Int -> Dec+productGetFunD conName components =+  FunD 'Cereal.get [clause]+  where+    clause =+      Clause [] (NormalB body) []+      where+        body =+          applicativeChainE (ConE conName) (replicate components (VarE 'Cereal.get))++-- *++mconcatE :: [Exp] -> Exp+mconcatE = AppE (VarE 'mconcat) . ListE++nameListPutE :: [Name] -> Exp+nameListPutE = mconcatE . fmap namePutE++namePutE :: Name -> Exp+namePutE name = AppE (VarE 'Cereal.put) (VarE name)++signedAsWord32E :: Exp -> Exp+signedAsWord32E exp = SigE exp (ConT ''Word32)++word32GetLEB128E :: Exp+word32GetLEB128E = SigE (VarE 'Leb128.getLEB128) (AppT (ConT ''Cereal.Get) (ConT ''Word32))