serdoc-core (empty) → 0.1.0.0
raw patch · 11 files changed
+1266/−0 lines, 11 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, mtl, serdoc-core, tasty, tasty-quickcheck, template-haskell, text, th-abstraction, time
Files
- CHANGELOG.md +5/−0
- LICENSE +13/−0
- README.md +115/−0
- serdoc-core.cabal +65/−0
- src/Data/SerDoc/Class.hs +332/−0
- src/Data/SerDoc/Info.hs +193/−0
- src/Data/SerDoc/TH.hs +215/−0
- src/Data/SerDoc/TestUtil.hs +19/−0
- test/Data/SerDoc/Test/Class.hs +139/−0
- test/Data/SerDoc/Test/Info.hs +154/−0
- test/Main.hs +16/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for serdoc-core++## v0.1.0++- Initial release
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2023 IO Global++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ README.md view
@@ -0,0 +1,115 @@+serdoc+======++Unified serialization with semi-automatic documentation++Introduction+------------+SerDoc provides:++- A unified interface for serialization formats ("codecs"), in the form of a+ 'Serializable' typeclass.+- A mini-EDSL (`FieldInfo`) for describing serialization formats as first-class+ data structures, and a typeclass (`HasInfo`) to link them to codecs and+ serializable Haskell types.+- Building blocks and utility code for implementing `Codec`, `Serializable`,+ and `HasInfo` for existing or new serialization formats.++It also includes an implementation of these typeclasses for [the `binary`+package](https://hackage.haskell.org/package/binary).++Components+----------+SerDoc is split up into two sub-projects:++- `serdoc-core (this library)`, which provides the typeclasses and building blocks+- `serdoc-binary`, which provides instances for `binary`++How To Use+----------++### Serializing and deserializing values++For encoding, it's straightforward - use `encode`.++For decoding, you have a few options, depending on the codec you use. The most+general form is `decodeM`; apart from that, a family of similar functions is+provided, following the conventions:++- Monadic decoders have an `M` suffix; pure decoders (where the decoding Monad+ is `Except err` or `Identity`) have no `M` suffix (e.g., `decode` vs.+ `decodeM`).+- Flavors that ignore any remaining unconsumed input have a `_` suffix (e.g.+ `decode_`).+- Flavors that convert decoding errors to `Either`s have an `Either` suffix+ (e.g. `decodeMEither`); these require that the decoding monad is `Except err`+ or `ExceptT err m`.++Keep in mind that depending on how the codec works, the serialized data may be+returned / consumed via the `Encoded` type, or passed by (mutable) reference+through the `Context` object. The API purposefully supports both ways, because+a given codec may only support one or the other.++### Implementing `HasInfo` and `Serializable` for an existing codec++- For **newtype** wrappers that use the same serialization format as their+ wrapped payloads, the easiest way is to use `GeneralizedNewtypeDeriving` to+ derive instances for both typeclasses.+- For **newtype** wrappers that should implement a *different* serialization+ format, you may need to hand-write instances; if you do this, take special+ care to ensure that the `HasInfo` instance matches the actual serialization.+- **Lists** and some other data structures are supported out of the box and+ require no explicit instance; they are serialized using a 32-bit list length+ followed by the serialized list elements, in order. If you need a different+ representation, then newtype-wrapping may be necessary.+- For **enumeration types**, a generic wrapper, `ViaEnum`, is provided, which+ you can use in combination with the `DerivingVia` extension; alternatively,+ you can use `enumInfo`, `encodeEnum`, and `decodeEnum` to write the instances+ yourself.+- **`String`**, due to being just a type alias for `[Char]`, will only+ serialize iff an instance for `Char` exists. However, it is usually preferred+ to convert your strings to `Text`.+- For **record types**, consider using `deriveSerDoc` (found in+ `Data.SerDoc.TH`). This Template Haskell function will generate matching+ instances for both typeclasses, following the convention of serializing all+ fields in the order they appear in the type declaration, and labelled by+ their Haskell field names. Obviously this will only work if instances for+ each of the record fields exist.++### Adding your own codecs++A codec is indicated using a phantom type; no values of that type ever need to+exist at runtime, we merely use it to identify the codec we want, so we can+define it as a constructorless `data` type (like `Void`), e.g.:++ data MyFantasticCodec++We then need a `Codec` instance, which is where we define:++- A type for a *context* passed to each invocation of `encode` and `decodeM`;+ this can be anything you want, depending on the needs of your codec. If the+ codec does not require any context, use `()`.+- A monadic data type used for encoding, `MonadEncode`. For pure codecs, this+ can be `Identity`; if you serialize directly to something like a file handle+ or network socket, it will typically have to be `IO`, or some `MonadIO`.+- A monadic data type used for decoding, `MonadDecode`. Since decoding can+ fail, this will typically involve not just the required effects for the+ decoding process itself, but also some form of error handling. It is+ recommended to use `Except err` for pure codecs, and `ExceptT err IO` (or `MonadIO m+ => ExceptT err m`) for codecs that require IO, where `err` is an appropriate+ error data structure for your codec.+- The default encoding to use for enum types (optional, defaults to `Word16`).++Providing instances for a reasonable set of primitive values and data+structures is highly recommended; a minimum viable set might be:++- `()`+- `Bool`+- `Int`, `Int8`, `Int16`, `Int32`, `Int64`+- `Word`, `Word8`, `Word16`, `Word32`, `Word64`+- Whatever type you picked for the default enum encoding+- `[a]`+- `Maybe a`+- `Either a b`+- Tuples up to 7 elements+- `ByteString`
+ serdoc-core.cabal view
@@ -0,0 +1,65 @@+cabal-version: 3.0+name: serdoc-core+version: 0.1.0.0+synopsis: Generated documentation of serialization formats+description: A set of typeclasses, primitives, combinators, and TH+ utilities for documenting serialization formats in a mostly+ automatic fashion.+license: Apache-2.0+license-file: LICENSE+author: Tobias Dammers+maintainer: tobias@well-typed.com+copyright: 2023 IO Global+category: Data+build-type: Simple+extra-doc-files: README.md+ , CHANGELOG.md+-- extra-source-files:++common warnings+ ghc-options: -Wall++common project-config+ ghc-options:+ -haddock+ -- -ddump-splices++library+ import: project-config+ import: warnings+ exposed-modules: Data.SerDoc.Class+ , Data.SerDoc.Info+ , Data.SerDoc.TestUtil+ , Data.SerDoc.TH+ build-depends: base >=4.14.0.0 && <5+ , bytestring >=0.11 && <0.13+ , containers >=0.6 && <0.8+ , mtl >=2.3.1 && <2.4+ , tasty >=1.5 && <1.6+ , tasty-quickcheck >=0.10.3 && <0.11+ , text >=1.1 && <2.2+ , time >=1.12 && <1.14+ , template-haskell >=2.16 && <2.22+ , th-abstraction >=0.6 && <0.7+ hs-source-dirs: src+ default-language: Haskell2010++test-suite serdoc-test+ import: project-config+ import: warnings+ default-language: Haskell2010+ other-modules: Data.SerDoc.Test.Class+ , Data.SerDoc.Test.Info+ -- other-extensions:+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >=4.14.0.0 && <5+ , serdoc-core+ , bytestring >=0.11 && <0.13+ , mtl >=2.3.1 && <2.4+ , tasty >=1.5 && <1.6+ , tasty-quickcheck >=0.10.3 && <0.11+ , template-haskell >=2.16 && <2.22+ , text >=1.1 && <2.2+ , time >=1.12 && <1.14
+ src/Data/SerDoc/Class.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.SerDoc.Class+where++import Data.SerDoc.Info++import Data.Kind+import Data.List+import Data.Map ( Map )+import qualified Data.Map.Strict as Map+import Data.Proxy+import Data.Typeable+import Data.Word++-- * Typeclasses++-- | Abstracts over an individual serializer / deserializer, a.k.a., a+-- \"codec\". A codec typically provides a serializer, deserializer, and+-- metadata for each serializable type; however, for various reasons, the+-- 'Codec' typeclass itself only captures the associated types that are involved+-- in serializing and deserializing.+class Codec codec where+ -- | The 'Monad' in which encoding can happen.+ type MonadEncode codec :: Type -> Type++ -- | The 'Monad' in which decoding can happen.+ type MonadDecode codec :: Type -> Type++ -- | Unless explicitly declared otherwise, enum fields will be encoded as+ -- this type.+ type DefEnumEncoding codec :: Type+ type DefEnumEncoding codec = Word16++-- | Serialization and deserialization API for a 'Codec'.+class Codec codec => Serializable codec a where+ -- | Encode / serialize a value.+ encode :: Proxy codec -> a -> MonadEncode codec ()++ -- | Decode / deserialize a value.+ decode :: Proxy codec -> MonadDecode codec a++-- | Serialization metadata for a 'Codec'.+class Codec codec => HasInfo codec a where+ info :: Proxy codec -> Proxy a -> FieldInfo codec++-- * Helpers For Writing Instances++-- | Newtype wrapper for deriving / defining 'HasInfo' and 'Serializable'+-- instances for enum types.+newtype ViaEnum a = ViaEnum { viaEnum :: a }+ deriving newtype (Show)++instance ( Enum a+ , Bounded a+ , Typeable a+ , Show a+ , Codec codec+ , HasInfo codec (DefEnumEncoding codec)+ ) => HasInfo codec (ViaEnum a)+ where+ info pCodec _ =+ enumInfo pCodec (Proxy @a) (Proxy @(DefEnumEncoding codec))++instance ( Enum a+ , Bounded a+ , Codec codec+ , Integral (DefEnumEncoding codec)+ , Num (DefEnumEncoding codec)+ , Monad (MonadEncode codec)+ , Monad (MonadDecode codec)+ , Serializable codec (DefEnumEncoding codec)+ ) => Serializable codec (ViaEnum a)+ where+ encode pCodec (ViaEnum x) = encodeEnum pCodec (Proxy @(DefEnumEncoding codec)) x+ decode pCodec = ViaEnum <$> decodeEnum pCodec (Proxy @(DefEnumEncoding codec))++enumInfo :: forall codec a n.+ ( Typeable a+ , Show a+ , Enum a+ , Bounded a+ , Codec codec+ , HasInfo codec n+ , HasInfo codec (DefEnumEncoding codec)+ )+ => Proxy codec+ -> Proxy a+ -> Proxy n+ -> FieldInfo codec+enumInfo pCodec _ pN =+ enumField+ (getTypeName $ Proxy @a)+ (fieldSize $ info pCodec pN)+ [ (fromEnum val, show val) | val <- [minBound .. maxBound :: a] ]++encodeEnum :: forall codec n a.+ ( Enum a+ , Bounded a+ , Codec codec+ , Num n+ , Serializable codec n+ )+ => Proxy codec+ -> Proxy n+ -> a+ -> MonadEncode codec ()+encodeEnum pCodec _ x = do+ let i :: n = fromIntegral . fromEnum $ x+ encode pCodec i++decodeEnum :: forall codec n a.+ ( Enum a+ , Bounded a+ , Codec codec+ , Integral n+ , Serializable codec n+ , Monad (MonadDecode codec)+ )+ => Proxy codec+ -> Proxy n+ -> (MonadDecode codec) a+decodeEnum pCodec _ = do+ (i :: n) <- decode pCodec+ return (toEnum . fromIntegral $ i)++getTypeName :: Typeable a => Proxy a -> String+getTypeName = tyConName . typeRepTyCon . typeRep+++-- * Helpers For Dealing With 'FieldInfo' And 'Field Size'++fieldType :: forall codec.+ HasInfo codec Word32+ => FieldInfo codec -> String+fieldType (AnnField _ fi) = fieldType fi+fieldType (BasicField fi) = basicFieldType fi+fieldType (EnumField fi) = enumFieldType fi ++ " = " ++ fieldType (info @codec @Word32 Proxy Proxy)+fieldType (CompoundField fi) = compoundFieldType fi+fieldType (ChoiceField fi) = intercalate " | " $ map fieldType (choiceFieldAlternatives fi)+fieldType (ListField fi) = "[" ++ fieldType (listElemInfo fi) ++ "]"+fieldType (AliasField fi) = aliasFieldName fi ++ " = " ++ fieldType (aliasFieldTarget fi)+fieldType (SumField fi) = sumFieldType fi++shortFieldType :: FieldInfo codec -> String+shortFieldType (AnnField _ fi) = shortFieldType fi+shortFieldType (BasicField fi) = basicFieldType fi+shortFieldType (EnumField fi) = enumFieldType fi+shortFieldType (CompoundField fi) = compoundFieldType fi+shortFieldType (ChoiceField fi) = intercalate " | " $ map shortFieldType (choiceFieldAlternatives fi)+shortFieldType (ListField fi) = "[" ++ shortFieldType (listElemInfo fi) ++ "]"+shortFieldType (AliasField fi) = aliasFieldName fi+shortFieldType (SumField fi) = sumFieldType fi++-- | Reduce a 'FieldInfo' to report only the relevant information for a known+-- constructor.+infoOf :: String -> FieldInfo codec -> FieldInfo codec+infoOf name (AnnField _ fi) = infoOf name fi+infoOf name (EnumField fi) =+ EnumField fi+ { enumFieldValues =+ [ (i, n)+ | (i, n) <- enumFieldValues fi+ , n == name+ ]+ }+infoOf name (SumField fi) =+ SumField fi+ { sumFieldAlternatives =+ [ (n, i)+ | (n, i) <- sumFieldAlternatives fi+ , n == name+ ]+ }+infoOf _ fi = fi++formatPath :: [String] -> String+formatPath = intercalate "." . reverse++scopeFieldSize :: String -> FieldSize -> FieldSize+scopeFieldSize scope (VarSize var) = VarSize (scope ++ "." ++ var)+scopeFieldSize scope (BinopSize op a b) = BinopSize op (scopeFieldSize scope a) (scopeFieldSize scope b)+scopeFieldSize scope (RangeSize a b) = RangeSize (scopeFieldSize scope a) (scopeFieldSize scope b)+scopeFieldSize _ x = x++simplifyFieldSize :: FieldSize -> FieldSize+simplifyFieldSize (RangeSize a b) =+ let a' = simplifyFieldSize a+ b' = simplifyFieldSize b+ in+ if a' == b' then+ a'+ else+ case (a', b') of+ (RangeSize aa' ab', RangeSize ba' bb') ->+ simplifyFieldSize (RangeSize (BinopSize FSMin aa' ba') (BinopSize FSMax ab' bb'))+ (a'', RangeSize ba' bb') ->+ simplifyFieldSize (RangeSize (BinopSize FSMin a'' ba') (BinopSize FSMax a'' bb'))+ _ -> RangeSize a' b'++simplifyFieldSize (BinopSize op a b) =+ let a' = simplifyFieldSize a+ b' = simplifyFieldSize b+ in+ case (a', op, b') of+ (UnknownSize, _, _) -> UnknownSize+ (_, _, UnknownSize) -> UnknownSize++ (FixedSize x, FSPlus, BinopSize FSPlus (FixedSize y) z) ->+ simplifyFieldSize (BinopSize FSPlus (FixedSize (x + y)) z)+ (BinopSize FSPlus z (FixedSize y), FSPlus, FixedSize x) ->+ simplifyFieldSize (BinopSize FSPlus (FixedSize (x + y)) z)+ (RangeSize la ra, _, RangeSize lb rb) ->+ simplifyFieldSize (RangeSize (BinopSize op la lb) (BinopSize op ra rb))+ (RangeSize l r, _, c) ->+ simplifyFieldSize (RangeSize (BinopSize op l c) (BinopSize op r c))+ (x, FSPlus, BinopSize FSPlus y z) ->+ simplifyFieldSize (BinopSize FSPlus (BinopSize FSPlus x y) z)++ (FixedSize x, FSMul, BinopSize FSMul (FixedSize y) z) ->+ simplifyFieldSize (BinopSize FSMul (FixedSize (x + y)) z)+ (BinopSize FSMul z (FixedSize y), FSMul, FixedSize x) ->+ simplifyFieldSize (BinopSize FSMul (FixedSize (x + y)) z)++ (FixedSize x, FSPlus, FixedSize y) -> FixedSize (x + y)+ (FixedSize x, FSMul, FixedSize y) -> FixedSize (x * y)++ (FixedSize x, FSMax, FixedSize y) -> FixedSize (max x y)+ (FixedSize x, FSMin, FixedSize y) -> FixedSize (min x y)++ (FixedSize x, FSPlus, RangeSize lo hi) ->+ simplifyFieldSize (RangeSize (BinopSize FSPlus (FixedSize x) lo) (BinopSize FSPlus (FixedSize x) hi))++ (FixedSize 0, FSPlus, y) -> y+ (x, FSPlus, FixedSize 0) -> x+ (FixedSize 1, FSMul, y) -> y+ (x, FSMul, FixedSize 1) -> x+ (FixedSize 0, FSMin, _) -> FixedSize 0+ (_, FSMin, FixedSize 0) -> FixedSize 0+ (FixedSize 0, FSMax, y) -> y+ (x, FSMax, FixedSize 0) -> x++ _ -> BinopSize op a' b'+simplifyFieldSize x = x++resolveSizeScopes :: forall codec.+ ( Codec codec+ , HasInfo codec (DefEnumEncoding codec)+ )+ => Proxy codec+ -> Map String [String]+ -> FieldSize+ -> FieldSize+resolveSizeScopes _ env (VarSize name) =+ let name' = maybe name formatPath $ Map.lookup name env+ in VarSize name'+resolveSizeScopes pCodec env (BinopSize op a b) =+ BinopSize op (resolveSizeScopes pCodec env a) (resolveSizeScopes pCodec env b)+resolveSizeScopes pCodec env (RangeSize a b) =+ RangeSize (resolveSizeScopes pCodec env a) (resolveSizeScopes pCodec env b)+resolveSizeScopes pCodec env EnumSize =+ resolveSizeScopes pCodec env (fieldSize $ info pCodec (Proxy @(DefEnumEncoding codec)))+resolveSizeScopes _ _ x = x++fieldSize :: forall codec.+ ( Codec codec+ , HasInfo codec (DefEnumEncoding codec)+ )+ => FieldInfo codec+ -> FieldSize+fieldSize = fieldSizeScoped [] mempty++fieldSizeScoped :: forall codec.+ ( Codec codec+ , HasInfo codec (DefEnumEncoding codec)+ )+ => [String]+ -> Map String [String]+ -> FieldInfo codec+ -> FieldSize+fieldSizeScoped path env (AnnField _ fi) =+ fieldSizeScoped path env fi+fieldSizeScoped path env (AliasField fi) =+ fieldSizeScoped path env (aliasFieldTarget fi)+fieldSizeScoped _ env (BasicField fi) =+ resolveSizeScopes (Proxy @codec) env (basicFieldSize fi)+fieldSizeScoped _ env (EnumField fi) =+ resolveSizeScopes (Proxy @codec) env (enumFieldSize fi)+fieldSizeScoped path env (CompoundField fi) =+ let env' = foldl' (\e sfi -> Map.insert (subfieldName sfi) (subfieldName sfi : path) e) env (compoundFieldSubfields fi)+ qualifiedSubfieldSizes sfi =+ let path' = subfieldName sfi : path+ env'' = Map.insert (subfieldName sfi) path' env'+ in+ fieldSizeScoped path' env'' (subfieldInfo sfi)+ in+ case map qualifiedSubfieldSizes (compoundFieldSubfields fi) of+ [] -> FixedSize 0+ (x:xs) -> simplifyFieldSize $ foldl' (BinopSize FSPlus) x xs+fieldSizeScoped path env (ListField fi) =+ let elemSize = maybe UnknownSize FixedSize $+ knownSize+ (fieldSizeScoped path env (listElemInfo fi))+ in+ simplifyFieldSize $+ BinopSize FSMul (listSize fi) elemSize+fieldSizeScoped path env (ChoiceField fi) =+ case map (fieldSizeScoped path env) (choiceFieldAlternatives fi) of+ [] -> FixedSize 0+ (x:xs) -> let maxVal = foldl' (BinopSize FSMax) x xs+ minVal = foldl' (BinopSize FSMin) x xs+ in simplifyFieldSize (RangeSize minVal maxVal)+fieldSizeScoped path env (SumField fi) =+ case map (fieldSizeScoped path env . snd) (sumFieldAlternatives fi) of+ [] -> FixedSize 0+ (x:xs) -> let maxVal = foldl' (BinopSize FSMax) x xs+ minVal = foldl' (BinopSize FSMin) x xs+ in simplifyFieldSize (RangeSize minVal maxVal)
+ src/Data/SerDoc/Info.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.SerDoc.Info+where++import Data.Data+import Data.Word+import Language.Haskell.TH.Syntax (Lift)++-- * Documentation annotation types++-- | Used to add descriptions via @ANN@ pragmas. This is necessary because+-- Template Haskell cannot find Haddock comments attached to constructors inside+-- associated types, but it can find annotations on those same constructors.+newtype Description = Description { descriptionParagraphs :: [String] }+ deriving newtype (Show, Read, Eq, Semigroup, Monoid)+ deriving (Data, Typeable, Lift)++-- * 'FieldInfo' and related types++-- | Describes the serialization format of a field.+data FieldInfo codec+ = AnnField !String !(FieldInfo codec)+ -- ^ Adds an annotation to a field.+ | BasicField !BasicFieldInfo+ -- ^ A simple field, with a named type and a size.+ | EnumField !EnumFieldInfo+ -- ^ An enum field, which reports labels and values for the possible values.+ | CompoundField !(CompoundFieldInfo codec)+ -- ^ A field that is composed out of multiple sub-fields, encoded+ -- sequentially.+ | ChoiceField !(ChoiceFieldInfo codec)+ -- ^ A list of alternatives, to be picked based on a given choice condition.+ | ListField !(ListFieldInfo codec)+ -- ^ A list of values, encoded sequentially. The length must be encoded+ -- separately, and can be referenced from a length expression.+ | AliasField !(AliasFieldInfo codec)+ -- ^ Adds an alternative name (alias) to a field type.+ | SumField !(SumFieldInfo codec)+ -- ^ A list of named alternatives. TODO: this is probably redundant and may+ -- not actually work.+ deriving (Show, Eq)++data BasicFieldInfo =+ BasicFieldInfo+ { basicFieldType :: !String+ , basicFieldSize :: !FieldSize+ }+ deriving (Show, Eq)++data EnumFieldInfo =+ EnumFieldInfo+ { enumFieldType :: !String+ , enumFieldSize :: !FieldSize+ , enumFieldValues :: ![(Int, String)]+ }+ deriving (Show, Eq)++data AliasFieldInfo codec =+ AliasFieldInfo+ { aliasFieldName :: !String+ , aliasFieldTarget :: !(FieldInfo codec)+ }+ deriving (Show, Eq)++data CompoundFieldInfo codec =+ CompoundFieldInfo+ { compoundFieldType :: !String+ , compoundFieldSubfields :: ![SubfieldInfo codec]+ }+ deriving (Show, Eq)++data SumFieldInfo codec =+ SumFieldInfo+ { sumFieldType :: !String+ , sumFieldAlternatives :: ![(String, FieldInfo codec)]+ }+ deriving (Show, Eq)++data ListFieldInfo codec =+ ListFieldInfo+ { listSize :: !FieldSize+ , listElemInfo :: !(FieldInfo codec)+ }+ deriving (Show, Eq)++data SubfieldInfo codec =+ SubfieldInfo+ { subfieldName :: !String+ , subfieldInfo :: !(FieldInfo codec)+ }+ deriving (Show, Eq)++data ChoiceCondition+ = IndexField !String+ | IndexFlag !String Word32+ deriving (Show, Eq)++data ChoiceFieldInfo codec =+ ChoiceFieldInfo+ { choiceCondition :: !ChoiceCondition+ , choiceFieldAlternatives :: ![FieldInfo codec]+ }+ deriving (Show, Eq)++annField :: String -> FieldInfo codec -> FieldInfo codec+annField = AnnField++basicField :: String -> FieldSize -> FieldInfo codec+basicField ty size = BasicField $ BasicFieldInfo ty size++enumField :: String -> FieldSize -> [(Int, String)] -> FieldInfo codec+enumField ty size values = EnumField $ EnumFieldInfo ty size values++enumField_ :: String+ -> [String]+ -> FieldInfo codec+enumField_ ty values = enumField ty EnumSize (zip [0,1..] values)++aliasField :: String -> FieldInfo codec -> FieldInfo codec+aliasField name ty = AliasField $ AliasFieldInfo name ty++compoundField :: String -> [(String, FieldInfo codec)] -> FieldInfo codec+compoundField ty subfields =+ CompoundField $+ CompoundFieldInfo+ ty+ [ SubfieldInfo name i+ | (name, i) <- subfields+ ]++choiceField :: ChoiceCondition -> [FieldInfo codec] -> FieldInfo codec+choiceField cond subfields =+ ChoiceField $+ ChoiceFieldInfo+ cond+ subfields++sumField :: String -> [(String, FieldInfo codec)] -> FieldInfo codec+sumField name alternatives =+ SumField $+ SumFieldInfo+ name+ alternatives++listField :: FieldSize -> FieldInfo codec -> FieldInfo codec+listField lengthExpr elemInfo =+ ListField $+ ListFieldInfo+ lengthExpr+ elemInfo++-- * Field sizes++data FieldSize+ = FixedSize !Int -- ^ Exactly this size+ | EnumSize -- ^ The default enum size for the codec+ | VarSize !String -- ^ Size given by a named variable from the context+ | BinopSize !FieldSizeBinop !FieldSize !FieldSize -- ^ Binary operation+ | RangeSize !FieldSize !FieldSize -- ^ Min/max range+ | UnknownSize -- ^ Size is entirely unknown+ deriving (Show, Eq)++knownSize :: FieldSize -> Maybe Int+knownSize (FixedSize i) = Just i+knownSize VarSize {} = Nothing+knownSize (BinopSize FSPlus a b) = (+) <$> knownSize a <*> knownSize b+knownSize (BinopSize FSMul a b) = (*) <$> knownSize a <*> knownSize b+knownSize (BinopSize FSMax a b) = max <$> knownSize a <*> knownSize b+knownSize (BinopSize FSMin a b) = min <$> knownSize a <*> knownSize b+knownSize _ = Nothing++data FieldSizeBinop+ = FSPlus+ | FSMul+ | FSMax+ | FSMin+ deriving (Show, Eq)+
+ src/Data/SerDoc/TH.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++module Data.SerDoc.TH+( deriveSerializable+, deriveHasInfo+, deriveSerDoc+)+where++import Data.SerDoc.Info+import Data.SerDoc.Class++import Data.List+import Data.Proxy+import Language.Haskell.TH+import Language.Haskell.TH.Datatype+import Data.Char+import Control.Monad++-- * Deriving 'HasInfo' and 'Serializable' with Template Haskell++strippedFieldName :: Name -> Name -> String+strippedFieldName tyName fieldName =+ let tyStr = nameBase tyName+ fieldStr = nameBase fieldName+ lcfirst [] = []+ lcfirst (x:xs) = toLower x : xs+ tyStrLC = lcfirst tyStr+ in+ if tyStrLC `isPrefixOf` fieldStr then+ drop (length tyStrLC) fieldStr+ else+ fieldStr++nameToTy :: Name -> Type+nameToTy name = case nameBase name of+ "" -> error "Empty names are not allowed"+ c:_ | isLower c -> VarT name+ c:_ | isUpper c -> ConT name+ _ -> error $ "Unsupported name: " ++ show name++#if MIN_VERSION_template_haskell(2,17,0)+tyVarBndrName :: TyVarBndr a -> Name+tyVarBndrName (PlainTV name _) = name+tyVarBndrName (KindedTV name _ _) = name+#else+tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV name ) = name+tyVarBndrName (KindedTV name _) = name+#endif++-- | Derive a 'HasInfo' instance for the given codec and type.+-- Currently only supports record types.+-- A matching 'Serializable' instance must serialize record fields in the order+-- they are declared in the source code, without any additional separators,+-- padding, or envelope around or between them. If your serializer does not meet+-- these requirements, you must write a custom 'HasInfo' instance instead.+deriveHasInfo :: Name -> [Name] -> Name -> DecsQ+deriveHasInfo codecName codecArgs typeName = do+ TyConI (DataD _ _ codecVars _ _ _) <- reify codecName+ let remainingVars = drop (length codecArgs) codecVars+ let codecTy = foldl AppT (ConT codecName) (map nameToTy (codecArgs ++ map tyVarBndrName remainingVars))+ reify typeName >>= \case+ TyConI (DataD [] tyName tyVars Nothing [RecC _ fields] []) -> do+ let constraintFields = filter (\(_, _, fieldTy) -> not . null . freeVariables $ fieldTy) fields+ constraints <- forM constraintFields $+ \(_, _, fieldTy) ->+ [t| HasInfo $(pure codecTy) $(pure fieldTy) |]+ fmap (:[]) $+ instanceD+ (pure constraints) + [t| HasInfo+ $(pure codecTy)+ $(foldl appT (conT tyName) [ varT (tyVarName bndr) | bndr <- tyVars ])+ |]+ [ funD+ (mkName "info")+ [ clause+ [ varP (mkName "codec")+ , varP (mkName "_")+ ]+ (normalB [|+ compoundField+ $(litE (stringL (nameBase tyName)))+ $(listE+ [ [| ( $(litE (stringL (strippedFieldName tyName fieldName)))+ , info codec (Proxy :: Proxy $(return fieldTy))+ )+ |]+ | (fieldName, _, fieldTy) <- fields+ ]+ )+ |]+ )+ []+ ]+ ]+ x ->+ error $ "Unsupported data type " ++ show typeName ++ ": " ++ show x++-- | Derive a 'Serializable' instance for the given codec and type.+-- Currently only supports record types.+-- The generated instance will serialize record fields in the order+-- they are declared in the source code, without any additional separators,+-- padding, or envelope around or between them, making it compatible with+-- 'deriveHasInfo'. (See also 'deriveSerDoc'.)+deriveSerializable :: Name -> [Name] -> Name -> DecsQ+deriveSerializable codecName codecArgs typeName = do+ TyConI (DataD _ _ codecVars _ _ _) <- reify codecName+ let remainingVars = drop (length codecArgs) codecVars+ let codecTy = foldl AppT (ConT codecName) (map nameToTy (codecArgs ++ map tyVarBndrName remainingVars))+ reify typeName >>= \case+ TyConI (DataD [] tyName tyVars Nothing [RecC conName fields] []) -> do+ let constraintFields =+ if null remainingVars then+ filter (\(_, _, fieldTy) -> not . null . freeVariables $ fieldTy) fields+ else+ fields+ constraints1 <-+ if null remainingVars then+ pure []+ else+ sequence+ [ [t| Monad (MonadEncode $(pure codecTy)) |]+ , [t| Monad (MonadDecode $(pure codecTy)) |]+ ]+ constraints2 <- forM constraintFields $+ \(_, _, fieldTy) ->+ [t| Serializable $(pure codecTy) $(pure fieldTy) |]+ let constraints = constraints1 ++ constraints2+ fmap (:[]) $+ instanceD+ (pure constraints) + [t| Serializable+ $(pure codecTy)+ $(foldl appT (conT tyName) [ varT (tyVarName bndr) | bndr <- tyVars ])+ |]+ [ funD+ (mkName "encode")+ [ clause+ [ varP (mkName "p")+ , varP (mkName "item")+ ]+ (normalB $+ [| sequence_+ $(listE+ [ [| encode p ($(varE fieldName) item) |]+ | (fieldName, _, _) <- fields+ ])+ |]+ )+ []+ ]+ , funD+ (mkName "decode")+ [ clause+ [ varP (mkName "p")+ ]+ (normalB $+ [| $(foldApplicative+ (conE conName)+ [ [| decode p |] | _ <- fields ]+ )+ |]+ )+ []+ ]+ ]+ x ->+ error . show $ x++-- | Derive both a 'HasInfo' instance and a matching 'Serializable' instance,+-- combining 'deriveHasInfo' and 'deriveSerializable'.+deriveSerDoc :: Name -> [Name] -> Name -> DecsQ+deriveSerDoc codecName codecArgs typeName =+ (++) <$> deriveHasInfo codecName codecArgs typeName+ <*> deriveSerializable codecName codecArgs typeName++-- <$> :: (a -> b) -> f a -> f b+-- <*> :: f (a -> b) -> f a -> f b+foldApplicative :: ExpQ -> [ExpQ] -> ExpQ+foldApplicative initial [] = [| pure $initial |]+foldApplicative initial [x] = [| $initial <$> $x |]+foldApplicative initial (x:xs) =+ foldl (\a b -> [| $a <*> $b |]) [| $initial <$> $x |] xs++#if MIN_VERSION_template_haskell(2,17,0)+tyVarName :: TyVarBndr a -> Name+tyVarName (PlainTV n _) = n+tyVarName (KindedTV n _ _) = n+#else+tyVarName :: TyVarBndr -> Name+tyVarName (PlainTV n) = n+tyVarName (KindedTV n _) = n+#endif
+ src/Data/SerDoc/TestUtil.hs view
@@ -0,0 +1,19 @@+module Data.SerDoc.TestUtil+where++import Text.Read+import Data.ByteString (ByteString)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Data.Maybe++showBS :: Show a => a -> ByteString+showBS = encodeUtf8 . Text.pack . show++readMaybeBS_ :: Read a => ByteString -> Maybe a+readMaybeBS_ = readMaybe . Text.unpack . decodeUtf8++readMaybeBS :: Read a => ByteString -> Maybe (a, ByteString)+readMaybeBS src = do+ (x, restStr) <- listToMaybe . reads . Text.unpack . decodeUtf8 $ src+ return (x, encodeUtf8 . Text.pack $ restStr)
+ test/Data/SerDoc/Test/Class.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.SerDoc.Test.Class+where++import Test.Tasty+import Test.Tasty.QuickCheck+import Data.Proxy+import Control.Monad.Identity+import Control.Monad.Except+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Control.Monad.Writer+import Control.Monad.State+import Data.Kind++import Data.SerDoc.Class+import Data.SerDoc.Info+import Data.SerDoc.TH+import Data.SerDoc.TestUtil++data ShowCodec (m :: Type -> Type)++instance Codec (ShowCodec m) where+ type MonadEncode (ShowCodec m) = Writer ByteString+ type MonadDecode (ShowCodec m) = ExceptT String (State ByteString)++instance HasInfo (ShowCodec m) () where+ info _ _ = basicField "()" (FixedSize $ BS.length $ showBS ())++instance HasInfo (ShowCodec m) Int where+ info _ _ = basicField "Int" (RangeSize (FixedSize 1) (FixedSize $ length $ show (minBound :: Int)))++newtype ViaShow a = ViaShow { viaShow :: a }++instance (Show a, Read a) => Serializable (ShowCodec m) (ViaShow a) where+ encode _ = tell . showBS . viaShow+ decode _ = do+ decodedMay <- readMaybeBS <$> get+ case decodedMay of+ Nothing ->+ throwError "Read: no parse"+ Just (x, rest) -> do+ put rest+ return (ViaShow x)++deriving via (ViaShow ()) instance Serializable (ShowCodec m) ()++deriving via (ViaShow Int) instance Serializable (ShowCodec m) Int+++data Record =+ Record+ { firstField :: ()+ , secondField :: Int+ }+ deriving (Show, Read, Eq, Ord)++instance Arbitrary Record where+ arbitrary = Record <$> arbitrary <*> arbitrary+ shrink (Record a b) =+ Record a <$> shrink b++$(deriveSerDoc ''ShowCodec [] ''Record)++data Record1 a =+ Record1+ { firstField1 :: a+ , secondField1 :: [a]+ }+ deriving (Show, Read, Eq, Ord)++instance Arbitrary a => Arbitrary (Record1 a) where+ arbitrary = Record1 <$> arbitrary <*> arbitrary+ shrink (Record1 a b) =+ (Record1 a <$> shrink b)+ +++ (Record1 <$> shrink a <*> pure b)++$(deriveSerDoc ''ShowCodec [] ''Record1)++tests :: TestTree+tests = testGroup "Class"+ [ testGroup "ShowCodec m"+ [ testGroup "HasInfo"+ [ testProperty "()" $ pUnitHasInfo (Proxy @(ShowCodec IO))+ ]+ , testGroup "Serializable"+ [ testProperty "()" $ pRoundTrip @() (Proxy @(ShowCodec IO)) execWriter (runState . runExceptT)+ -- , testProperty "Int" $ pRoundTrip @Int (Proxy @(ShowCodec IO)) execWriter runState+ -- , testProperty "Record" $ pRoundTrip @Record (Proxy @(ShowCodec IO)) execWriter runState+ ]+ ]+ ]++pUnitHasInfo :: (Codec codec, HasInfo codec ())+ => Proxy codec+ -> Property+pUnitHasInfo pCodec =+ actual === expected+ where+ actual = info pCodec (Proxy @())+ expected = basicField "()" (FixedSize $ BS.length $ showBS ())++pRoundTrip :: forall a codec err encoded mdecode.+ ( Codec codec+ , Serializable codec a+ , Arbitrary a+ , Eq a+ , Show a+ , Monad (MonadEncode codec)+ , Monad mdecode+ , MonadDecode codec ~ ExceptT err mdecode+ , Eq encoded+ , Show encoded+ , Monoid encoded+ , Eq err+ , Show err+ )+ => Proxy codec+ -> (MonadEncode codec () -> encoded)+ -> (MonadDecode codec a -> encoded -> (Either err a, encoded))+ -> a+ -> Property+pRoundTrip pCodec runEncode runDecode expected =+ actual === (Right expected, mempty)+ where+ encoded = runEncode (encode pCodec expected)+ actual = runDecode (decode pCodec) encoded
+ test/Data/SerDoc/Test/Info.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.SerDoc.Test.Info+where++import Test.Tasty+import Test.Tasty.QuickCheck++import Data.SerDoc.Info++tests :: TestTree+tests = testGroup "Info"+ [ testGroup "FieldSize"+ [ testProperty "KnownFieldSize" pKnownFieldSizeKnown+ , testProperty "FieldSizeWithinExpectedLimits" pFieldSizeWithinExpectedLimits+ ]+ ]++pKnownFieldSizeKnown :: KnownFieldSize -> Property+pKnownFieldSizeKnown (KnownFieldSize _ s) =+ knownSize s =/= Nothing++pFieldSizeWithinExpectedLimits :: AnyFieldSize -> Property+pFieldSizeWithinExpectedLimits (AnyFieldSize size s) =+ let actual = knownSize s+ in+ case actual of+ Nothing -> label "unknown size" $ property True+ Just actualSize -> do+ label "known size" . property $ actualSize <= size++-- * Helpers++data KnownFieldSize = KnownFieldSize Int FieldSize+ deriving (Show, Eq)++data AnyFieldSize = AnyFieldSize Int FieldSize+ deriving (Show, Eq)++instance Arbitrary KnownFieldSize where+ arbitrary = getSize >>= genKnownFieldSize+ shrink (KnownFieldSize size s) = KnownFieldSize size <$> shrinkFieldSize s++instance Arbitrary AnyFieldSize where+ arbitrary = do+ size <- getSize+ AnyFieldSize size <$> genFieldSize False size+ shrink (AnyFieldSize size s) = AnyFieldSize size <$> shrinkFieldSize s++shrinkFieldSize :: FieldSize -> [FieldSize]+shrinkFieldSize UnknownSize =+ []+shrinkFieldSize (VarSize name) =+ VarSize <$> shrink name+shrinkFieldSize (FixedSize n) =+ FixedSize <$> shrink n+shrinkFieldSize (RangeSize a b) =+ fmap (\b' -> RangeSize a b') (shrinkFieldSize b) +++ fmap (\a' -> RangeSize a' b) (shrinkFieldSize a) +++ [ a, b ]+shrinkFieldSize (BinopSize op a b) =+ fmap (\b' -> BinopSize op a b') (shrinkFieldSize b) +++ fmap (\a' -> BinopSize op a' b) (shrinkFieldSize a) +++ [ a, b ]+shrinkFieldSize EnumSize =+ []+++genFieldSize :: Bool -> Int -> Gen FieldSize+genFieldSize onlyKnown n+ = oneof $+ [ return $ FixedSize n ] +++ [ VarSize <$> arbitrary+ | not onlyKnown+ ] +++ [ pure UnknownSize+ | not onlyKnown+ ] +++ [ do+ a <- chooseInt (1, n - 1)+ RangeSize+ <$> genFieldSize onlyKnown a+ <*> genFieldSize onlyKnown (n - 1)+ | n > 1+ , not onlyKnown+ ] +++ [ do+ a <- chooseInt (1, n - 1)+ BinopSize FSPlus+ <$> genFieldSize onlyKnown a+ <*> genFieldSize onlyKnown (n - a)+ | n >= 1+ ] +++ [ do+ a <- chooseInt (2, n - 1)+ BinopSize FSMul+ <$> genFieldSize onlyKnown a+ <*> genFieldSize onlyKnown (n `div` a)+ | n >= 2+ ] +++ [ do+ a <- chooseInt (1, n - 1)+ BinopSize FSMax+ <$> genFieldSize onlyKnown a+ <*> genFieldSize onlyKnown (n - 1)+ | n >= 1+ ] +++ [ do+ a <- chooseInt (1, n - 1)+ BinopSize FSMax+ <$> genFieldSize onlyKnown (n - 1)+ <*> genFieldSize onlyKnown a+ | n >= 1+ ] +++ [ do+ a <- chooseInt (1, n - 1)+ BinopSize FSMin+ <$> genFieldSize onlyKnown (n - 1)+ <*> genFieldSize onlyKnown a+ | n >= 1+ ] +++ [ do+ a <- chooseInt (1, n - 1)+ BinopSize FSMin+ <$> genFieldSize onlyKnown a+ <*> genFieldSize onlyKnown (n - 1)+ | n >= 1+ ]+ ++genKnownFieldSize :: Int -> Gen KnownFieldSize+genKnownFieldSize size = KnownFieldSize size <$> genFieldSize True size++genField :: Int -> Gen (FieldInfo codec)+genField 0 = genConstBasicField+genField fuel =+ oneof+ [ genConstBasicField+ , genAnnField fuel+ ]++genConstBasicField :: Gen (FieldInfo codec)+genConstBasicField =+ basicField <$> arbitrary <*> (FixedSize <$> arbitrarySizedNatural)++genAnnField :: Int -> Gen (FieldInfo codec)+genAnnField fuel =+ annField <$> arbitrary <*> genField (fuel - 1)
+ test/Main.hs view
@@ -0,0 +1,16 @@+module Main+where++import Test.Tasty++import qualified Data.SerDoc.Test.Class as Class+import qualified Data.SerDoc.Test.Info as Info++tests :: TestTree+tests = testGroup "serdoc"+ [ Class.tests+ , Info.tests+ ]++main :: IO ()+main = defaultMain tests