diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,16 @@ +Copyright (c) 2022 Eric Torreborre + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/registry-messagepack.cabal b/registry-messagepack.cabal new file mode 100644 --- /dev/null +++ b/registry-messagepack.cabal @@ -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 diff --git a/src/Data/Registry/MessagePack/Decoder.hs b/src/Data/Registry/MessagePack/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/MessagePack/Decoder.hs @@ -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) diff --git a/src/Data/Registry/MessagePack/Encoder.hs b/src/Data/Registry/MessagePack/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/MessagePack/Encoder.hs @@ -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) [] diff --git a/src/Data/Registry/MessagePack/TH.hs b/src/Data/Registry/MessagePack/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/MessagePack/TH.hs @@ -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" diff --git a/test/AutoDiscoveredSpecs.hs b/test/AutoDiscoveredSpecs.hs new file mode 100644 --- /dev/null +++ b/test/AutoDiscoveredSpecs.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-} diff --git a/test/Test/Data/Registry/MessagePack/DataTypes.hs b/test/Test/Data/Registry/MessagePack/DataTypes.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/DataTypes.hs @@ -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] diff --git a/test/Test/Data/Registry/MessagePack/DecoderSpec.hs b/test/Test/Data/Registry/MessagePack/DecoderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/DecoderSpec.hs @@ -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 diff --git a/test/Test/Data/Registry/MessagePack/EncoderSpec.hs b/test/Test/Data/Registry/MessagePack/EncoderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/EncoderSpec.hs @@ -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) + diff --git a/test/Test/Data/Registry/MessagePack/RecursiveSpec.hs b/test/Test/Data/Registry/MessagePack/RecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/RecursiveSpec.hs @@ -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 diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,5 @@ +import AutoDiscoveredSpecs (tests) +import Protolude +import Test.Tasty.Hedgehogx + +main = tests >>= defaultMain . groupByModuleName