mu-avro 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+298/−239 lines, 6 filesdep ~avrodep ~language-avrodep ~mu-avroPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: avro, language-avro, mu-avro, mu-rpc, mu-schema

API changes (from Hackage documentation)

Files

• mu-avro.cabal +9/−9
• src/Data/Time/Millis.hs +20/−19
• src/Mu/Adapter/Avro.hs +238/−181
• src/Mu/Quasi/Avro.hs +22/−21
• test/Avro.hs +7/−8
• test/avro/example.avsc +2/−1

@@ -1,5 +1,5 @@ name:          mu-avro-version:       0.2.0.0+version:       0.3.0.0 synopsis:      Avro serialization support for Mu microservices description:   You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell@@ -29,14 +29,14 @@    build-depends:       aeson-    , avro                  >=0.4.7-    , base                  >=4.12  && <5+    , avro                  >=0.5.1+    , base                  >=4.12    && <5     , bytestring     , containers     , deepseq-    , language-avro         >=0.1.2-    , mu-rpc                >=0.2.0-    , mu-schema             >=0.2.0+    , language-avro         >=0.1.3.1+    , mu-rpc                >=0.3.0+    , mu-schema             >=0.3.0     , sop-core     , tagged     , template-haskell      >=2.12@@ -53,11 +53,11 @@ executable test-avro   main-is:          Avro.hs   build-depends:-      avro        >=0.4.7+      avro        >=0.5     , base        >=4.12  && <5     , bytestring-    , mu-avro     >=0.2.0-    , mu-schema   >=0.2.0+    , mu-avro     >=0.3.0+    , mu-schema   >=0.3.0    hs-source-dirs:   test   default-language: Haskell2010

@@ -1,41 +1,42 @@ {-# language GeneralizedNewtypeDeriving #-}-module Data.Time.Millis where+{-|+Description : Time differences in milliseconds +Avro defines a specific logical type for time+differences expessed in milliseconds. This module+provides a type which wraps the 'DiffTime' from+the @time@ library (which uses nanoseconds),+offering a millisecond-based interface.+-}+module Data.Time.Millis where -import           Control.DeepSeq         (NFData)-import           Data.Avro.Encode-import           Data.Avro.EncodeRaw-import           Data.Avro.FromAvro+import           Control.DeepSeq             (NFData)+import           Data.Avro.Encoding.FromAvro+import           Data.Avro.Encoding.ToAvro import           Data.Avro.HasAvroSchema-import           Data.Avro.Schema        as S-import           Data.Avro.ToAvro-import           Data.Avro.Types         as T+import qualified Data.Avro.Schema.Schema     as S+import           Data.Int                    (Int32) import           Data.Tagged import           Data.Time-import           Unsafe.Coerce  -- | Wrapper for time difference expressed in milliseconds newtype DiffTimeMs = DiffTimeMs { unDiffTimeMs :: DiffTime }   deriving (Show, Eq, Ord, Enum, Num, Fractional, Real, RealFrac, NFData) -instance EncodeAvro DiffTimeMs where-  avro d-      -- Unfortunately, the AvroM constructor is not exposed :(-    = unsafeCoerce ( encodeRaw (fromIntegral $ diffTimeToMillis d :: Int)-                   , S.Long (Just TimeMicros) )- instance HasAvroSchema DiffTimeMs where-  schema = Tagged $ S.Int (Just TimeMillis)+  schema = Tagged $ S.Int (Just S.TimeMillis)  instance ToAvro DiffTimeMs where-  toAvro = T.Int . fromIntegral . diffTimeToMillis+  toAvro s = toAvro s . (fromIntegral :: Integer -> Int32) . diffTimeToMillis  instance FromAvro DiffTimeMs where-  fromAvro (T.Int  v) = pure $ millisToDiffTime (toInteger v)-  fromAvro v          = badValue v "TimeMicros"+  fromAvro (Int _ v) = pure $ millisToDiffTime (toInteger v)+  fromAvro _         = Left "expecting time_ms" +-- | Obtain the underlying time in milliseconds from a 'DiffTimeMs'. diffTimeToMillis :: DiffTimeMs -> Integer diffTimeToMillis = (`div` 1000000000) . diffTimeToPicoseconds . unDiffTimeMs +-- | Build a 'DiffTimeMs' from an amount expressed in milliseconds. millisToDiffTime :: Integer -> DiffTimeMs millisToDiffTime = DiffTimeMs . picosecondsToDiffTime . (* 1000000000)

@@ -8,6 +8,7 @@ {-# language RankNTypes            #-} {-# language ScopedTypeVariables   #-} {-# language TypeApplications      #-}+{-# language TypeFamilies          #-} {-# language TypeOperators         #-} {-# language UndecidableInstances  #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -20,18 +21,24 @@ -} module Mu.Adapter.Avro () where +import           Control.Applicative                 ((<|>)) import           Control.Arrow                       ((***)) import qualified Data.Avro                           as A-import qualified Data.Avro.Schema                    as ASch-import qualified Data.Avro.Types.Value               as AVal+import qualified Data.Avro.Encoding.FromAvro         as AVal+import qualified Data.Avro.Encoding.ToAvro           as A+import qualified Data.Avro.Schema.ReadSchema         as RSch+import qualified Data.Avro.Schema.Schema             as ASch -- 'Tagged . unTagged' can be replaced by 'coerce' -- eliminating some run-time overhead+import           Data.Avro.EitherN                   (putIndexedValue)+import           Data.ByteString.Builder             (Builder, word8) import           Data.Coerce                         (coerce)-import           Data.Functor.Identity import qualified Data.HashMap.Strict                 as HM+import           Data.List                           ((\\)) import           Data.List.NonEmpty                  (NonEmpty (..)) import qualified Data.List.NonEmpty                  as NonEmptyList import qualified Data.Map                            as M+import           Data.Maybe                          (fromJust) import           Data.Tagged import qualified Data.Text                           as T import qualified Data.Vector                         as V@@ -40,26 +47,29 @@ import           Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess -instance SLess.ToSchemalessTerm (AVal.Value t) Identity where-  toSchemalessTerm (AVal.Record _ r)-    = SLess.TRecord $ map (\(k,v) -> SLess.Field k (Identity $ SLess.toSchemalessValue v))-                    $ HM.toList r+instance SLess.ToSchemalessTerm AVal.Value where+  toSchemalessTerm (AVal.Record s r)+    = case s of+        RSch.Record { RSch.fields = fs }+          -> SLess.TRecord $ map (\(k,v) -> SLess.Field k (SLess.toSchemalessValue v))+                           $ zip (map RSch.fldName fs) (V.toList r)+        _ -> error ("this should never happen:\n" ++ show s)   toSchemalessTerm (AVal.Enum _ i _)     = SLess.TEnum i   toSchemalessTerm (AVal.Union _ _ v)     = SLess.toSchemalessTerm v   toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) -instance SLess.ToSchemalessValue (AVal.Value t) Identity where-  toSchemalessValue AVal.Null        = SLess.FNull-  toSchemalessValue (AVal.Boolean b) = SLess.FPrimitive b-  toSchemalessValue (AVal.Int b)     = SLess.FPrimitive b-  toSchemalessValue (AVal.Long b)    = SLess.FPrimitive b-  toSchemalessValue (AVal.Float b)   = SLess.FPrimitive b-  toSchemalessValue (AVal.Double b)  = SLess.FPrimitive b-  toSchemalessValue (AVal.String b)  = SLess.FPrimitive b-  toSchemalessValue (AVal.Fixed _ b) = SLess.FPrimitive b-  toSchemalessValue (AVal.Bytes b)   = SLess.FPrimitive b+instance SLess.ToSchemalessValue AVal.Value where+  toSchemalessValue AVal.Null         = SLess.FNull+  toSchemalessValue (AVal.Boolean  b) = SLess.FPrimitive b+  toSchemalessValue (AVal.Int    _ b) = SLess.FPrimitive b+  toSchemalessValue (AVal.Long   _ b) = SLess.FPrimitive b+  toSchemalessValue (AVal.Float  _ b) = SLess.FPrimitive b+  toSchemalessValue (AVal.Double _ b) = SLess.FPrimitive b+  toSchemalessValue (AVal.String _ b) = SLess.FPrimitive b+  toSchemalessValue (AVal.Fixed  _ b) = SLess.FPrimitive b+  toSchemalessValue (AVal.Bytes  _ b) = SLess.FPrimitive b   toSchemalessValue (AVal.Array v)     = SLess.FList $ map SLess.toSchemalessValue $ V.toList v   toSchemalessValue (AVal.Map hm)@@ -73,87 +83,129 @@   toSchemalessValue e@AVal.Enum {}     = SLess.FSchematic (SLess.toSchemalessTerm e) -instance A.HasAvroSchema (Term f sch (sch :/: sty))-         => A.HasAvroSchema (WithSchema f sch sty t) where-  schema = coerce $ A.schema @(Term f sch (sch :/: sty))-instance ( FromSchema f sch sty t-         , A.FromAvro (Term f sch (sch :/: sty)) )-         => A.FromAvro (WithSchema f sch sty t) where-  fromAvro v = WithSchema . fromSchema' @_ @_ @sch @f <$> A.fromAvro v-instance ( ToSchema Identity sch sty t-         , A.ToAvro (Term Identity sch (sch :/: sty)) )-         => A.ToAvro (WithSchema Identity sch sty t) where-  toAvro (WithSchema v) = A.toAvro (toSchema' @_ @_ @sch @Identity v)+instance (HasAvroSchemas sch sch)+         => A.HasAvroSchema (WithSchema sch sty t) where+  schema = Tagged $ ASch.Union $ schemas (Proxy @sch) (Proxy @sch) ts+    where ts = typeNames (Proxy @sch) (Proxy @sch)+instance ( FromSchema sch sty t+         , A.FromAvro (Term sch (sch :/: sty)) )+         => A.FromAvro (WithSchema sch sty t) where+  fromAvro entire@(AVal.Union _ _ v)+    =   -- remove first layer of union+        WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro v+    <|> -- try with the entire thing+        WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro entire+  fromAvro entire+    =   WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro entire+instance ( ToSchema sch sty t+         , A.ToAvro (Term sch (sch :/: sty))+         , KnownNat (IxOf sch sty) )+         => A.ToAvro (WithSchema sch sty t) where+  toAvro (ASch.Union vs) (WithSchema v)+    = putIndexedValue (fromInteger $ natVal (Proxy @(IxOf sch sty)))+                      vs+                      (toSchema' @_ @_ @sch v)+  toAvro s _ = error ("this should never happen:\n" ++ show s) +class HasAvroSchemas (r :: Schema tn fn) (sch :: Schema tn fn) where+  schemas   :: Proxy r -> Proxy sch -> [ASch.TypeName] -> V.Vector ASch.Schema+  typeNames :: Proxy r -> Proxy sch -> [ASch.TypeName]+instance HasAvroSchemas r '[] where+  schemas _ _ _ = V.empty+  typeNames _ _ = []+instance forall r d ds.+         (HasAvroSchema' (Term r d), HasAvroSchemas r ds)+         => HasAvroSchemas r (d ': ds) where+  schemas pr _ tys = V.cons thisSchema (schemas pr (Proxy @ds) tys)+    where thisSchema = unTagged $ schema' @(Term r d) (tys \\ typeName' (Proxy @(Term r d)))+  typeNames pr _ = typeName' (Proxy @(Term r d)) ++ typeNames pr (Proxy @ds)++type family IxOf (sch :: Schema tn fn) (sty :: tn) :: Nat where+  IxOf ('DRecord nm fs ': rest) nm = 0+  IxOf ('DEnum   nm cs ': rest) nm = 0+  IxOf (other          ': rest) nm = 1 + IxOf rest nm+ -- HasAvroSchema instances  class HasAvroSchema' x where-  schema' :: [ASch.TypeName] -> Tagged x ASch.Type+  typeName' :: Proxy x -> [ASch.TypeName]+  schema' :: [ASch.TypeName] -> Tagged x ASch.Schema -instance HasAvroSchema' (Term f sch t)-         => A.HasAvroSchema (Term f sch t) where-  schema = schema' []-instance HasAvroSchema' (FieldValue f sch t)-         => A.HasAvroSchema (FieldValue f sch t) where+instance TypeError ('Text "you should never use HasAvroSchema directly on Term, use WithSchema")+         => A.HasAvroSchema (Term sch t) where+  schema = error "this should never happen"+instance HasAvroSchema' (FieldValue sch t)+         => A.HasAvroSchema (FieldValue sch t) where   schema = schema' []  instance (KnownName name, HasAvroSchemaFields sch args)-         => HasAvroSchema' (Term f sch ('DRecord name args)) where+         => HasAvroSchema' (Term sch ('DRecord name args)) where+  typeName' _ = [nameTypeName (Proxy @name)]   schema' visited     = if recordName `elem` visited          then Tagged $ ASch.NamedType recordName-         else Tagged $ ASch.Record recordName [] Nothing Nothing fields+         else Tagged $ ASch.Record recordName [] Nothing fields     where recordName = nameTypeName (Proxy @name)           fields = schemaF (Proxy @sch) (Proxy @args) visited instance (KnownName name, HasAvroSchemaEnum choices)-          => HasAvroSchema' (Term f sch ('DEnum name choices)) where+          => HasAvroSchema' (Term sch ('DEnum name choices)) where+  typeName' _ = [nameTypeName (Proxy @name)]   schema' visited     = if enumName `elem` visited          then Tagged $ ASch.NamedType enumName          else Tagged $ ASch.mkEnum enumName [] Nothing choicesNames     where enumName = nameTypeName (Proxy @name)           choicesNames = schemaE (Proxy @choices)-instance HasAvroSchema' (FieldValue f sch t)-         => HasAvroSchema' (Term f sch ('DSimple t)) where-  schema' visited = coerce $ schema' @(FieldValue f sch t) visited+instance HasAvroSchema' (FieldValue sch t)+         => HasAvroSchema' (Term sch ('DSimple t)) where+  typeName' _ = []+  schema' visited = coerce $ schema' @(FieldValue sch t) visited -instance HasAvroSchema' (FieldValue f sch 'TNull) where+instance HasAvroSchema' (FieldValue sch 'TNull) where+  typeName' _ = []   schema' _ = Tagged ASch.Null instance A.HasAvroSchema t-         => HasAvroSchema' (FieldValue f sch ('TPrimitive t)) where+         => HasAvroSchema' (FieldValue sch ('TPrimitive t)) where+  typeName' _ = []   schema' _ = coerce $ A.schema @t-instance (HasAvroSchema' (Term f sch (sch :/: t)))-         => HasAvroSchema' (FieldValue f sch ('TSchematic t)) where-  schema' visited = coerce $ schema' @(Term f sch (sch :/: t)) visited-instance forall sch f choices.-         HasAvroSchemaUnion (FieldValue f sch) choices-         => HasAvroSchema' (FieldValue f sch ('TUnion choices)) where+instance (HasAvroSchema' (Term sch (sch :/: t)))+         => HasAvroSchema' (FieldValue sch ('TSchematic t)) where+  typeName' _ = []+  schema' visited = coerce $ schema' @(Term sch (sch :/: t)) visited+instance forall sch choices.+         HasAvroSchemaUnion (FieldValue sch) choices+         => HasAvroSchema' (FieldValue sch ('TUnion choices)) where+  typeName' _ = []   schema' visited-    = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue f sch)) (Proxy @choices) visited-instance HasAvroSchema' (FieldValue f sch t)-         => HasAvroSchema' (FieldValue f sch ('TOption t)) where+    = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue sch)) (Proxy @choices) visited+instance HasAvroSchema' (FieldValue sch t)+         => HasAvroSchema' (FieldValue sch ('TOption t)) where+  typeName' _ = []   schema' visited     = Tagged $ ASch.mkUnion $ ASch.Null :| [iSchema]-    where iSchema = unTagged $ schema' @(FieldValue f sch t) visited-instance HasAvroSchema' (FieldValue f sch t)-         => HasAvroSchema' (FieldValue f sch ('TList t)) where+    where iSchema = unTagged $ schema' @(FieldValue sch t) visited+instance HasAvroSchema' (FieldValue sch t)+         => HasAvroSchema' (FieldValue sch ('TList t)) where+  typeName' _ = []   schema' visited     = Tagged $ ASch.Array iSchema-    where iSchema = unTagged $ schema' @(FieldValue f sch t) visited+    where iSchema = unTagged $ schema' @(FieldValue sch t) visited -- These are the only two versions of Map supported by the library-instance HasAvroSchema' (FieldValue f sch v)-         => HasAvroSchema' (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where+instance HasAvroSchema' (FieldValue sch v)+         => HasAvroSchema' (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where+  typeName' _ = []   schema' visited     = Tagged $ ASch.Map iSchema-    where iSchema = unTagged $ schema' @(FieldValue f sch v) visited-instance HasAvroSchema' (FieldValue f sch v)-         => HasAvroSchema' (FieldValue f sch ('TMap ('TPrimitive String) v)) where+    where iSchema = unTagged $ schema' @(FieldValue sch v) visited+instance HasAvroSchema' (FieldValue sch v)+         => HasAvroSchema' (FieldValue sch ('TMap ('TPrimitive String) v)) where+  typeName' _ = []   schema' visited     = Tagged $ ASch.Map iSchema-    where iSchema = unTagged $ schema' @(FieldValue f sch v) visited+    where iSchema = unTagged $ schema' @(FieldValue sch v) visited  class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where-  schemaU :: Proxy f -> Proxy xs -> [ASch.TypeName] -> NonEmpty ASch.Type+  schemaU :: Proxy f -> Proxy xs -> [ASch.TypeName] -> NonEmpty ASch.Schema instance HasAvroSchema' (f v) => HasAvroSchemaUnion f '[v] where   schemaU _ _ visited = vSchema :| []     where vSchema = unTagged (schema' @(f v) visited)@@ -167,11 +219,11 @@   schemaF :: Proxy sch -> Proxy fs -> [ASch.TypeName] -> [ASch.Field] instance HasAvroSchemaFields sch '[] where   schemaF _ _ _ = []-instance (KnownName name, HasAvroSchema' (FieldValue Identity sch t), HasAvroSchemaFields sch fs)+instance (KnownName name, HasAvroSchema' (FieldValue sch t), HasAvroSchemaFields sch fs)          => HasAvroSchemaFields sch ('FieldDef name t ': fs) where   schemaF psch _ visited = schemaThis : schemaF psch (Proxy @fs) visited     where fieldName = nameText (Proxy @name)-          schemaT = unTagged $ schema' @(FieldValue Identity sch t) visited+          schemaT = unTagged $ schema' @(FieldValue sch t) visited           schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing  class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where@@ -184,148 +236,153 @@  -- FromAvro instances -instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields f sch args)-         => A.FromAvro (Term f sch ('DRecord name args)) where-  fromAvro (AVal.Record _ fields) = TRecord <$> fromAvroF fields-  fromAvro v                      = A.badValue v "record"-instance (KnownName name, HasAvroSchemaEnum choices, FromAvroEnum choices)-          => A.FromAvro (Term f sch ('DEnum name choices)) where-  fromAvro v@(AVal.Enum _ n _) = TEnum <$> fromAvroEnum v n-  fromAvro v                   = A.badValue v "enum"-instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t))-         => A.FromAvro (Term f sch ('DSimple t)) where-  fromAvro v = TSimple <$> A.fromAvro v+instance (KnownName name, FromAvroFields sch args)+         => A.FromAvro (Term sch ('DRecord name args)) where+  fromAvro (AVal.Record RSch.Record { RSch.fields = fs } fields)+    = TRecord <$> fromAvroF r+    where+      r = HM.fromList $ zip (map RSch.fldName fs) (V.toList fields)+  fromAvro _ = Left "expecting record"+instance (KnownName name, FromAvroEnum choices)+          => A.FromAvro (Term sch ('DEnum name choices)) where+  fromAvro (AVal.Enum _ _ v) = TEnum <$> fromAvroEnum v+  fromAvro _                 = Left "expecting enum"+instance (A.FromAvro (FieldValue sch t))+         => A.FromAvro (Term sch ('DSimple t)) where+  fromAvro v = TSimple <$> AVal.fromAvro v -instance A.FromAvro (FieldValue f sch 'TNull) where-  fromAvro AVal.Null = return FNull-  fromAvro v         = A.badValue v "null"-instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where-  fromAvro v = FPrimitive <$> A.fromAvro v-instance ( KnownName t, HasAvroSchema' (Term f sch (sch :/: t))-         , A.FromAvro (Term f sch (sch :/: t)) )-         => A.FromAvro (FieldValue f sch ('TSchematic t)) where-  fromAvro v = FSchematic <$> A.fromAvro v-instance (HasAvroSchemaUnion (FieldValue f sch) choices, FromAvroUnion f sch choices)-         => A.FromAvro (FieldValue f sch ('TUnion choices)) where-  fromAvro (AVal.Union _ branch v) = FUnion <$> fromAvroU branch v-  fromAvro v                       = A.badValue v "union"-instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t))-         => A.FromAvro (FieldValue f sch ('TOption t)) where-  fromAvro v = FOption <$> A.fromAvro v-instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t))-         => A.FromAvro (FieldValue f sch ('TList t)) where-  fromAvro v = FList <$> A.fromAvro v+instance A.FromAvro (FieldValue sch 'TNull) where+  fromAvro AVal.Null = pure FNull+  fromAvro _         = Left "expecting null"+instance A.FromAvro t => A.FromAvro (FieldValue sch ('TPrimitive t)) where+  fromAvro v = FPrimitive <$> AVal.fromAvro v+instance ( KnownName t, A.FromAvro (Term sch (sch :/: t)) )+         => A.FromAvro (FieldValue sch ('TSchematic t)) where+  fromAvro v = FSchematic <$> AVal.fromAvro v+instance (FromAvroUnion sch choices)+         => A.FromAvro (FieldValue sch ('TUnion choices)) where+  fromAvro (AVal.Union _ i v) = FUnion <$> fromAvroU i v+  fromAvro _                  = Left "expecting union"+instance (A.FromAvro (FieldValue sch t))+         => A.FromAvro (FieldValue sch ('TOption t)) where+  fromAvro v = FOption <$> AVal.fromAvro v+instance (A.FromAvro (FieldValue sch t))+         => A.FromAvro (FieldValue sch ('TList t)) where+  fromAvro v = FList <$> AVal.fromAvro v -- These are the only two versions of Map supported by the library-instance (HasAvroSchema' (FieldValue f sch v), A.FromAvro (FieldValue f sch v))-         => A.FromAvro (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where-  fromAvro v = FMap . M.mapKeys FPrimitive <$> A.fromAvro v-instance (HasAvroSchema' (FieldValue f sch v), A.FromAvro (FieldValue f sch v))-         => A.FromAvro (FieldValue f sch ('TMap ('TPrimitive String) v)) where-  fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> A.fromAvro v+instance (A.FromAvro (FieldValue sch v))+         => A.FromAvro (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where+  fromAvro v = FMap . M.mapKeys FPrimitive <$> AVal.fromAvro v+instance (A.FromAvro (FieldValue sch v))+         => A.FromAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where+  fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> AVal.fromAvro v  class FromAvroEnum (vs :: [ChoiceDef fn]) where-  fromAvroEnum :: AVal.Value ASch.Type -> Int -> A.Result (NS Proxy vs)+  fromAvroEnum :: T.Text -> Either String (NS Proxy vs) instance FromAvroEnum '[] where-  fromAvroEnum v _ = A.badValue v "element not found"-instance FromAvroEnum vs => FromAvroEnum (v ': vs) where-  fromAvroEnum _ 0 = return (Z Proxy)-  fromAvroEnum v n = S <$> fromAvroEnum v (n-1)+  fromAvroEnum _ = Left "enum choice not found"+instance (KnownName name, FromAvroEnum vs)+         => FromAvroEnum ('ChoiceDef name ': vs) where+  fromAvroEnum s+    | s == fieldName = pure $ Z Proxy+    | otherwise      = S <$> fromAvroEnum s+    where fieldName = nameText (Proxy @name) -class FromAvroUnion f sch choices where-  fromAvroU :: ASch.Type -> AVal.Value ASch.Type -> ASch.Result (NS (FieldValue f sch) choices)-instance FromAvroUnion f sch '[] where-  fromAvroU _ v = A.badValue v "union choice not found"-instance (A.FromAvro (FieldValue f sch u), FromAvroUnion f sch us)-         => FromAvroUnion f sch (u ': us) where-  fromAvroU branch v-    | ASch.matches branch (unTagged (A.schema @(FieldValue f sch u)))-    = Z <$> A.fromAvro v-    | otherwise-    = S <$> fromAvroU branch v+class FromAvroUnion sch choices where+  fromAvroU :: Int -> AVal.Value -> Either String (NS (FieldValue sch) choices)+instance FromAvroUnion sch '[] where+  fromAvroU _ _ = Left "union choice not found"+instance (A.FromAvro (FieldValue sch u), FromAvroUnion sch us)+         => FromAvroUnion sch (u ': us) where+  fromAvroU 0 v = Z <$> AVal.fromAvro v+  fromAvroU n v = S <$> fromAvroU (n-1) v -class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where-  fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Type) -> A.Result (NP (Field f sch) fs)-instance FromAvroFields f sch '[] where-  fromAvroF _ = return Nil-instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs)-         => FromAvroFields f sch ('FieldDef name t ': fs) where+class FromAvroFields sch (fs :: [FieldDef Symbol Symbol]) where+  fromAvroF :: HM.HashMap T.Text AVal.Value+            -> Either String (NP (Field sch) fs)+instance FromAvroFields sch '[] where+  fromAvroF _ = pure Nil+instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs)+         => FromAvroFields sch ('FieldDef name t ': fs) where   fromAvroF v = case HM.lookup fieldName v of-                  Nothing -> A.badValue v "field not found"-                  Just f  -> (:*) <$> (Field . pure <$> A.fromAvro f) <*> fromAvroF v+                  Nothing -> Left "field not found"+                  Just f  -> (:*) <$> (Field <$> AVal.fromAvro f) <*> fromAvroF v     where fieldName = nameText (Proxy @name)  -- ToAvro instances -instance (KnownName name, HasAvroSchemaFields sch args, ToAvroFields sch args)-         => A.ToAvro (Term Identity sch ('DRecord name args)) where-  toAvro (TRecord fields) = AVal.Record wholeSchema (toAvroF fields)-    where wholeSchema = unTagged (A.schema @(Term Identity sch ('DRecord name args)))-instance (KnownName name, HasAvroSchemaEnum choices, ToAvroEnum choices)-          => A.ToAvro (Term Identity sch ('DEnum name choices)) where-  toAvro (TEnum n) = AVal.Enum wholeSchema choice text-    where wholeSchema = unTagged (A.schema @(Term Identity sch ('DEnum name choices)))-          (choice, text) = toAvroE n-instance (HasAvroSchema' (FieldValue Identity sch t), A.ToAvro (FieldValue Identity sch t))-         => A.ToAvro (Term Identity sch ('DSimple t)) where-  toAvro (TSimple v) = A.toAvro v+instance (KnownName name, ToAvroFields sch args, HasAvroSchemaFields sch args)+         => A.ToAvro (Term sch ('DRecord name args)) where+  toAvro s@ASch.Record {} (TRecord fields)+    = A.record s $ toAvroF fields+  -- if we don't have a record, fall back to the one from schema+  toAvro _ (TRecord fields)+    = A.record (unTagged $ schema' @(Term sch ('DRecord name args)) []) $ toAvroF fields+instance (KnownName name, ToAvroEnum choices, HasAvroSchemaEnum choices)+          => A.ToAvro (Term sch ('DEnum name choices)) where+  toAvro ASch.Enum { ASch.symbols = ss } (TEnum n)+    = word8 $ fromIntegral $ toAvroE ss n+  -- otherwise fall back to the one from schema+  toAvro _ (TEnum n)+    = word8 $ fromIntegral $ toAvroE (V.fromList $ schemaE (Proxy @choices)) n+instance (A.ToAvro (FieldValue sch t))+         => A.ToAvro (Term sch ('DSimple t)) where+  toAvro s (TSimple v) = A.toAvro s v -instance A.ToAvro (FieldValue Identity sch 'TNull) where-  toAvro FNull = AVal.Null-instance A.ToAvro t => A.ToAvro (FieldValue Identity sch ('TPrimitive t)) where-  toAvro (FPrimitive v) = A.toAvro v-instance ( KnownName t, HasAvroSchema' (Term Identity sch (sch :/: t))-         , A.ToAvro (Term Identity sch (sch :/: t)) )-         => A.ToAvro (FieldValue Identity sch ('TSchematic t)) where-  toAvro (FSchematic v) = A.toAvro v-instance forall sch choices.-         (HasAvroSchemaUnion (FieldValue Identity sch) choices, ToAvroUnion sch choices)-         => A.ToAvro (FieldValue Identity sch ('TUnion choices)) where-  toAvro (FUnion v) = AVal.Union wholeSchema' chosenTy chosenVal-    where wholeSchema = schemaU (Proxy @(FieldValue Identity sch)) (Proxy @choices) []-          wholeSchema' = V.fromList (NonEmptyList.toList wholeSchema)-          (chosenTy, chosenVal) = toAvroU v-instance (HasAvroSchema' (FieldValue Identity sch t), A.ToAvro (FieldValue Identity sch t))-         => A.ToAvro (FieldValue Identity sch ('TOption t)) where-  toAvro (FOption v) = A.toAvro v-instance (HasAvroSchema' (FieldValue Identity sch t), A.ToAvro (FieldValue Identity sch t))-         => A.ToAvro (FieldValue Identity sch ('TList t)) where-  toAvro (FList v) = AVal.Array $ V.fromList $ A.toAvro <$> v+instance A.ToAvro (FieldValue sch 'TNull) where+  toAvro _ FNull = mempty+instance A.ToAvro t => A.ToAvro (FieldValue sch ('TPrimitive t)) where+  toAvro s (FPrimitive v) = A.toAvro s v+instance ( KnownName t, A.ToAvro (Term sch (sch :/: t)) )+         => A.ToAvro (FieldValue sch ('TSchematic t)) where+  toAvro s (FSchematic v) = A.toAvro s v+instance (ToAvroUnion sch choices)+         => A.ToAvro (FieldValue sch ('TUnion choices)) where+  toAvro (ASch.Union vs) (FUnion v) = toAvroU vs 0 v+  toAvro s _                        = error ("this should never happen:\n" ++ show s)+instance (A.ToAvro (FieldValue sch t))+         => A.ToAvro (FieldValue sch ('TOption t)) where+  toAvro s (FOption v) = A.toAvro s v+instance (A.ToAvro (FieldValue sch t))+         => A.ToAvro (FieldValue sch ('TList t)) where+  toAvro s (FList v) = A.toAvro s v -- These are the only two versions of Map supported by the library-instance (HasAvroSchema' (FieldValue Identity sch v), A.ToAvro (FieldValue Identity sch v))-         => A.ToAvro (FieldValue Identity sch ('TMap ('TPrimitive T.Text) v)) where-  toAvro (FMap v) = A.toAvro $ M.mapKeys (\(FPrimitive k) -> k) v-instance (HasAvroSchema' (FieldValue Identity sch v), A.ToAvro (FieldValue Identity sch v))-         => A.ToAvro (FieldValue Identity sch ('TMap ('TPrimitive String) v)) where-  toAvro (FMap v) = A.toAvro $ M.mapKeys (\(FPrimitive k) -> k) v--class ToAvroUnion sch choices where-  toAvroU :: NS (FieldValue Identity sch) choices -> (ASch.Type, AVal.Value ASch.Type)-instance ToAvroUnion sch '[] where-  toAvroU _ = error "ToAvro in an empty union"-instance forall sch u us.-         (A.ToAvro (FieldValue Identity sch u), ToAvroUnion sch us)-         => ToAvroUnion sch (u ': us) where-  toAvroU (Z v) = (unTagged (A.schema @(FieldValue Identity sch u)), A.toAvro v)-  toAvroU (S n) = toAvroU n+instance (A.ToAvro (FieldValue sch v))+         => A.ToAvro (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where+  toAvro s (FMap v) = A.toAvro s $ M.mapKeys (\(FPrimitive k) -> k) v+instance (A.ToAvro (FieldValue sch v))+         => A.ToAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where+  toAvro s (FMap v) = A.toAvro s $ M.mapKeys (\(FPrimitive k) -> T.pack k) v  class ToAvroEnum choices where-  toAvroE :: NS Proxy choices -> (Int, T.Text)+  toAvroE :: V.Vector T.Text -> NS Proxy choices -> Int instance ToAvroEnum '[] where   toAvroE = error "ToAvro in an empty enum" instance (KnownName u, ToAvroEnum us)          => ToAvroEnum ('ChoiceDef u ': us) where-  toAvroE (Z _) = (0, nameText (Proxy @u))-  toAvroE (S v) = let (n, t) = toAvroE v in (n + 1, t)+  toAvroE s (Z _) = fromJust $ nameText (Proxy @u) `V.elemIndex` s+  toAvroE s (S v) = toAvroE s v +class ToAvroUnion sch choices where+  toAvroU :: V.Vector ASch.Schema+          -> Int -> NS (FieldValue sch) choices -> Builder+instance ToAvroUnion sch '[] where+  toAvroU = error "this should never happen"+instance (A.ToAvro (FieldValue sch u), ToAvroUnion sch us)+         => ToAvroUnion sch (u ': us) where+  toAvroU allSch n (Z v)+    = putIndexedValue n allSch v+  toAvroU allSch n (S v)+    = toAvroU allSch (n+1) v+ class ToAvroFields sch (fs :: [FieldDef Symbol Symbol]) where-  toAvroF :: NP (Field Identity sch) fs -> HM.HashMap T.Text (AVal.Value ASch.Type)+  toAvroF :: NP (Field sch) fs -> [(T.Text, A.Encoder)] instance ToAvroFields sch '[] where-  toAvroF _ = HM.empty-instance (KnownName name, A.ToAvro (FieldValue Identity sch t), ToAvroFields sch fs)+  toAvroF _ = []+instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs)          => ToAvroFields sch ('FieldDef name t ': fs) where-  toAvroF (Field (Identity v) :* rest) = HM.insert fieldName fieldValue (toAvroF rest)+  toAvroF (Field v :* rest) = (fieldName A..= v) : toAvroF rest     where fieldName  = nameText (Proxy @name)-          fieldValue = A.toAvro v  -- Conversion of symbols to other things nameText :: KnownName s => proxy s -> T.Text

@@ -28,8 +28,8 @@  import           Control.Monad.IO.Class import           Data.Aeson                 (decode)-import qualified Data.Avro.Schema           as A-import           Data.Avro.Types.Decimal    as D+import           Data.Avro.Schema.Decimal   as D+import qualified Data.Avro.Schema.Schema    as A import qualified Data.ByteString            as B import           Data.ByteString.Lazy.Char8 (pack) import           Data.Int@@ -67,18 +67,17 @@ avroFile :: QuasiQuoter avroFile = quoteFile avro --- | Reads a @.proto@ file and generates:---   * A 'Mu.Schema.Definition.Schema' with all the message+-- | Reads a @.avdl@ file and generates:+--   * A 'Mu.Schema.Definition.Schema' with all the record --     types, using the name given as first argument.---   * A 'Service' declaration for each service in the file,---     where the name is obtained by applying the function---     given as second argument to the name in the file.+--   * A 'Service' declaration containing all the methods+--     defined in the file. avdl :: String -> String -> FilePath -> FilePath -> Q [Dec] avdl schemaName serviceName baseDir initialFile   = do r <- liftIO $ readWithImports baseDir initialFile        case r of          Left e-           -> fail ("could not parse protocol buffers spec: " ++ show e)+           -> fail ("could not parse Avro IDL: " ++ show e)          Right p            -> avdlToDecls schemaName serviceName p @@ -88,20 +87,22 @@            serviceName' = mkName serviceName        schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol))        serviceDec <- tySynD serviceName' []-         [t| 'Service $(textToStrLit (A.pname protocol)) $(pkgType (A.ns protocol))-                      $(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |]-       return [schemaDec, serviceDec]+         [t| 'Package $(pkgType (A.ns protocol))+                '[ 'Service $(textToStrLit (A.pname protocol)) '[]+                            $(typesToList <$> mapM (avroMethodToType schemaName')+                            (S.toList $ A.messages protocol)) ] |]+       pure [schemaDec, serviceDec]   where-    pkgType Nothing = [t| '[] |]+    pkgType Nothing = [t| 'Nothing |]     pkgType (Just (A.Namespace p))-                    = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]+                    = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]  schemaFromAvro :: [A.Schema] -> Q Type schemaFromAvro =   (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls  schemaDecFromAvroType :: A.Schema -> Q Type-schemaDecFromAvroType (A.Record name _ _ _ fields) =+schemaDecFromAvroType (A.Record name _ _ fields) =   [t|'DRecord $(textToStrLit $ A.baseName name)               $(typesToList <$> mapM avroFieldToType fields)|]   where@@ -154,15 +155,15 @@ flattenAvroDecls = concatMap (uncurry (:) . flattenDecl)   where     flattenDecl :: A.Schema -> (A.Schema, [A.Schema])-    flattenDecl (A.Record name a d o fields) =+    flattenDecl (A.Record name a d fields) =       let (flds, tts) = unzip (flattenAvroField <$> fields)-       in (A.Record name a d o flds, concat tts)+       in (A.Record name a d flds, concat tts)     flattenDecl (A.Union _) = error "should never happen, please, file an issue"     flattenDecl t = (t, [])     flattenAvroType :: A.Schema -> (A.Schema, [A.Schema])-    flattenAvroType (A.Record name a d o fields) =+    flattenAvroType (A.Record name a d fields) =       let (flds, tts) = unzip (flattenAvroField <$> fields)-       in (A.NamedType name, A.Record name a d o flds : concat tts)+       in (A.NamedType name, A.Record name a d flds : concat tts)     flattenAvroType (A.Union (V.toList -> ts)) =       let (us, tts) = unzip (map flattenAvroType ts)        in (A.Union $ V.fromList us, concat tts)@@ -181,7 +182,7 @@   where     argToType :: A.Argument -> Q Type     argToType (A.Argument (A.NamedType a) _)-      = [t| 'ArgSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]+      = [t| 'ArgSingle 'Nothing '[] ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]     argToType (A.Argument _ _)       = fail "only named types may be used as arguments" @@ -189,7 +190,7 @@     retToType A.Null       = [t| 'RetNothing |]     retToType (A.NamedType a)-      = [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]+      = [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]     retToType _       = fail "only named types may be used as results" @@ -197,4 +198,4 @@ typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT  textToStrLit :: T.Text -> Q Type-textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s+textToStrLit s = litT $ strTyLit $ T.unpack s

@@ -8,7 +8,6 @@  import           Data.Avro import qualified Data.ByteString.Lazy as BS-import           Data.Functor.Identity import           System.Environment  import           Mu.Adapter.Avro      ()@@ -19,12 +18,12 @@ exampleAddress = Address "1111BB" "Spain"  examplePerson1, examplePerson2 :: Person-examplePerson1 = Person "Haskellio" "Gomez" (Just 30) (Just Male) exampleAddress-examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress+examplePerson1 = Person "Haskellio" "Gomez" (Just 30) (Just Male) exampleAddress [1,2,3]+examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress [] -deriving via (WithSchema Identity ExampleSchema "person" Person) instance HasAvroSchema Person-deriving via (WithSchema Identity ExampleSchema "person" Person) instance FromAvro Person-deriving via (WithSchema Identity ExampleSchema "person" Person) instance ToAvro Person+deriving via (WithSchema ExampleSchema "person" Person) instance HasAvroSchema Person+deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person+deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person  main :: IO () main = do -- Obtain the filenames@@ -32,10 +31,10 @@   -- Read the file produced by Python   putStrLn "haskell/consume"   cbs <- BS.readFile conFile-  let [people] = decodeContainer @Person cbs+  let people = decodeContainer @Person cbs   print people   -- Encode a couple of values   putStrLn "haskell/generate"   print [examplePerson1, examplePerson2]-  gbs <- encodeContainer [[examplePerson1, examplePerson2]]+  gbs <- encodeContainer nullCodec [[examplePerson1, examplePerson2]]   BS.writeFile genFile gbs

@@ -16,7 +16,8 @@       {"name": "lastName", "type": "string"},       {"name": "age",  "type": ["long", "null"]},       {"name": "gender", "type": ["gender", "null"]},-      {"name": "address", "type": "address"}+      {"name": "address", "type": "address"},+      {"name": "lucky_numbers", "type": { "type": "array", "items": "long" } }     ]   } ]