diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,183 @@ +# `registry-messagepack` + +##### *It's functions all the way down* + +### 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 diff --git a/registry-messagepack.cabal b/registry-messagepack.cabal --- a/registry-messagepack.cabal +++ b/registry-messagepack.cabal @@ -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 diff --git a/src/Data/Registry/MessagePack/Decoder.hs b/src/Data/Registry/MessagePack/Decoder.hs --- a/src/Data/Registry/MessagePack/Decoder.hs +++ b/src/Data/Registry/MessagePack/Decoder.hs @@ -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)]) diff --git a/src/Data/Registry/MessagePack/Encoder.hs b/src/Data/Registry/MessagePack/Encoder.hs --- a/src/Data/Registry/MessagePack/Encoder.hs +++ b/src/Data/Registry/MessagePack/Encoder.hs @@ -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)) diff --git a/src/Data/Registry/MessagePack/Options.hs b/src/Data/Registry/MessagePack/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/MessagePack/Options.hs @@ -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 diff --git a/src/Data/Registry/MessagePack/TH.hs b/src/Data/Registry/MessagePack/TH.hs --- a/src/Data/Registry/MessagePack/TH.hs +++ b/src/Data/Registry/MessagePack/TH.hs @@ -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 diff --git a/test/Test/Data/Registry/MessagePack/DataTypes.hs b/test/Test/Data/Registry/MessagePack/DataTypes.hs --- a/test/Test/Data/Registry/MessagePack/DataTypes.hs +++ b/test/Test/Data/Registry/MessagePack/DataTypes.hs @@ -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} diff --git a/test/Test/Data/Registry/MessagePack/DecoderSpec.hs b/test/Test/Data/Registry/MessagePack/DecoderSpec.hs --- a/test/Test/Data/Registry/MessagePack/DecoderSpec.hs +++ b/test/Test/Data/Registry/MessagePack/DecoderSpec.hs @@ -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 diff --git a/test/Test/Data/Registry/MessagePack/EncoderSpec.hs b/test/Test/Data/Registry/MessagePack/EncoderSpec.hs --- a/test/Test/Data/Registry/MessagePack/EncoderSpec.hs +++ b/test/Test/Data/Registry/MessagePack/EncoderSpec.hs @@ -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) - diff --git a/test/Test/Data/Registry/MessagePack/OptionsSpec.hs b/test/Test/Data/Registry/MessagePack/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/OptionsSpec.hs @@ -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" diff --git a/test/Test/Data/Registry/MessagePack/QualifiedDecodersSpec.hs b/test/Test/Data/Registry/MessagePack/QualifiedDecodersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/QualifiedDecodersSpec.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.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 diff --git a/test/Test/Data/Registry/MessagePack/QualifiedEncodersSpec.hs b/test/Test/Data/Registry/MessagePack/QualifiedEncodersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/QualifiedEncodersSpec.hs @@ -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) diff --git a/test/Test/Data/Registry/MessagePack/Reexported.hs b/test/Test/Data/Registry/MessagePack/Reexported.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/Reexported.hs @@ -0,0 +1,6 @@ +module Test.Data.Registry.MessagePack.Reexported + ( module Test.Data.Registry.MessagePack.DataTypes, + ) +where + +import Test.Data.Registry.MessagePack.DataTypes diff --git a/test/Test/Data/Registry/MessagePack/ReexportedTypesSpec.hs b/test/Test/Data/Registry/MessagePack/ReexportedTypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/MessagePack/ReexportedTypesSpec.hs @@ -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