packages feed

registry-messagepack 0.1.0.3 → 0.2.0.0

raw patch · 14 files changed

+542/−45 lines, 14 filesdep ~msgpack

Dependency ranges changed: msgpack

Files

+ README.md view
@@ -0,0 +1,183 @@+# `registry-messagepack`++##### *It's functions all the way down* <img src="doc/images/unboxed-bottomup.jpg" border="0"/>++### Presentation++This library is an add-on to [`registry`](https://github.com/etorreborre/registry), providing customizable encoders / decoders for [MessagePack](https://msgpack.org/).+The approach taken is to add to a registry a list of functions taking encoders / decoders as parameters and producing encoders / decoders.+Then `registry` is able to assemble all the functions required to make an `Encoder` or a `Decoder` of a given type if the encoders or decoders for its dependencies can+be made out of the registry.++### Encoders++#### Example++Here is an example of creating encoders for a set of related data types:+```+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++import Data.MessagePack+import Data.Registry+import Data.Registry.MessagePack.Encoder+import Data.Time+import Data.Vector+import Protolude++newtype Identifier = Identifier Int+newtype Email = Email { _email :: Text }+newtype DateTime = DateTime { _datetime :: UTCTime }+data Person = Person { identifier :: Identifier, email :: Email }++data Delivery =+    NoDelivery+  | ByEmail Email+  | InPerson Person DateTime++encoders :: Registry _ _+encoders =+  $(makeEncoder ''Delivery)+  <: $(makeEncoder ''Person)+  <: $(makeEncoder ''Email)+  <: $(makeEncoder ''Identifier)+  <: fun datetimeEncoder+  <: messagePackEncoder @Text+  <: messagePackEncoder @Int++datetimeEncoder :: Encoder DateTime+datetimeEncoder = Encoder (ObjectStr . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%3QZ" . _datetime)+```++In the code above most encoders are created with `TemplateHaskell` and the `makeEncoder` function. The other encoders are either:++ - created manually: `dateTimeEncoder` (note that this encoder needs to be added to the registry with `fun`)+ - retrieved from a `MessagePack` instance: `messagePackEncoder @Text`, `messagePackEncoder @Int`++Given the list of `encoders` an `Encoder Person` can be retrieved with:+```+let encoderPerson = make @(Encoder Person) encoders+let encoded = encode encoderPerson (Person (Identifier 123) (Email "me@here.com")) :: Object+```++#### Generated encoders++The `makeEncoder` function makes the following functions:+```+-- makeEncoder ''Identifier+\(e::Encoder Int) -> Encoder $ \(Identifier n) -> encode e n++-- makeEncoder ''Email+\(e::Encoder Text) -> Encoder $ \(Email s) -> encode e s++-- makeEncoder ''Person+\(e1::Encoder Identifier) (e2::Encoder Email) -> Encoder $ \(Person a1 a2) -> ObjectArray [encode e1 a1, encode e2 a2]++-- makeEncoder ''Delivery+\(e1::Encoder Email) (e2::Encoder Person) (e3::Encoder DateTime) -> Encoder $ \case+  NoDelivery -> ObjectArray [ObjectInt 0]+  ByEmail a1 -> ObjectArray [ObjectInt 1, encode e1 a1]+  InPerson a1 a2 -> ObjectArray [ObjectInt 2, encode e1 a1, encode e2 a2]+```++__NOTE__ this function does not support recursive data types (and much less mutually recursive data types)++### Decoders++#### Example++Here is an example of creating decoders for a set of related data types:+```+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++import Data.MessagePack+import Data.Registry+import Data.Registry.MessagePack.Decoder+import Data.Time+import Protolude++newtype Identifier = Identifier Int+newtype Email = Email { _email :: Text }+newtype DateTime = DateTime { _datetime :: UTCTime }+data Person = Person { identifier :: Identifier, email :: Email }++data Delivery =+    NoDelivery+  | ByEmail Email+  | InPerson Person DateTime++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 -> DateTime <$> parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" s+  other -> Error ("not a valid DateTime: " <> show other)+```++In the code above most decoders are created with `TemplateHaskell` and the `makeDecoder` function. The other decoders are either:++ - created manually: `dateTimeDecoder` (note that this decoder needs to be added to the registry with `fun`)+ - retrieved from a `MessagePack` instance: `messagePackDecoder @Text`, `messagePackDecoder @Int`++Given the list of `Decoders` an `Decoder Person` can be retrieved with:+```+let decoderPerson = make @(Decoder Person) decoders+let decoded = decode decoderPerson $ ObjectArray [ObjectInt 123, ObjectStr "me@here.com"]+```++#### Generated decoders++The `makeDecoder` function makes the following functions:+```+-- makeDecoder ''Identifier+\(d::Decoder Int) -> Decoder $ \o -> Identifier <$> decode d o++-- makeDecoder ''Email+\(d::Decoder Text) -> Decoder $ \o -> Email <$> decode d o++-- makeDecoder ''Person+\(d1::Decoder Identifier) (d2::Decoder Email) -> Decoder $ \case+  ObjectArray [o1, o2] -> Person <$> decode d1 o1 <*> decode d2 o2+  other -> Error ("not a valid Person: " <> show other)++-- makeDecoder ''Delivery+\(d1::Decoder Email) (d2::Decoder Person) (d3::Decoder DateTime) -> Decoder $ \case+  ObjectArray [ObjectInt 0] -> pure NoDelivery+  ObjectArray [ObjectInt 1, o1] -> ByEmail <$> decode d1 o1+  ObjectArray [ObjectInt 2, o1, o2] -> InPerson <$> decode d1 o1 <*> decode d2 o2+  other -> Error ("not a valid Delivery: " <> show other)+```++__NOTE__ this function does not support recursive data types (and much less mutually recursive data types)++### Generation options++When using TemplateHaskell to generate encoders and decoders, all type names will be generated as unqualified by default.+You can instead opt for qualified names by specifying an `Options` value:+```+import Data.Registry.MessagePack.Encoder+import Data.Registry.MessagePack.Options++-- DataTypes defines the Email and Person data types+import qualified DataTypes as DT+import qualified Data.Common++encoders =+  <: $(makeEncoderWith defaultOptions {modifyTypeName = qualified} ''DT.Person)+  <: $(makeEncoderWith defaultOptions {modifyTypeName = qualifiedAs "DT"} ''DT.Email)+  <: $(makeEncoderWith defaultOptions {modifyTypeName = qualifiedWithLastName} ''Common.Age)+```++__NOTE__ only the data type and its constructors are qualified when you use `qualifiedXXX` functions
registry-messagepack.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           registry-messagepack-version:        0.1.0.3+version:        0.2.0.0 synopsis:       MessagePack encoders / decoders description:    This library provides encoders / decoders which can be easily customized for the MessagePack format. category:       Data@@ -13,6 +13,8 @@ license:        MIT license-file:   LICENSE.txt build-type:     Simple+extra-source-files:+    README.md  source-repository head   type: git@@ -22,6 +24,7 @@   exposed-modules:       Data.Registry.MessagePack.Decoder       Data.Registry.MessagePack.Encoder+      Data.Registry.MessagePack.Options       Data.Registry.MessagePack.TH   other-modules:       Paths_registry_messagepack@@ -60,7 +63,7 @@   build-depends:       base >=4.7 && <5     , containers >=0.2 && <1-    , msgpack >=1.1 && <2+    , msgpack >=1.2 && <2     , protolude ==0.3.*     , registry ==0.2.*     , template-haskell >=2.13 && <3.0@@ -77,7 +80,12 @@       Test.Data.Registry.MessagePack.DataTypes       Test.Data.Registry.MessagePack.DecoderSpec       Test.Data.Registry.MessagePack.EncoderSpec+      Test.Data.Registry.MessagePack.OptionsSpec+      Test.Data.Registry.MessagePack.QualifiedDecodersSpec+      Test.Data.Registry.MessagePack.QualifiedEncodersSpec       Test.Data.Registry.MessagePack.RecursiveSpec+      Test.Data.Registry.MessagePack.Reexported+      Test.Data.Registry.MessagePack.ReexportedTypesSpec       Paths_registry_messagepack   hs-source-dirs:       test@@ -114,7 +122,7 @@   build-depends:       base >=4.7 && <5     , containers >=0.2 && <1-    , msgpack >=1.1 && <2+    , msgpack >=1.2 && <2     , protolude ==0.3.*     , registry ==0.2.*     , registry-hedgehog
src/Data/Registry/MessagePack/Decoder.hs view
@@ -15,6 +15,7 @@ import Data.MessagePack import Data.Registry hiding (Result) import Data.Registry.Internal.Types+import Data.Registry.MessagePack.Options import Data.Registry.MessagePack.TH import qualified Data.Vector as Vector import Language.Haskell.TH@@ -70,6 +71,13 @@ messagePackDecoderOf :: MessagePack a => Decoder a messagePackDecoderOf = Decoder fromObject +-- | Create a Decoder from a Read instance+readDecoder :: forall a. (Typeable a, Read a) => Typed (Decoder String -> Decoder a)+readDecoder = fun readDecoderOf++readDecoderOf :: forall a. (Read a) => Decoder String -> Decoder a+readDecoderOf ds = Decoder $ decode ds >=> (either Error Success . readEither)+ -- * COMBINATORS  -- | Add a Maybe (Decoder a) to a registry of decoders@@ -143,31 +151,48 @@ -- | Make a Decoder for a given data type --   Usage: $(makeDecoder ''MyDataType <: otherDecoders) makeDecoder :: Name -> ExpQ-makeDecoder typeName = appE (varE $ mkName "fun") $ do+makeDecoder = makeDecoderWith defaultOptions++-- | Make a Decoder for a given data type, where all constructors and decoded types are qualified+--   Usage: $(makeDecoderQualified ''MyDataType <: otherDecoders)+makeDecoderQualified :: Name -> ExpQ+makeDecoderQualified = makeDecoderWith (Options identity)++-- | Make a Decoder for a given data type, where all constructors and decoded types are qualified+--   Usage: $(makeDecoderQualifiedLast ''MyDataType <: otherDecoders)+makeDecoderQualifiedLast :: Name -> ExpQ+makeDecoderQualifiedLast = makeDecoderWith (Options qualifyWithLastName)++-- | Make a Decoder with a given set of options+--   Usage: $(makeDecoderWith (Options qualify) ''MyDataType <: otherDecoders)+makeDecoderWith :: Options -> Name -> ExpQ+makeDecoderWith options 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"))+      let cName = mkName $ show $ makeName options constructor+      lamE [sigP (varP $ mkName "d") (appT (conT $ mkName "Decoder") (pure other))] (appE (appE (varE $ mkName "fmap") (conE cName)) (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"))+      let cName = mkName $ show $ makeName options constructor+      lamE [sigP (varP $ mkName "d") (appT (conT $ mkName "Decoder") (pure other))] (appE (appE (varE $ mkName "fmap") (conE cName)) (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+        [c] -> makeConstructorDecoder options typeName c+        _ -> makeConstructorsDecoder options 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+makeConstructorDecoder :: Options -> Name -> Con -> ExpQ+makeConstructorDecoder options typeName c = do   ts <- typesOf c-  cName <- nameOf c+  cName <- makeName options <$> 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")@@ -178,7 +203,7 @@           (normalB (applyDecoder cName [0 .. length ts - 1]))           [] -  let decoded = caseE paramE [matchClause, makeErrorClause typeName]+  let decoded = caseE paramE [matchClause, makeErrorClause options typeName]    -- (\(d1::Decoder Type1) (d2::Decoder Type2) ... -> Decoder (\case   --     ObjectArray (toList -> [o1, o2, ...]) -> Constructor <$> decode d1 o1 <*> decode d2 o2 ...))@@ -189,14 +214,14 @@ --     - 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+makeConstructorsDecoder :: Options -> Name -> [Con] -> ExpQ+makeConstructorsDecoder options 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 matchClauses = uncurry (makeMatchClause options ts) <$> zip cs [0 ..]+  let errorClause = makeErrorClause options typeName   let decoded = caseE paramE (matchClauses <> [errorClause])    -- (\(d1::Decoder Type1) (d2::Decoder Type2) ... -> Decoder (\case@@ -206,24 +231,24 @@  -- | 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+makeErrorClause :: Options -> Name -> MatchQ+makeErrorClause options typeName = do   let errorMessage =         appE (varE $ mkName "mconcat") $           listE             [ litE (StringL "not a valid "),-              litE (StringL $ show typeName),+              litE (StringL . show $ makeName options 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+makeMatchClause :: Options -> [Type] -> Con -> Integer -> MatchQ+makeMatchClause options allTypes c constructorIndex = do   ts <- typesOf c   constructorTypes <- fmap snd <$> indexConstructorTypes allTypes ts-  cName <- nameOf c+  cName <- makeName options <$> 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)])
src/Data/Registry/MessagePack/Encoder.hs view
@@ -16,10 +16,12 @@ import Data.MessagePack import Data.Registry hiding (Result) import Data.Registry.Internal.Types+import Data.Registry.MessagePack.Options import Data.Registry.MessagePack.TH import Language.Haskell.TH import Language.Haskell.TH.Syntax import Protolude hiding (Type)+import Prelude (String)  -- * ENCODER DATA TYPE @@ -42,6 +44,13 @@ messagePackEncoderOf :: MessagePack a => Encoder a messagePackEncoderOf = Encoder toObject +-- | Create an encoder from a MessagePack instance+showEncoder :: forall a. (Typeable a, Show a) => Typed (Encoder String -> Encoder a)+showEncoder = fun showEncoderOf++showEncoderOf :: forall a. (Show a) => Encoder String -> Encoder a+showEncoderOf e = Encoder $ encode e . show+ -- * COMBINATORS  -- | Create an Encoder for a (Maybe a)@@ -88,35 +97,52 @@ -- | Make an Encoder for a given data type --   Usage: $(makeEncoder ''MyDataType <: otherEncoders) makeEncoder :: Name -> ExpQ-makeEncoder encodedType = appE (varE $ mkName "fun") $ do+makeEncoder = makeEncoderWith defaultOptions++-- | Make an Encoder for a given data type, where all types names are qualified+--   Usage: $(makeEncoderQualified ''MyDataType <: otherEncoders)+makeEncoderQualified :: Name -> ExpQ+makeEncoderQualified = makeEncoderWith (Options qualified)++-- | Make an Encoder for a given data type, where all types names are qualified+--   Usage: $(makeEncoderQualifiedLast ''MyDataType <: otherEncoders)+makeEncoderQualifiedLast :: Name -> ExpQ+makeEncoderQualifiedLast = makeEncoderWith (Options qualifyWithLastName)++-- | Make an Encoder for a given data type with a specific set of options+--   Usage: $(makeEncoderWith (Options qualify) ''MyDataType <: otherEncoders)+makeEncoderWith :: Options -> Name -> ExpQ+makeEncoderWith options 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"))))+      let cName = makeName options constructor+      lamE [sigP (varP $ mkName "ea") (appT (conT $ mkName "Encoder") (pure other))] (appE (conE $ mkName "Encoder") (lamE [conP cName [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"))))+      let cName = makeName options constructor+      lamE [sigP (varP $ mkName "ea") (appT (conT $ mkName "Encoder") (pure other))] (appE (conE $ mkName "Encoder") (lamE [conP cName [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+        [c] -> makeConstructorEncoder options c+        _ -> makeConstructorsEncoder options 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 ..]+makeConstructorEncoder :: Options -> Con -> ExpQ+makeConstructorEncoder options c = do+  types <- typesOf c+  cName <- makeName options <$> nameOf c+  let encoderParameters = (\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip types [0 ..]+  let params = conP (mkName $ show cName) $ (\(_, n) -> varP (mkName $ "a" <> show n)) <$> zip types [0 ..]+  let values = (\(_, n) -> appE (appE (varE $ mkName "encode") (varE (mkName $ "e" <> show n))) (varE (mkName $ "a" <> show n))) <$> zip types [0 ..]   let encoded = appE (conE (mkName "ObjectArray")) (appE (varE (mkName "Data.Vector.fromList")) (listE values))   lamE encoderParameters (appE (conE (mkName "Encoder")) (lamE [params] encoded)) @@ -125,23 +151,23 @@ --    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+makeConstructorsEncoder :: Options -> [Con] -> ExpQ+makeConstructorsEncoder options 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)+  types <- nub . join <$> for cs typesOf+  let encoderParameters = (\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip types [0 ..]+  matchClauses <- for (zip cs [0 ..]) (uncurry $ makeMatchClause options types)   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+makeMatchClause :: Options -> [Type] -> Con -> Integer -> MatchQ+makeMatchClause options allTypes c constructorIndex = do   ts <- typesOf c   constructorTypes <- indexConstructorTypes allTypes ts-  cName <- nameOf c+  cName <- makeName options <$> 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))
+ src/Data/Registry/MessagePack/Options.hs view
@@ -0,0 +1,35 @@+module Data.Registry.MessagePack.Options where++import qualified Data.Text as T+import Protolude++-- | Options used to adjust the creation of encoders/decoders+newtype Options = Options+  { modifyTypeName :: Text -> Text+  }++-- | Default options for adjusting the creation of Encoders/Decoders+defaultOptions :: Options+defaultOptions = Options dropQualifier++-- | Drop the leading names in a qualified name+---  dropQualifier "x.y.z" === "z"+dropQualifier :: Text -> Text+dropQualifier t = fromMaybe t . lastMay $ T.splitOn "." t++-- | This function does not modify type names+qualified :: Text -> Text+qualified  = identity++-- | Provide a specific qualifier to produce type names+---  qualifyAs "a" "x.y.z" === "a.z"+qualifyAs :: Text -> Text -> Text+qualifyAs qualifier t = qualifier <> "." <> dropQualifier t++-- | Keep the last name as the qualifier+---  qualifyWithLastName "x.y.z" === "y.z"+qualifyWithLastName :: Text -> Text+qualifyWithLastName t =+  case reverse $ T.splitOn "." t of+    t1 : t2 : _ -> t2 <> "." <> t1+    _ -> t
src/Data/Registry/MessagePack/TH.hs view
@@ -10,6 +10,7 @@  import Control.Monad.Fail import Data.List (elemIndex)+import Data.Registry.MessagePack.Options import Language.Haskell.TH import Language.Haskell.TH.Syntax import Protolude hiding (Type)@@ -35,3 +36,20 @@ nameOf other = do   qReport True ("we can only create encoders for normal constructors and records, got: " <> show other)   fail "encoders creation failed"++-- | Remove the module name from a qualified name+makeName :: Options -> Name -> Name+makeName options = mkName . toS . modifyTypeName options . show++-- | Return the name of a given type with a modified name based on options+getSimpleTypeName :: Options -> Type -> Name+getSimpleTypeName options (ForallT _ _ ty) = getSimpleTypeName options ty+getSimpleTypeName options (VarT name) = makeName options name+getSimpleTypeName options (ConT name) = makeName options name+getSimpleTypeName options (TupleT n) = makeName options $ tupleTypeName n+getSimpleTypeName options ArrowT = makeName options ''(->)+getSimpleTypeName options ListT = makeName options ''[]+getSimpleTypeName options (AppT t1 t2) = mkName (show (getSimpleTypeName options t1) <> " " <> show (getSimpleTypeName options t2))+getSimpleTypeName options (SigT t _) = getSimpleTypeName options t+getSimpleTypeName options (UnboxedTupleT n) = makeName options $ unboxedTupleTypeName n+getSimpleTypeName _ t = panic $ "getSimpleTypeName: Unknown type: " <> show t
test/Test/Data/Registry/MessagePack/DataTypes.hs view
@@ -1,5 +1,6 @@ module Test.Data.Registry.MessagePack.DataTypes where +import Data.Registry.MessagePack.Options import Data.Time import Protolude @@ -21,11 +22,16 @@   | InPerson Person DateTime   deriving (Eq, Show) -data Path =-  File Int+data Path+  = File Int   | Directory [Path]   deriving (Eq, Show) +data BoxedValues =+  OptionalValue (Maybe Int)+  | ListValue [Text]+  deriving (Eq, Show)+ -- * EXAMPLES  email1 :: Email@@ -48,3 +54,14 @@  path1 :: Path path1 = Directory [Directory [Directory [File 1], Directory [File 2]], File 3]++-- | When options are used with the makeEncoderWith/DecoderWith functions they must+--   be defined in another file+qualifiedAsOptions :: Options+qualifiedAsOptions = Options qualified++qualifiedOptions :: Options+qualifiedOptions = Options $ qualifyAs "Test.Data.Registry.MessagePack.DataTypes"++qualifiedWithLastOptions :: Options+qualifiedWithLastOptions = Options {modifyTypeName = qualifyWithLastName}
test/Test/Data/Registry/MessagePack/DecoderSpec.hs view
@@ -14,11 +14,13 @@ import Protolude import Test.Data.Registry.MessagePack.DataTypes import Test.Tasty.Hedgehogx+import Prelude (String)  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+  decode (make @(Decoder Integer) decoders) (ObjectStr "10000000000000000") === Success 10000000000000000  -- * HELPERS @@ -29,7 +31,9 @@     <: $(makeDecoder ''Email)     <: $(makeDecoder ''Identifier)     <: fun datetimeDecoder+    <: readDecoder @Integer     <: messagePackDecoder @Text+    <: messagePackDecoder @String     <: messagePackDecoder @Int  datetimeDecoder :: Decoder DateTime
test/Test/Data/Registry/MessagePack/EncoderSpec.hs view
@@ -13,11 +13,13 @@ import Protolude import Test.Data.Registry.MessagePack.DataTypes import Test.Tasty.Hedgehogx+import Prelude (String)  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"]+  encode (make @(Encoder Integer) encoders) 10000000000000000 === ObjectStr "10000000000000000"  -- * HELPERS @@ -28,9 +30,10 @@     <: $(makeEncoder ''Email)     <: $(makeEncoder ''Identifier)     <: fun datetimeEncoder+    <: showEncoder @Integer     <: messagePackEncoder @Text+    <: messagePackEncoder @String     <: messagePackEncoder @Int  datetimeEncoder :: Encoder DateTime datetimeEncoder = Encoder (ObjectStr . toS . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%3QZ" . _datetime)-
+ test/Test/Data/Registry/MessagePack/OptionsSpec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.MessagePack.OptionsSpec where++import Data.Registry.MessagePack.Options+import Protolude+import Test.Tasty.Hedgehogx++test_qualifiers = test "qualifiers" $ do+  dropQualifier "x.y.z" === "z"+  dropQualifier "z" === "z"++  qualified "x.y.z" === "x.y.z"+  qualified "z" === "z"++  qualifyAs "a" "x.y.z" === "a.z"+  qualifyAs "a" "z" === "a.z"++  qualifyWithLastName "x.y.z" === "y.z"+  qualifyWithLastName "y.z" === "y.z"+  qualifyWithLastName "z" === "z"
+ test/Test/Data/Registry/MessagePack/QualifiedDecodersSpec.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.QualifiedDecodersSpec 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 Prelude (String)++{-+  This specification checks that decoders built with qualified+  name will compile+-}++decoders :: Registry _ _+decoders =+  $(makeDecoderQualified ''Delivery)+    <: $(makeDecoderQualified ''Person)+    <: $(makeDecoderQualified ''Email)+    <: $(makeDecoderQualified ''Identifier)+    <: fun datetimeDecoder+    <: readDecoder @Integer+    <: messagePackDecoder @Text+    <: messagePackDecoder @String+    <: 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/QualifiedEncodersSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.MessagePack.QualifiedEncodersSpec 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 (qualifiedAsOptions, qualifiedOptions, qualifiedWithLastOptions, BoxedValues (..))+import qualified Test.Data.Registry.MessagePack.DataTypes+import qualified Test.Data.Registry.MessagePack.DataTypes as DataTypes+import Prelude (String)++{-+  This specification checks that encoders built with qualified+  name will compile+-}++encoders :: Registry _ _+encoders =+  $(makeEncoderQualified ''Test.Data.Registry.MessagePack.DataTypes.Delivery)+    <: $(makeEncoderQualified ''Test.Data.Registry.MessagePack.DataTypes.Person)+    <: $(makeEncoderQualified ''Test.Data.Registry.MessagePack.DataTypes.Email)+    -- options can also be used directly+    <: $(makeEncoderWith qualifiedAsOptions ''Test.Data.Registry.MessagePack.DataTypes.Identifier)+    <: $(makeEncoderWith qualifiedOptions ''Test.Data.Registry.MessagePack.DataTypes.Identifier)+    <: $(makeEncoderWith qualifiedWithLastOptions ''Test.Data.Registry.MessagePack.DataTypes.Identifier)+    <: $(makeEncoderWith qualifiedOptions ''BoxedValues)+    <: fun datetimeEncoder+    <: showEncoder @Integer+    <: encodeListOf @Text+    <: encodeMaybeOf @Int+    <: messagePackEncoder @Text+    <: messagePackEncoder @String+    <: messagePackEncoder @Int++datetimeEncoder :: Encoder Test.Data.Registry.MessagePack.DataTypes.DateTime+datetimeEncoder = Encoder (ObjectStr . toS . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%3QZ" . Test.Data.Registry.MessagePack.DataTypes._datetime)
+ test/Test/Data/Registry/MessagePack/Reexported.hs view
@@ -0,0 +1,6 @@+module Test.Data.Registry.MessagePack.Reexported+  ( module Test.Data.Registry.MessagePack.DataTypes,+  )+where++import Test.Data.Registry.MessagePack.DataTypes
+ test/Test/Data/Registry/MessagePack/ReexportedTypesSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.MessagePack.ReexportedTypesSpec where++import Data.MessagePack+import Data.Registry+import Data.Registry.MessagePack.Decoder+import Data.Registry.MessagePack.Encoder+import Data.Time+import qualified Data.Vector+import Protolude+import Test.Data.Registry.MessagePack.Reexported+import Prelude (String, fail)++{-++  In this specification we check that the code compiles+  when we produce non-qualified type names.+  They can then be found in a re-exported module++-}++encoders :: Registry _ _+encoders =+  $(makeEncoder ''Delivery)+    <: $(makeEncoder ''Person)+    <: $(makeEncoder ''Email)+    <: $(makeEncoder ''Identifier)+    <: $(makeEncoder ''BoxedValues)+    <: fun datetimeEncoder+    <: showEncoder @Integer+    <: encodeListOf @Text+    <: encodeMaybeOf @Int+    <: messagePackEncoder @Text+    <: messagePackEncoder @String+    <: messagePackEncoder @Int++datetimeEncoder :: Encoder DateTime+datetimeEncoder = Encoder (ObjectStr . toS . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%3QZ" . _datetime)++decoders :: Registry _ _+decoders =+  $(makeDecoder ''Delivery)+    <: $(makeDecoder ''Person)+    <: $(makeDecoder ''Email)+    <: $(makeDecoder ''Identifier)+    <: $(makeDecoder ''BoxedValues)+    <: fun datetimeDecoder+    <: readDecoder @Integer+    <: decodeListOf @Text+    <: decodeMaybeOf @Int+    <: messagePackDecoder @Text+    <: messagePackDecoder @String+    <: 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