packages feed

registry-messagepack (empty) → 0.1.0.0

raw patch · 12 files changed

+748/−0 lines, 12 filesdep +basedep +containersdep +msgpacksetup-changed

Dependencies added: base, containers, msgpack, protolude, registry, registry-hedgehog, tasty, template-haskell, text, time, transformers, vector

Files

+ LICENSE.txt view
@@ -0,0 +1,16 @@+Copyright (c) 2022 Eric Torreborre <etorreborre@yahoo.com>++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. Neither the name of specs nor the names of its contributors may be used to endorse or promote+products derived from this software without specific prior written permission.++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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ registry-messagepack.cabal view
@@ -0,0 +1,127 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           registry-messagepack+version:        0.1.0.0+synopsis:       MessagePack encoders / decoders+description:    This library provides encoders / decoders which can be easily customized for the MessagePack format.+category:       Data+maintainer:     etorreborre@yahoo.com+license:        MIT+license-file:   LICENSE.txt+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/etorreborre/registry-messagepack++library+  exposed-modules:+      Data.Registry.MessagePack.Decoder+      Data.Registry.MessagePack.Encoder+      Data.Registry.MessagePack.TH+  other-modules:+      Paths_registry_messagepack+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      DefaultSignatures+      EmptyCase+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NoImplicitPrelude+      OverloadedStrings+      PatternSynonyms+      Rank2Types+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns+  build-depends:+      base >=4.7 && <5+    , containers >=0.2 && <1+    , msgpack >=1.0 && <2+    , protolude ==0.3.*+    , registry ==0.2.*+    , template-haskell >=2.13 && <3.0+    , text ==1.*+    , transformers >=0.5 && <2+    , vector >=0.1 && <1+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      AutoDiscoveredSpecs+      Test.Data.Registry.MessagePack.DataTypes+      Test.Data.Registry.MessagePack.DecoderSpec+      Test.Data.Registry.MessagePack.EncoderSpec+      Test.Data.Registry.MessagePack.RecursiveSpec+      Paths_registry_messagepack+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      DefaultSignatures+      EmptyCase+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NoImplicitPrelude+      OverloadedStrings+      PatternSynonyms+      Rank2Types+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults -optP-Wno-nonportable-include-path+  build-depends:+      base >=4.7 && <5+    , containers >=0.2 && <1+    , msgpack >=1.0 && <2+    , protolude ==0.3.*+    , registry ==0.2.*+    , registry-hedgehog+    , tasty+    , template-haskell >=2.13 && <3.0+    , text ==1.*+    , time+    , transformers >=0.5 && <2+    , vector >=0.1 && <1+  default-language: Haskell2010
+ src/Data/Registry/MessagePack/Decoder.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++{-+  A Decoder is used to decode a MessagePack Object into a specific data type+  This module provides several functions to create decoders and assemble them into a registry of encoders.+-}+module Data.Registry.MessagePack.Decoder where++import Control.Monad.Fail+import Data.List (nub)+import Data.MessagePack+import Data.Registry hiding (Result)+import Data.Registry.Internal.Types+import Data.Registry.MessagePack.TH+import qualified Data.Vector as Vector+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude hiding (Type)+import Prelude (String)++-- * DECODER DATA TYPE++newtype Decoder a = Decoder {decode :: Object -> Result a}++instance Functor Decoder where+  fmap f (Decoder d) = Decoder (fmap f . d)++instance Applicative Decoder where+  pure a = Decoder (const (pure a))+  f <*> a = uncurry ($) <$> decoderAp f a++decoderAp :: Decoder a -> Decoder b -> Decoder (a, b)+decoderAp (Decoder da) (Decoder db) = Decoder $ \case+  o@(ObjectArray ls) ->+    case reverse (toList ls) of+      b : as -> (,) <$> da (ObjectArray $ Vector.fromList $ reverse as) <*> db b+      [] -> (,) <$> da o <*> db o+  o -> (,) <$> da o <*> db o++-- * DECODING++-- | Use a Decoder to decode a ByteString into the desired type+decodeByteString :: forall a. (Typeable a) => Decoder a -> ByteString -> Either Text a+decodeByteString d bs =+  case unpack' bs of+    Left e -> Left $ "cannot unpack the bytestring as an Object: " <> show e <> ". The bytestring is: " <> show bs+    Right o ->+      case decodeObject d o of+        Right a -> pure a+        Left e -> Left $ "Error: " <> toS e <> ". Cannot decode " <> toS (showType @a) <> " from the Object: " <> show o++-- | Use a Decoder to decode an Object into the desired type+decodeObject :: Decoder a -> Object -> Either Text a+decodeObject (Decoder d) object =+  case d object of+    Success a -> Right a+    Error e -> Left (toS e)++-- * CREATING DECODERS++-- | Add a Decoder a to a registry of decoders when a MessagePack a instance exists+--   usage: decoders = messagePackDecoder @a <: otherDecoders+messagePackDecoder :: forall a. (MessagePack a, Typeable a) => Typed (Decoder a)+messagePackDecoder = fun (messagePackDecoderOf @a)++messagePackDecoderOf :: MessagePack a => Decoder a+messagePackDecoderOf = Decoder fromObject++-- * COMBINATORS++-- | Add a Maybe (Decoder a) to a registry of decoders+--   usage: decoders = decodeMaybeOf @a <: otherDecoders+--   the list of otherDecoders must contain a Decoder a+--   otherwise there will be a compilation error+decodeMaybeOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder (Maybe a))+decodeMaybeOf = fun (maybeOfDecoder @a)++maybeOfDecoder :: forall a. Decoder a -> Decoder (Maybe a)+maybeOfDecoder (Decoder d) = Decoder $ \case+  ObjectNil -> pure Nothing+  just -> Just <$> d just++-- | Add a Maybe (a, b) to a registry of decoders+--   usage: decoders = decodePairOf @a @b <: otherDecoders+--   the list of otherDecoders must contain a Decoder a and a Decoder b+--   otherwise there will be a compilation error+decodePairOf :: forall a b. (Typeable a, Typeable b) => Typed (Decoder a -> Decoder b -> Decoder (a, b))+decodePairOf = fun (pairOfDecoder @a @b)++pairOfDecoder :: forall a b. (Typeable a, Typeable b) => Decoder a -> Decoder b -> Decoder (a, b)+pairOfDecoder (Decoder a) (Decoder b) = Decoder $ \case+  ObjectArray [oa, ob] -> (,) <$> a oa <*> b ob+  other -> Error $ "not a pair of " <> showType @a <> "," <> showType @b <> ": " <> show other++-- | Add a Maybe (a, b, c) to a registry of decoders+--   usage: decoders = decodeTripleOf @a @b @c <: otherDecoders+--   the list of otherDecoders must contain a Decoder a, a Decoder b and a Decoder c+--   otherwise there will be a compilation error+decodeTripleOf :: forall a b c. (Typeable a, Typeable b, Typeable c) => Typed (Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c))+decodeTripleOf = fun (tripleOfDecoder @a @b @c)++tripleOfDecoder :: forall a b c. (Typeable a, Typeable b, Typeable c) => Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)+tripleOfDecoder (Decoder a) (Decoder b) (Decoder c) = Decoder $ \case+  ObjectArray [oa, ob, oc] -> (,,) <$> a oa <*> b ob <*> c oc+  other -> Error $ "not a triple of " <> showType @a <> "," <> showType @b <> "," <> showType @c <> ": " <> show other++-- | Add a Decoder [a] to a registry of decoders+--   usage: decoders = decodeListOf @a <: otherDecoders+--   the list of otherDecoders must contain a Decoder a+--   otherwise there will be a compilation error+decodeListOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder [a])+decodeListOf = fun (listOfDecoder @a)++listOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder [a]+listOfDecoder (Decoder a) = Decoder $ \case+  ObjectArray os -> for (toList os) a+  other -> Error $ "not a list of " <> showType @a <> ": " <> show other++-- | Add a Decoder (NonEmpty a) to a registry of decoders+--   usage: decoders = decodeNonEmptyOf @a <: otherDecoders+--   the list of otherDecoders must contain a Decoder a+--   otherwise there will be a compilation error+decodeNonEmptyOf :: forall a. (Typeable a) => Typed (Decoder a -> Decoder (NonEmpty a))+decodeNonEmptyOf = fun (nonEmptyOfDecoder @a)++nonEmptyOfDecoder :: forall a. (Typeable a) => Decoder a -> Decoder (NonEmpty a)+nonEmptyOfDecoder (Decoder a) = Decoder $ \case+  ObjectArray values ->+    case toList values of+      [] -> Error $ "expected a NonEmpty of " <> showType @a+      o : os -> (:|) <$> a o <*> for os a+  other -> Error $ "not a list of " <> showType @a <> ": " <> show other++showType :: forall a. (Typeable a) => String+showType = show (typeRep (Proxy :: Proxy a))++-- * TEMPLATE HASKELL++-- | Make a Decoder for a given data type+--   Usage: $(makeDecoder ''MyDataType <: otherDecoders)+makeDecoder :: Name -> ExpQ+makeDecoder typeName = appE (varE $ mkName "fun") $ do+  info <- reify typeName+  case info of+    TyConI (NewtypeD _context _name _typeVars _kind (RecC constructor [(_, _, other)]) _deriving) -> do+      -- \(a::Decoder OldType) -> fmap NewType d+      lamE [sigP (varP $ mkName "d") (appT (conT $ mkName "Decoder") (pure other))] (appE (appE (varE $ mkName "fmap") (conE . mkName $ show constructor)) (varE $ mkName "d"))+    TyConI (NewtypeD _context _name _typeVars _kind (NormalC constructor [(_, other)]) _deriving) -> do+      -- \(a::Decoder OldType) -> fmap NewType d+      lamE [sigP (varP $ mkName "d") (appT (conT $ mkName "Decoder") (pure other))] (appE (appE (varE $ mkName "fmap") (conE . mkName $ show constructor)) (varE $ mkName "d"))+    TyConI (DataD _context _name _typeVars _kind constructors _deriving) -> do+      case constructors of+        [] -> do+          qReport True "can not make an Decoder for an empty data type"+          fail "decoders creation failed"+        [c] -> makeConstructorDecoder typeName c+        _ -> makeConstructorsDecoder typeName constructors+    other -> do+      qReport True ("can only create decoders for an ADT, got: " <> show other)+      fail "decoders creation failed"++-- | Make a Decoder for a single Constructor, where each field of the constructor is encoded as an element of an ObjectArray+makeConstructorDecoder :: Name -> Con -> ExpQ+makeConstructorDecoder typeName c = do+  ts <- typesOf c+  cName <- nameOf c+  let decoderParameters = (\(t, n) -> sigP (varP (mkName $ "d" <> show n)) (appT (conT $ mkName "Decoder") (pure t))) <$> zip ts [0 ..]+  let paramP = varP (mkName "o")+  let paramE = varE (mkName "o")+  let paramsP = (\n -> varP $ mkName $ "o" <> show n) <$> [0 .. length ts -1]+  let matchClause =+        match+          (conP (mkName "ObjectArray") [viewP (varE (mkName "toList")) (listP paramsP)])+          (normalB (applyDecoder cName [0 .. length ts - 1]))+          []++  let decoded = caseE paramE [matchClause, makeErrorClause typeName]++  -- (\(d1::Decoder Type1) (d2::Decoder Type2) ... -> Decoder (\case+  --     ObjectArray (toList -> [o1, o2, ...]) -> Constructor <$> decode d1 o1 <*> decode d2 o2 ...))+  --     other -> Error ("not a valid " <> constructorType <> ": " <> show other)+  lamE decoderParameters (appE (conE (mkName "Decoder")) (lamE [paramP] decoded))++-- | Make a Decoder for a each Constructor of a data type:+--     - each constructor is specified by an ObjectArray [ObjectInt n, o1, o2, ...]+--     - n specifies the number of the constructor+--     - each object in the array represents a constructor field+makeConstructorsDecoder :: Name -> [Con] -> ExpQ+makeConstructorsDecoder typeName cs = do+  ts <- nub . join <$> for cs typesOf+  let decoderParameters = (\(t, n) -> sigP (varP (mkName $ "d" <> show n)) (appT (conT $ mkName "Decoder") (pure t))) <$> zip ts [0 ..]+  let paramP = varP (mkName "o")+  let paramE = varE (mkName "o")+  let matchClauses = uncurry (makeMatchClause ts) <$> zip cs [0 ..]+  let errorClause = makeErrorClause typeName+  let decoded = caseE paramE (matchClauses <> [errorClause])++  -- (\(d1::Decoder Type1) (d2::Decoder Type2) ... -> Decoder (\case+  --     ObjectArray (toList -> [ObjectInt n, o1, o2, ...]) -> Constructor <$> decode d1 o1 <*> decode d2 o2 ...))+  --     other -> Error ("not a valid " <> constructorType <> ": " <> show other)+  lamE decoderParameters (appE (conE (mkName "Decoder")) (lamE [paramP] decoded))++-- | Return an error if an object is not an ObjectArray as expected+--   other -> Error (mconcat ["not a valid ", show typeName, ": ", show other])+makeErrorClause :: Name -> MatchQ+makeErrorClause typeName = do+  let errorMessage =+        appE (varE $ mkName "mconcat") $+          listE+            [ litE (StringL "not a valid "),+              litE (StringL $ show typeName),+              litE (StringL ": "),+              appE (varE $ mkName "show") (varE $ mkName "_1")+            ]+  match (varP $ mkName "_1") (normalB (appE (conE $ mkName "Error") errorMessage)) []++-- | Decode the nth constructor of a data type+makeMatchClause :: [Type] -> Con -> Integer -> MatchQ+makeMatchClause allTypes c constructorIndex = do+  ts <- typesOf c+  constructorTypes <- fmap snd <$> indexConstructorTypes allTypes ts+  cName <- nameOf c+  let paramsP = conP (mkName "ObjectInt") [litP (IntegerL constructorIndex)] : ((\n -> varP $ mkName $ "o" <> show n) <$> constructorTypes)+  match+    (conP (mkName "ObjectArray") [viewP (varE (mkName "toList")) (listP paramsP)])+    (normalB (applyDecoder cName constructorTypes))+    []++-- ConstructorName <$> decode d1 o1 <*> decode d2 o2 ...+applyDecoder :: Name -> [Int] -> ExpQ+applyDecoder cName [] = appE (varE $ mkName "pure") (conE cName)+applyDecoder cName (n : ns) = do+  let cons = appE (varE $ mkName "pure") (conE cName)+  foldr (\i r -> appE (appE (varE (mkName "ap")) r) $ decodeAt i) (appE (appE (varE (mkName "ap")) cons) $ decodeAt n) (reverse ns)+  where+    decodeAt i = appE (appE (varE $ mkName "decode") (varE $ mkName ("d" <> show i))) (varE $ mkName $ "o" <> show i)
+ src/Data/Registry/MessagePack/Encoder.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++{-+  An Encoder is used to encode a specific data type into a MessagePack Object+  This module provides several functions to create encoders and assemble them into a registry of encoders.+-}++module Data.Registry.MessagePack.Encoder where++import Control.Monad.Fail+import Data.Functor.Contravariant+import Data.List (nub)+import Data.MessagePack+import Data.Registry hiding (Result)+import Data.Registry.Internal.Types+import Data.Registry.MessagePack.TH+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude hiding (Type)++-- * ENCODER DATA TYPE++newtype Encoder a = Encoder {encode :: a -> Object}++instance Contravariant Encoder where+  contramap f (Encoder a) = Encoder (a . f)++-- * ENCODE VALUES++encodeByteString :: Encoder a -> a -> ByteString+encodeByteString (Encoder e) = pack' . e++-- * CREATE ENCODERS++-- | Create an encoder from a MessagePack instance+messagePackEncoder :: forall a. (MessagePack a, Typeable a) => Typed (Encoder a)+messagePackEncoder = fun (messagePackEncoderOf @a)++messagePackEncoderOf :: MessagePack a => Encoder a+messagePackEncoderOf = Encoder toObject++-- * COMBINATORS++-- | Create an Encoder for a (Maybe a)+encodeMaybeOf :: forall a. (Typeable a) => Typed (Encoder a -> Encoder (Maybe a))+encodeMaybeOf = fun (maybeOfEncoder @a)++maybeOfEncoder :: Encoder a -> Encoder (Maybe a)+maybeOfEncoder (Encoder e) = Encoder $ \case+  Nothing -> ObjectNil+  Just a -> e a++-- | Create an Encoder for a pair (a, b)+encodePairOf :: forall a b. (Typeable a, Typeable b) => Typed (Encoder a -> Encoder b -> Encoder (a, b))+encodePairOf = fun (pairOfEncoder @a @b)++pairOfEncoder :: Encoder a -> Encoder b -> Encoder (a, b)+pairOfEncoder (Encoder ea) (Encoder eb) =+  Encoder $ \(a, b) -> ObjectArray [ea a, eb b]++-- | Create an Encoder for a tripe (a, b, c)+encodeTripleOf :: forall a b c. (Typeable a, Typeable b, Typeable c) => Typed (Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c))+encodeTripleOf = fun (tripleOfEncoder @a @b @c)++tripleOfEncoder :: Encoder a -> Encoder b -> Encoder c -> Encoder (a, b, c)+tripleOfEncoder (Encoder ea) (Encoder eb) (Encoder ec) =+  Encoder $ \(a, b, c) -> ObjectArray [ea a, eb b, ec c]++-- | Create an Encoder for a list [a]+encodeListOf :: forall a. (Typeable a) => Typed (Encoder a -> Encoder [a])+encodeListOf = fun (listOfEncoder @a)++listOfEncoder :: Encoder a -> Encoder [a]+listOfEncoder (Encoder ea) = Encoder $ \as -> toObject $ ea <$> as++-- | Create an Encoder for a non-empty list (NonEmpty a)+encodeNonEmptyOf :: forall a. (Typeable a) => Typed (Encoder a -> Encoder (NonEmpty a))+encodeNonEmptyOf = fun (nonEmptyOfEncoder @a)++nonEmptyOfEncoder :: Encoder a -> Encoder (NonEmpty a)+nonEmptyOfEncoder (Encoder ea) = Encoder $ \as -> toObject $ ea <$> as++-- * TEMPLATE HASKELL++-- | Make an Encoder for a given data type+--   Usage: $(makeEncoder ''MyDataType <: otherEncoders)+makeEncoder :: Name -> ExpQ+makeEncoder encodedType = appE (varE $ mkName "fun") $ do+  info <- reify encodedType+  case info of+    -- \(ea::Encoder OldType) -> Encoder (\(NewType a) -> encode ea a)+    TyConI (NewtypeD _context _name _typeVars _kind (RecC constructor [(_, _, other)]) _deriving) -> do+      lamE [sigP (varP $ mkName "ea") (appT (conT $ mkName "Encoder") (pure other))] (appE (conE $ mkName "Encoder") (lamE [conP constructor [varP $ mkName "a"]] (appE (appE (varE $ mkName "encode") (varE $ mkName "ea")) (varE $ mkName "a"))))+    -- \(e::Encoder OldType) -> Encoder (\(NewType a) -> encode e a)+    TyConI (NewtypeD _context _name _typeVars _kind (NormalC constructor [(_, other)]) _deriving) -> do+      lamE [sigP (varP $ mkName "ea") (appT (conT $ mkName "Encoder") (pure other))] (appE (conE $ mkName "Encoder") (lamE [conP constructor [varP $ mkName "a"]] (appE (appE (varE $ mkName "encode") (varE $ mkName "ea")) (varE $ mkName "a"))))+    TyConI (DataD _context _name _typeVars _kind constructors _deriving) -> do+      case constructors of+        [] -> do+          qReport True "can not make an Encoder for an empty data type"+          fail "encoders creation failed"+        [c] -> makeConstructorEncoder c+        _ -> makeConstructorsEncoder constructors+    other -> do+      qReport True ("can only create encoders for an ADT, got: " <> show other)+      fail "encoders creation failed"++-- | Make an Encoder for a data type with a single constructor+-- \(e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \(T a0 a1 ...) -> ObjectArray [encode e0 a0, encode e1 a1, ...]+makeConstructorEncoder :: Con -> ExpQ+makeConstructorEncoder c = do+  ts <- typesOf c+  cName <- nameOf c+  let encoderParameters = (\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip ts [0 ..]+  let params = conP (mkName $ show cName) $ (\(_, n) -> varP (mkName $ "a" <> show n)) <$> zip ts [0 ..]+  let values = (\(_, n) -> appE (appE (varE $ mkName "encode") (varE (mkName $ "e" <> show n))) (varE (mkName $ "a" <> show n))) <$> zip ts [0 ..]+  let encoded = appE (conE (mkName "ObjectArray")) (appE (varE (mkName "Data.Vector.fromList")) (listE values))+  lamE encoderParameters (appE (conE (mkName "Encoder")) (lamE [params] encoded))++-- | Make an Encoder for a data type with several constructors+-- \(e0::Encoder A0) (e1::Encoder A1) (e2::Encoder A2) ... -> Encoder $ \case+--    T0  -> ObjectArray [ObjectInt 0]+--    T1 a0 a1 ... -> ObjectArray [ObjectInt 1, encode e0 a0, encode e1 a1, ...]+--    T2 a2 a0 ... -> ObjectArray [ObjectInt 2, encode e2 a2, encode e0 a0, ...]+makeConstructorsEncoder :: [Con] -> ExpQ+makeConstructorsEncoder cs = do+  -- get the types of all the fields of all the constructors+  ts <- nub . join <$> for cs typesOf+  let encoderParameters = (\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip ts [0 ..]+  matchClauses <- for (zip cs [0 ..]) (uncurry $ makeMatchClause ts)+  lamE encoderParameters (appE (conE (mkName "Encoder")) (lamCaseE (pure <$> matchClauses)))++-- | Make the match clause for a constructor given+--    - the list of all the encoder types+--    - the constructor name+--    - the constructor index in the list of all the constructors for the encoded data type+makeMatchClause :: [Type] -> Con -> Integer -> MatchQ+makeMatchClause allTypes c constructorIndex = do+  ts <- typesOf c+  constructorTypes <- indexConstructorTypes allTypes ts+  cName <- nameOf c+  let params = conP (mkName $ show cName) $ (\(_, n) -> varP (mkName $ "a" <> show n)) <$> constructorTypes+  let values = (\(_, n) -> appE (appE (varE $ mkName "encode") (varE (mkName $ "e" <> show n))) (varE (mkName $ "a" <> show n))) <$> constructorTypes+  let index = appE (conE $ mkName "ObjectInt") (litE (integerL constructorIndex))+  let encoded = appE (conE (mkName "ObjectArray")) (appE (varE (mkName "Data.Vector.fromList")) (listE $ index : values))+  match params (normalB encoded) []
+ src/Data/Registry/MessagePack/TH.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++{-+  TemplateHaskell functions+-}++module Data.Registry.MessagePack.TH where++import Control.Monad.Fail+import Data.List (elemIndex)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude hiding (Type)++indexConstructorTypes :: [Type] -> [Type] -> Q [(Type, Int)]+indexConstructorTypes allTypes constructorTypes =+  for constructorTypes $ \t ->+    case elemIndex t allTypes of+      Just n -> pure (t, n)+      Nothing -> fail $ "the type " <> show t <> " cannot be found in the list of all types " <> show allTypes++-- | Get the types of all the fields of a constructor+typesOf :: Con -> Q [Type]+typesOf (NormalC _ types) = pure (snd <$> types)+typesOf (RecC _ types) = pure $ (\(_, _, t) -> t) <$> types+typesOf other = do+  qReport True ("we can only create encoders for normal constructors and records, got: " <> show other)+  fail "encoders creation failed"++nameOf :: Con -> Q Name+nameOf (NormalC n _) = pure n+nameOf (RecC n _) = pure n+nameOf other = do+  qReport True ("we can only create encoders for normal constructors and records, got: " <> show other)+  fail "encoders creation failed"
+ test/AutoDiscoveredSpecs.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-}
+ test/Test/Data/Registry/MessagePack/DataTypes.hs view
@@ -0,0 +1,50 @@+module Test.Data.Registry.MessagePack.DataTypes where++import Data.Time+import Protolude++newtype Identifier = Identifier Int+  deriving (Eq, Show)++newtype Email = Email {_email :: Text}+  deriving (Eq, Show)++newtype DateTime = DateTime {_datetime :: UTCTime}+  deriving (Eq, Show)++data Person = Person {identifier :: Identifier, email :: Email}+  deriving (Eq, Show)++data Delivery+  = NoDelivery+  | ByEmail Email+  | InPerson Person DateTime+  deriving (Eq, Show)++data Path =+  File Int+  | Directory [Path]+  deriving (Eq, Show)++-- * EXAMPLES++email1 :: Email+email1 = Email "me@here.com"++person1 :: Person+person1 = Person (Identifier 123) email1++delivery0 :: Delivery+delivery0 = NoDelivery++delivery1 :: Delivery+delivery1 = ByEmail email1++delivery2 :: Delivery+delivery2 = InPerson person1 datetime1++datetime1 :: DateTime+datetime1 = DateTime $ UTCTime (fromGregorian 2022 4 18) 12++path1 :: Path+path1 = Directory [Directory [Directory [File 1], Directory [File 2]], File 3]
+ test/Test/Data/Registry/MessagePack/DecoderSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.MessagePack.DecoderSpec where++import Control.Monad.Fail+import Data.MessagePack+import Data.Registry+import Data.Registry.MessagePack.Decoder+import Data.Time+import Protolude+import Test.Data.Registry.MessagePack.DataTypes+import Test.Tasty.Hedgehogx++test_decode = test "decode" $ do+  decode (make @(Decoder Delivery) decoders) (ObjectArray [ObjectInt 0]) === Success delivery0+  decode (make @(Decoder Delivery) decoders) (ObjectArray [ObjectInt 1, ObjectStr "me@here.com"]) === Success delivery1+  decode (make @(Decoder Delivery) decoders) (ObjectArray [ObjectInt 2, ObjectArray [ObjectInt 123, ObjectStr "me@here.com"], ObjectStr "2022-04-18T00:00:12.000Z"]) === Success delivery2++-- * HELPERS++decoders :: Registry _ _+decoders =+  $(makeDecoder ''Delivery)+    <: $(makeDecoder ''Person)+    <: $(makeDecoder ''Email)+    <: $(makeDecoder ''Identifier)+    <: fun datetimeDecoder+    <: messagePackDecoder @Text+    <: messagePackDecoder @Int++datetimeDecoder :: Decoder DateTime+datetimeDecoder = Decoder $ \case+  ObjectStr s ->+    case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ toS s of+      Just t -> pure (DateTime t)+      Nothing -> fail ("cannot read a DateTime: " <> toS s)+  other -> Error $ "not a valid DateTime: " <> show other
+ test/Test/Data/Registry/MessagePack/EncoderSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.MessagePack.EncoderSpec where++import Data.MessagePack+import Data.Registry+import Data.Registry.MessagePack.Encoder+import Data.Time+import Data.Vector+import Protolude+import Test.Data.Registry.MessagePack.DataTypes+import Test.Tasty.Hedgehogx++test_encode = test "encode" $ do+  encode (make @(Encoder Delivery) encoders) delivery0 === ObjectArray [ObjectInt 0]+  encode (make @(Encoder Delivery) encoders) delivery1 === ObjectArray [ObjectInt 1, ObjectStr "me@here.com"]+  encode (make @(Encoder Delivery) encoders) delivery2 === ObjectArray [ObjectInt 2, ObjectArray [ObjectInt 123, ObjectStr "me@here.com"], ObjectStr "2022-04-18T00:00:12.000Z"]++-- * HELPERS++encoders :: Registry _ _+encoders =+  $(makeEncoder ''Delivery)+    <: $(makeEncoder ''Person)+    <: $(makeEncoder ''Email)+    <: $(makeEncoder ''Identifier)+    <: fun datetimeEncoder+    <: messagePackEncoder @Text+    <: messagePackEncoder @Int++datetimeEncoder :: Encoder DateTime+datetimeEncoder = Encoder (ObjectStr . toS . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%3QZ" . _datetime)+
+ test/Test/Data/Registry/MessagePack/RecursiveSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.MessagePack.RecursiveSpec where++import Data.MessagePack+import Data.Registry+import Data.Registry.MessagePack.Encoder+import Data.Vector+import Protolude+import Test.Data.Registry.MessagePack.DataTypes+import Test.Tasty.Hedgehogx++{-+  This module shows how to implement an encoder for a recursive data type.+  This could be supported by the makeEncoder function but it is not supported at the moment++-}+test_encode_recursive = test "encode a recursive data type" $ do+  encode (make @(Encoder Path) encoders) path1 === dir [dir [dir [file 1], dir [file 2]], file 3]++-- * HELPERS++dir :: [Object] -> Object+dir os = ObjectArray [ObjectInt 1, ObjectArray $ fromList os]++file :: Int -> Object+file n = ObjectArray [ObjectInt 0, toObject n]++encoders :: Registry _ _+encoders =+  fun pathEncoder+    <: messagePackEncoder @Int++pathEncoder :: Encoder Int -> Encoder Path+pathEncoder intEncoder = do+  let thisEncoder = Encoder $ \case+        File n -> ObjectArray [ObjectInt 0, encode intEncoder n]+        Directory paths -> ObjectArray [ObjectInt 1, ObjectArray (fromList $ encode thisEncoder <$> paths)]+  thisEncoder
+ test/test.hs view
@@ -0,0 +1,5 @@+import AutoDiscoveredSpecs (tests)+import Protolude+import Test.Tasty.Hedgehogx++main = tests >>= defaultMain . groupByModuleName