registry-aeson 0.2.0.0 → 0.2.1.0

raw patch · 11 files changed

+334/−238 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +32/−2
• registry-aeson.cabal +4/−2
• src/Data/Registry/Aeson/Decoder.hs +26/−93
• src/Data/Registry/Aeson/Encoder.hs +38/−73
• src/Data/Registry/Aeson/TH.hs +0/−64
• src/Data/Registry/Aeson/TH/Decoder.hs +99/−0
• src/Data/Registry/Aeson/TH/Encoder.hs +67/−0
• src/Data/Registry/Aeson/TH/TH.hs +64/−0
• test/Test/Data/Registry/Aeson/DecoderSpec.hs +1/−1
• test/Test/Data/Registry/Aeson/EncoderSpec.hs +1/−1
• test/Test/Data/Registry/Aeson/RoundtripSpec.hs +2/−2

@@ -54,7 +54,7 @@   <: fun datetimeEncoder   <: jsonEncoder @Text   <: jsonEncoder @Int-  <: val defaultOptions+  <: defaultEncoderOptions  datetimeEncoder :: Encoder DateTime datetimeEncoder = fromValue $ \(DateTime dt) -> do@@ -117,7 +117,7 @@   <: fun dateTimeDecoder   <: jsonDecoder @Text   <: jsonDecoder @Int-  <: val defaultOptions+  <: defaultDecoderOptions  datetimeDecoder :: Decoder DateTime datetimeDecoder = Decoder $ \case@@ -139,6 +139,21 @@ let decoded = decode decoderPerson $ ObjectArray [Number 123, ObjectStr "me@here.com"] ``` +##### Overriding the generated encoders++There is a bit of flexibility in the way encoders are created with TemplateHaskell.++A custom `ConstructorsEncoder` can be added to the registry to tweak the generation:+```+newtype ConstructorEncoder = ConstructorEncoder+  { encodeConstructor :: Options -> FromConstructor -> (Value, Encoding)+  }+```+A `ConstructorEncoder` uses configuration options and type information extracted from+given data type (with TemplateHaskell) in order to produce a `Value` and an `Encoding`.++If necessary you can provide your own options and reuse the default function to produce different encoders.+ #### Generated decoders  The `makeDecoder` function makes the following functions:@@ -163,3 +178,18 @@ ```  __NOTE__ this function does not support recursive data types (and much less mutually recursive data types)++##### Overriding the generated decoders++There is a bit of flexibility in the way decoders are created with TemplateHaskell.++A custom `ConstructorsDecoder` can be added to the registry to tweak the generation:+```+newtype ConstructorsDecoder = ConstructorsDecoder+  { decodeConstructors :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]+  }+```+This function extracts values for a set of constructor definitions and returns `ToConstructor` values+containing a JSON `Value` to be decoded for each field of a given constructor (along with its name).++If necessary you can provide your own options and reuse the default function to produce different decoders.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           registry-aeson-version:        0.2.0.0+version:        0.2.1.0 synopsis:       Aeson encoders / decoders description:    This library provides encoders / decoders which can be easily customized for the Aeson format. category:       Data@@ -24,7 +24,9 @@   exposed-modules:       Data.Registry.Aeson.Decoder       Data.Registry.Aeson.Encoder-      Data.Registry.Aeson.TH+      Data.Registry.Aeson.TH.Decoder+      Data.Registry.Aeson.TH.Encoder+      Data.Registry.Aeson.TH.TH   other-modules:       Paths_registry_aeson   hs-source-dirs:

@@ -9,22 +9,23 @@   A Decoder is used to decode a Aeson 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.Aeson.Decoder where+module Data.Registry.Aeson.Decoder+  ( module Data.Registry.Aeson.Decoder,+    module Data.Registry.Aeson.TH.Decoder,+  )+where -import Control.Monad.Fail import Data.Aeson import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as BL-import Data.List (nub, (\\))+import Data.List ((\\)) import Data.Registry-import Data.Registry.Aeson.TH+import Data.Registry.Aeson.TH.Decoder import Data.Registry.Internal.Types hiding (Value) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as Vector-import Language.Haskell.TH-import Language.Haskell.TH.Syntax import Protolude as P hiding (Type) import Prelude (String, show) @@ -140,92 +141,14 @@ showType :: forall a. (Typeable a) => String showType = P.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 constructor _deriving) ->-      makeConstructorsDecoder typeName [constructor]-    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"-        _ -> makeConstructorsDecoder typeName constructors-    other -> do-      qReport True ("can only create decoders for an ADT, got: " <> P.show other)-      fail "decoders creation failed"---- | Make a decoder for a given data type by extracting just enough metadata about the data type in order to be able---   to parse a Value------   For example for the data type:------   data T = T1 {f1::Int, f2::Int} | T2 Int Int------   we add this function to the registry:------   \opts d1 d2 d3 -> Decoder $ \v ->---     decodeFromDefinitions opts v $ \case---       ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...---       ToConstructor "T2" [v1, v2]-> T2 <$> d1 v1 <*> d3 v2 ...---       other -> Left ("cannot decode " <> valueToText v)------   The \case function is the only one which needs to be generated in order to match the exact shape of the---   constructors to instantiate-makeConstructorsDecoder :: Name -> [Con] -> ExpQ-makeConstructorsDecoder typeName cs = do-  ts <- nub . join <$> for cs typesOf-  let decoderParameters = sigP (varP (mkName "os")) (conT $ mkName "Options") : ((\(t, n) -> sigP (varP (mkName $ "d" <> P.show n)) (appT (conT $ mkName "Decoder") (pure t))) <$> zip ts [0 ..])-  -- makeToConstructors os [Constructor "T1" ["f1", "f2"], Constructor "T2" []] v-  let paramP = varP (mkName "v")-  constructorDefs <- for cs $ \c -> do-    cName <- dropQualified <$> nameOf c-    fields <- fmap (litE . StringL . P.show . dropQualified) <$> fieldsOf c-    fieldTypes <- fmap (litE . StringL . P.show . getSimpleTypeName) <$> typesOf c-    varE (mkName "makeConstructorDef") `appE` (litE . StringL $ P.show cName) `appE` listE fields `appE` listE fieldTypes-  let matchClauses = makeMatchClause typeName ts <$> cs-  let matchFunction = lamCaseE (matchClauses <> [makeErrorClause typeName])-  let resolveFunction = varE (mkName "decodeFromDefinitions") `appE` varE (mkName "os") `appE` listE (pure <$> constructorDefs) `appE` varE (mkName "v") `appE` matchFunction-  lamE decoderParameters (appE (conE (mkName "Decoder")) (lamE [paramP] resolveFunction))---- | Decode the nth constructor of a data type---    ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...-makeMatchClause :: Name -> [Type] -> Con -> MatchQ-makeMatchClause typeName allTypes c = do-  ts <- typesOf c-  constructorTypes <- fmap snd <$> indexConstructorTypes allTypes ts-  cName <- dropQualified <$> nameOf c-  let fieldsP = listP $ (\i -> varP $ mkName ("v" <> P.show i)) <$> constructorTypes-  match-    (conP (mkName "ToConstructor") [litP (StringL . P.show $ cName), fieldsP])-    (normalB (applyDecoder typeName cName constructorTypes))-    []+-- * DEFAULT VALUES --- | Return an error the json value cannot be decoded with a constructor name and some values-makeErrorClause :: Name -> MatchQ-makeErrorClause typeName = do-  let errorMessage =-        (varE (mkName "<>") `appE` litE (StringL ("cannot use this constructor to create an instance of type '" <> P.show typeName <> "': ")))-          `appE` (varE (mkName "show") `appE` varE (mkName "_1"))-  match (varP $ mkName "_1") (normalB (appE (conE $ mkName "Left") errorMessage)) []+defaultDecoderOptions :: Registry _ _+defaultDecoderOptions =+  fun defaultConstructorsDecoder+    <: val defaultOptions --- ConstructorName <$> decodeFieldValue d1 o1 <*> decodeFieldValue d2 o2 ...-applyDecoder :: Name -> Name -> [Int] -> ExpQ-applyDecoder _typeName cName [] = appE (varE $ mkName "pure") (conE cName)-applyDecoder typeName 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 =-      varE (mkName "decodeFieldValue") `appE` varE (mkName ("d" <> P.show i))-        `appE` (litE . StringL . P.show . dropQualified $ typeName)-        `appE` (litE . StringL . P.show . dropQualified $ cName)-        `appE` varE (mkName ("v" <> P.show i))+-- * TEMPLATE HASKELL  -- | Use a decoder to decode a field --   The constructor name, the type where the field is inserted and the field definition@@ -281,12 +204,22 @@  -- | Try to find the appropriate constructor definition encoded in the json value --   then try to decode all its fields with decoding function-decodeFromDefinitions :: Options -> [ConstructorDef] -> Value -> (ToConstructor -> Either Text a) -> Either Text a-decodeFromDefinitions options constructorDefs value build = do-  let toConstructors = fmap build <$> makeToConstructors options constructorDefs value+decodeFromDefinitions :: Options -> ConstructorsDecoder -> [ConstructorDef] -> Value -> (ToConstructor -> Either Text a) -> Either Text a+decodeFromDefinitions options constructorsDecoder constructorDefs value build = do+  let toConstructors = fmap build <$> decodeConstructors constructorsDecoder options constructorDefs value   case toConstructors of     Left e -> Left e     Right es -> foldEither es++-- | This function extracts values for a set of constructor definitions+--   The TemplateHaskell function makeDecoder can then use the constructor name+--   and constructor field value to create an actual constructor instance for a given data type+newtype ConstructorsDecoder = ConstructorsDecoder+  { decodeConstructors :: Options -> [ConstructorDef] -> Value -> Either Text [ToConstructor]+  }++defaultConstructorsDecoder :: ConstructorsDecoder+defaultConstructorsDecoder = ConstructorsDecoder makeToConstructors  -- | Try to extract possible constructor values based on: --     - the encoding options

@@ -8,22 +8,22 @@   This module provides several functions to create encoders and assemble them into a registry of encoders. -} -module Data.Registry.Aeson.Encoder where+module Data.Registry.Aeson.Encoder+  ( module Data.Registry.Aeson.Encoder,+    module Data.Registry.Aeson.TH.Encoder,+  )+where -import Control.Monad.Fail import Data.Aeson import Data.Aeson.Encoding.Internal import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as BL (toStrict) import Data.Functor.Contravariant-import Data.List (nub) import Data.Registry-import Data.Registry.Aeson.TH+import Data.Registry.Aeson.TH.Encoder import Data.Registry.Internal.Types hiding (Value) import qualified Data.Vector as V-import Language.Haskell.TH-import Language.Haskell.TH.Syntax import Protolude hiding (Type, list)  -- * ENCODER DATA TYPE@@ -105,58 +105,25 @@ array :: [Value] -> Value array = Array . V.fromList --- * TEMPLATE HASKELL+-- * DEFAULT VALUES --- | 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-    TyConI (NewtypeD _context _name _typeVars _kind constructor _deriving) ->-      makeConstructorsEncoder [constructor]-    TyConI (DataD _context _name _typeVars _kind constructors _deriving) ->-      makeConstructorsEncoder constructors-    other -> do-      qReport True ("can only create encoders for an ADT, got: " <> show other)-      fail "encoders creation failed"+defaultEncoderOptions :: Registry _ _+defaultEncoderOptions =+  fun defaultConstructorEncoder+    <: val defaultOptions --- \(o::Options) (e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \a ->---   case a of---     T1 a0 a1 ... -> makeEncoderFromConstructor o (FromConstructor names types "T1" fieldNames [encode e0 a0, encode e1 a1, ...])---     T2 a0 a4 ... -> makeEncoderFromConstructor o (FromConstructor names types "T2" fieldNames [encode e0 a0, encode e4 a4, ...])-makeConstructorsEncoder :: [Con] -> ExpQ-makeConstructorsEncoder cs = do-  -- get the types of all the fields of all the constructors-  ts <- nub . join <$> for cs typesOf-  constructorsNames <- for cs nameOf-  let options = sigP (varP (mkName "os")) (conT $ mkName "Options")-  let encoderParameters = options : ((\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip ts [0 ..])-  matchClauses <- for cs $ makeMatchClause constructorsNames ts-  lamE encoderParameters (appE (conE (mkName "Encoder")) (lamCaseE (pure <$> matchClauses)))+-- * BUILDING ENCODERS --- | 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---   T1 a0 a1 ... -> makeEncoderFromConstructor o (FromConstructor names types cName fieldNames values)-makeMatchClause :: [Name] -> [Type] -> Con -> MatchQ-makeMatchClause constructorNames allTypes c = do-  ts <- typesOf c-  constructorTypes <- indexConstructorTypes allTypes ts-  cName <- dropQualified <$> nameOf c-  let names = listE $ litE . StringL . show . dropQualified <$> constructorNames-  let types = listE $ litE . StringL . show <$> allTypes-  fields <- fieldsOf c-  let fieldNames = listE $ litE . StringL . show . dropQualified <$> fields-  let params = conP (mkName $ show cName) $ (\(_, n) -> varP (mkName $ "a" <> show n)) <$> constructorTypes-  let values = listE $ (\(_, n) -> appE (appE (varE $ mkName "encode") (varE (mkName $ "e" <> show n))) (varE (mkName $ "a" <> show n))) <$> constructorTypes-  let encoded =-        varE (mkName "makeEncoderFromConstructor")-          `appE` varE (mkName "os")-          `appE` (conE (mkName "FromConstructor") `appE` names `appE` types `appE` litE (StringL $ show cName) `appE` fieldNames `appE` values)-  match params (normalB encoded) []+-- | A ConstructorEncoder uses configuration options + type information extracted from+--   a given data type (with TemplateHaskell) in order to produce a Value and an Encoding+newtype ConstructorEncoder = ConstructorEncoder+  { encodeConstructor :: Options -> FromConstructor -> (Value, Encoding)+  } +-- | Default implementation, it can be overridden in a registry+defaultConstructorEncoder :: ConstructorEncoder+defaultConstructorEncoder = ConstructorEncoder makeEncoderFromConstructor+ -- | Minimum set of data extracted from a given type with Template Haskell --   in order to create the appropriate encoder given an Options value data FromConstructor = FromConstructor@@ -173,20 +140,6 @@   }   deriving (Eq, Show) --- | Apply Options to the constructor name + field names---   and remove Nothing values if necessary-modifyFromConstructorWithOptions :: Options -> FromConstructor -> FromConstructor-modifyFromConstructorWithOptions options fc = do-  let (fn, fv) =-        if omitNothingFields options && length (fromConstructorFieldNames fc) == length (fromConstructorValues fc)-          then unzip $ filter ((/= Null) . fst . snd) $ zip (fromConstructorFieldNames fc) (fromConstructorValues fc)-          else (fromConstructorFieldNames fc, fromConstructorValues fc)-  fc-    { fromConstructorName = toS . constructorTagModifier options . toS $ fromConstructorName fc,-      fromConstructorFieldNames = toS . fieldLabelModifier options . toS <$> fn,-      fromConstructorValues = fv-    }- -- | Make an Encoder from Options and the representation of a constructor for a given value to encode makeEncoderFromConstructor :: Options -> FromConstructor -> (Value, Encoding) makeEncoderFromConstructor options fromConstructor = do@@ -211,11 +164,9 @@                 else valuesToObject names values             _ ->               if null names-                then case values of-                  [v] -> v-                  _ -> do-                    let (vs, es) = unzip values-                    (array vs, list identity es)+                then do+                  let (vs, es) = unzip values+                  (array vs, list identity es)                 else valuesToObject names values     -- sum constructor     _ ->@@ -294,6 +245,20 @@               ( Object . KM.fromList $ (K.fromText $ toS tagFieldName, String constructorTag) : zip fieldNamesKeys vs,                 pairs (foldMap identity $ pair (K.fromText $ toS tagFieldName) (string $ toS constructorTag) : (uncurry pair <$> zip fieldNamesKeys es))                 )++-- | Apply Options to the constructor name + field names+--   and remove Nothing values if necessary+modifyFromConstructorWithOptions :: Options -> FromConstructor -> FromConstructor+modifyFromConstructorWithOptions options fc = do+  let (fn, fv) =+        if omitNothingFields options && length (fromConstructorFieldNames fc) == length (fromConstructorValues fc)+          then unzip $ filter ((/= Null) . fst . snd) $ zip (fromConstructorFieldNames fc) (fromConstructorValues fc)+          else (fromConstructorFieldNames fc, fromConstructorValues fc)+  fc+    { fromConstructorName = toS . constructorTagModifier options . toS $ fromConstructorName fc,+      fromConstructorFieldNames = toS . fieldLabelModifier options . toS <$> fn,+      fromConstructorValues = fv+    }  -- | Create an Object from a list of field names and a list of Values --   both as a Value and as an Encoding

@@ -1,64 +0,0 @@-{-# LANGUAGE PartialTypeSignatures #-}-{-# OPTIONS_GHC -Wno-type-defaults #-}-{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}--{--  TemplateHaskell functions--}--module Data.Registry.Aeson.TH where--import Control.Monad.Fail-import Data.List (elemIndex)-import qualified Data.Text as T-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 / decoders for normal constructors and records, got: " <> show other)-  fail "encoders / decoders creation failed"---- | Get the name of a constructor-nameOf :: Con -> Q Name-nameOf (NormalC n _) = pure n-nameOf (RecC n _) = pure n-nameOf other = do-  qReport True ("we can only create encoders / decoders for normal constructors and records, got: " <> show other)-  fail "encoders / decoders creation failed"---- | Get the list of names of a constructor-fieldsOf :: Con -> Q [Name]-fieldsOf (NormalC _ _) = pure []-fieldsOf (RecC _ types) = pure $ (\(f, _, _) -> f) <$> types-fieldsOf other = do-  qReport True ("we can only create encoders / decoders for normal constructors and records, got: " <> show other)-  fail "encoders / decoders creation failed"---- | Remove the module name from a qualified name-dropQualified :: Name -> Name-dropQualified name = maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))---- | Return the name of a given type-getSimpleTypeName :: Type -> Name-getSimpleTypeName (ForallT _ _ ty) = getSimpleTypeName ty-getSimpleTypeName (VarT name) = dropQualified name-getSimpleTypeName (ConT name) = dropQualified name-getSimpleTypeName (TupleT n) = dropQualified $ tupleTypeName n-getSimpleTypeName ArrowT = dropQualified ''(->)-getSimpleTypeName ListT = dropQualified ''[]-getSimpleTypeName (AppT t1 t2) = mkName (show (getSimpleTypeName t1) <> " " <> show (getSimpleTypeName t2))-getSimpleTypeName (SigT t _) = getSimpleTypeName t-getSimpleTypeName (UnboxedTupleT n) = dropQualified $ unboxedTupleTypeName n-getSimpleTypeName t = panic $ "getSimpleTypeName: Unknown type: " <> show t

@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wno-type-defaults #-}+module Data.Registry.Aeson.TH.Decoder where++import Control.Monad.Fail+import Data.List (nub)+import Data.Registry.Aeson.TH.TH+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude as P hiding (Type)++{-+  This module uses TemplateHaskell to extract enough type information to be able to+  build a Decoder based on configuration options+-}++-- | 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 constructor _deriving) ->+      makeConstructorsDecoder typeName [constructor]+    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"+        _ -> makeConstructorsDecoder typeName constructors+    other -> do+      qReport True ("can only create decoders for an ADT, got: " <> P.show other)+      fail "decoders creation failed"++-- | Make a decoder for a given data type by extracting just enough metadata about the data type in order to be able+--   to parse a Value+--+--   For example for the data type:+--+--   data T = T1 {f1::Int, f2::Int} | T2 Int Int+--+--   we add this function to the registry:+--+--   \opts d1 d2 d3 -> Decoder $ \v ->+--     decodeFromDefinitions opts v $ \case+--       ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...+--       ToConstructor "T2" [v1, v2]-> T2 <$> d1 v1 <*> d3 v2 ...+--       other -> Left ("cannot decode " <> valueToText v)+--+--   The \case function is the only one which needs to be generated in order to match the exact shape of the+--   constructors to instantiate+makeConstructorsDecoder :: Name -> [Con] -> ExpQ+makeConstructorsDecoder typeName cs = do+  ts <- nub . join <$> for cs typesOf+  let decoderParameters = sigP (varP (mkName "os")) (conT $ mkName "Options") : sigP (varP (mkName "cd")) (conT $ mkName "ConstructorsDecoder") : ((\(t, n) -> sigP (varP (mkName $ "d" <> P.show n)) (appT (conT $ mkName "Decoder") (pure t))) <$> zip ts [0 ..])+  -- makeToConstructors os [Constructor "T1" ["f1", "f2"], Constructor "T2" []] v+  let paramP = varP (mkName "v")+  constructorDefs <- for cs $ \c -> do+    cName <- dropQualified <$> nameOf c+    fields <- fmap (litE . StringL . P.show . dropQualified) <$> fieldsOf c+    fieldTypes <- fmap (litE . StringL . P.show . getSimpleTypeName) <$> typesOf c+    varE (mkName "makeConstructorDef") `appE` (litE . StringL $ P.show cName) `appE` listE fields `appE` listE fieldTypes+  let matchClauses = makeMatchClause typeName ts <$> cs+  let matchFunction = lamCaseE (matchClauses <> [makeErrorClause typeName])+  let resolveFunction = varE (mkName "decodeFromDefinitions") `appE` varE (mkName "os") `appE` varE (mkName "cd") `appE` listE (pure <$> constructorDefs) `appE` varE (mkName "v") `appE` matchFunction+  lamE decoderParameters (appE (conE (mkName "Decoder")) (lamE [paramP] resolveFunction))++-- | Decode the nth constructor of a data type+--    ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ...+makeMatchClause :: Name -> [Type] -> Con -> MatchQ+makeMatchClause typeName allTypes c = do+  ts <- typesOf c+  constructorTypes <- fmap snd <$> indexConstructorTypes allTypes ts+  cName <- dropQualified <$> nameOf c+  let fieldsP = listP $ (\i -> varP $ mkName ("v" <> P.show i)) <$> constructorTypes+  match+    (conP (mkName "ToConstructor") [litP (StringL . P.show $ cName), fieldsP])+    (normalB (applyDecoder typeName cName constructorTypes))+    []++-- | Return an error the json value cannot be decoded with a constructor name and some values+makeErrorClause :: Name -> MatchQ+makeErrorClause typeName = do+  let errorMessage =+        (varE (mkName "<>") `appE` litE (StringL ("cannot use this constructor to create an instance of type '" <> P.show typeName <> "': ")))+          `appE` (varE (mkName "show") `appE` varE (mkName "_1"))+  match (varP $ mkName "_1") (normalB (appE (conE $ mkName "Left") errorMessage)) []++-- ConstructorName <$> decodeFieldValue d1 o1 <*> decodeFieldValue d2 o2 ...+applyDecoder :: Name -> Name -> [Int] -> ExpQ+applyDecoder _typeName cName [] = appE (varE $ mkName "pure") (conE cName)+applyDecoder typeName 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 =+      varE (mkName "decodeFieldValue") `appE` varE (mkName ("d" <> P.show i))+        `appE` (litE . StringL . P.show . dropQualified $ typeName)+        `appE` (litE . StringL . P.show . dropQualified $ cName)+        `appE` varE (mkName ("v" <> P.show i))

@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Data.Registry.Aeson.TH.Encoder where++import Control.Monad.Fail+import Data.List (nub)+import Data.Registry.Aeson.TH.TH+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Protolude as P hiding (Type)++{-+  This module uses TemplateHaskell to extract enough type information to be able to+  build an Encoder based on configuration options+-}++-- | 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+    TyConI (NewtypeD _context _name _typeVars _kind constructor _deriving) ->+      makeConstructorsEncoder [constructor]+    TyConI (DataD _context _name _typeVars _kind constructors _deriving) ->+      makeConstructorsEncoder constructors+    other -> do+      qReport True ("can only create encoders for an ADT, got: " <> show other)+      fail "encoders creation failed"++-- \(o::Options) (ce::ConstructorEncoder) (e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \a ->+--   case a of+--     T1 a0 a1 ... -> encodeConstructor ce o (FromConstructor names types "T1" fieldNames [encode e0 a0, encode e1 a1, ...])+--     T2 a0 a4 ... -> encodeConstructor ce o (FromConstructor names types "T2" fieldNames [encode e0 a0, encode e4 a4, ...])+makeConstructorsEncoder :: [Con] -> ExpQ+makeConstructorsEncoder cs = do+  -- get the types of all the fields of all the constructors+  ts <- nub . join <$> for cs typesOf+  constructorsNames <- for cs nameOf+  let options = sigP (varP (mkName "os")) (conT $ mkName "Options")+  let constructorEncoder = sigP (varP (mkName "ce")) (conT $ mkName "ConstructorEncoder")+  let encoderParameters = options : constructorEncoder : ((\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip ts [0 ..])+  matchClauses <- for cs $ makeMatchClause constructorsNames 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+--   T1 a0 a1 ... -> encodeConstructor ce o (FromConstructor names types cName fieldNames values)+makeMatchClause :: [Name] -> [Type] -> Con -> MatchQ+makeMatchClause constructorNames allTypes c = do+  ts <- typesOf c+  constructorTypes <- indexConstructorTypes allTypes ts+  cName <- dropQualified <$> nameOf c+  let names = listE $ litE . StringL . show . dropQualified <$> constructorNames+  let types = listE $ litE . StringL . show <$> allTypes+  fields <- fieldsOf c+  let fieldNames = listE $ litE . StringL . show . dropQualified <$> fields+  let params = conP (mkName $ show cName) $ (\(_, n) -> varP (mkName $ "a" <> show n)) <$> constructorTypes+  let values = listE $ (\(_, n) -> appE (appE (varE $ mkName "encode") (varE (mkName $ "e" <> show n))) (varE (mkName $ "a" <> show n))) <$> constructorTypes+  let encoded =+        varE (mkName "encodeConstructor")+          `appE` varE (mkName "ce")+          `appE` varE (mkName "os")+          `appE` (conE (mkName "FromConstructor") `appE` names `appE` types `appE` litE (StringL $ show cName) `appE` fieldNames `appE` values)+  match params (normalB encoded) []

@@ -0,0 +1,64 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++{-+  TemplateHaskell utility functions to create encoders and decoders+-}++module Data.Registry.Aeson.TH.TH where++import Control.Monad.Fail+import Data.List (elemIndex)+import qualified Data.Text as T+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 / decoders for normal constructors and records, got: " <> show other)+  fail "encoders / decoders creation failed"++-- | Get the name of a constructor+nameOf :: Con -> Q Name+nameOf (NormalC n _) = pure n+nameOf (RecC n _) = pure n+nameOf other = do+  qReport True ("we can only create encoders / decoders for normal constructors and records, got: " <> show other)+  fail "encoders / decoders creation failed"++-- | Get the list of names of a constructor+fieldsOf :: Con -> Q [Name]+fieldsOf (NormalC _ _) = pure []+fieldsOf (RecC _ types) = pure $ (\(f, _, _) -> f) <$> types+fieldsOf other = do+  qReport True ("we can only create encoders / decoders for normal constructors and records, got: " <> show other)+  fail "encoders / decoders creation failed"++-- | Remove the module name from a qualified name+dropQualified :: Name -> Name+dropQualified name = maybe name (mkName . toS) (lastMay (T.splitOn "." (show name)))++-- | Return the name of a given type+getSimpleTypeName :: Type -> Name+getSimpleTypeName (ForallT _ _ ty) = getSimpleTypeName ty+getSimpleTypeName (VarT name) = dropQualified name+getSimpleTypeName (ConT name) = dropQualified name+getSimpleTypeName (TupleT n) = dropQualified $ tupleTypeName n+getSimpleTypeName ArrowT = dropQualified ''(->)+getSimpleTypeName ListT = dropQualified ''[]+getSimpleTypeName (AppT t1 t2) = mkName (show (getSimpleTypeName t1) <> " " <> show (getSimpleTypeName t2))+getSimpleTypeName (SigT t _) = getSimpleTypeName t+getSimpleTypeName (UnboxedTupleT n) = dropQualified $ unboxedTupleTypeName n+getSimpleTypeName t = panic $ "getSimpleTypeName: Unknown type: " <> show t

@@ -176,7 +176,7 @@     <: jsonDecoder @Text     <: decodeMaybeOf @Int     <: jsonDecoder @Int-    <: val defaultOptions+    <: defaultDecoderOptions  utcTimeDecoder :: Decoder UTCTime utcTimeDecoder = Decoder $ \case

@@ -77,7 +77,7 @@     <: encodeMaybeOf @Int     <: jsonEncoder @Text     <: jsonEncoder @Int-    <: val defaultOptions+    <: defaultEncoderOptions  -- | This Encoder for DateTime reproduces the default generic one datetimeEncoder :: Encoder DateTime

@@ -133,7 +133,7 @@     <: jsonEncoder @String     <: jsonEncoder @Int     <: jsonEncoder @Bool-    <: val defaultOptions+    <: defaultEncoderOptions  -- Decoders @@ -177,7 +177,7 @@     <: jsonDecoder @String     <: jsonDecoder @Int     <: jsonDecoder @Bool-    <: val defaultOptions+    <: defaultDecoderOptions  -- Generators