diff --git a/avro.cabal b/avro.cabal --- a/avro.cabal +++ b/avro.cabal @@ -2,15 +2,15 @@ -- -- see: https://github.com/sol/hpack -- --- hash: a7df532e971306f0e8b7c7ff21ecb95e20f336d396ec72f86154b1df850f7ee7 +-- hash: 9e78201d3840bc184e5d8c510138f5a2eedb7ce7dbceab86140bd2d7562b8e1d name: avro -version: 0.3.2.0 +version: 0.3.3.0 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell category: Data -homepage: https://github.com/GaloisInc/avro.git#readme -bug-reports: https://github.com/GaloisInc/avro.git/issues +homepage: https://github.com/GaloisInc/avro#readme +bug-reports: https://github.com/GaloisInc/avro/issues author: Thomas M. DuBuisson maintainer: Alexey Raga license: BSD3 @@ -35,7 +35,7 @@ source-repository head type: git - location: https://github.com/GaloisInc/avro.git + location: https://github.com/GaloisInc/avro flag dev description: Use development GHC flags diff --git a/src/Data/Avro/Deriving.hs b/src/Data/Avro/Deriving.hs --- a/src/Data/Avro/Deriving.hs +++ b/src/Data/Avro/Deriving.hs @@ -10,6 +10,7 @@ ( -- * Deriving options DeriveOptions(..), defaultDeriveOptions , mkPrefixedFieldName, mkAsIsFieldName +, mkLazyField, mkStrictPrimitiveField -- * Deriving Haskell types from Avro schema , makeSchema @@ -38,8 +39,8 @@ import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import GHC.Generics (Generic) -import Language.Haskell.TH as TH -import Language.Haskell.TH.Lib as TH +import Language.Haskell.TH as TH hiding (notStrict) +import Language.Haskell.TH.Lib as TH hiding (notStrict) import Language.Haskell.TH.Syntax import Data.Avro.Deriving.NormSchema @@ -53,11 +54,27 @@ import qualified Data.Text as T import qualified Data.Vector as V + +-- | Describes the strictness of a field for a derived +-- data type. The field will be derived as if it were +-- written with a @!@. +data FieldStrictness = StrictField | LazyField + deriving Generic + +-- | Describes the representation of a field for a derived +-- data type. The field will be derived as if it were written +-- with an @{-# UNPACK #-}@ pragma. +data FieldUnpackedness = UnpackedField | NonUnpackedField + deriving Generic + -- | Derives Avro from a given schema file. -- Generates data types, FromAvro and ToAvro instances. data DeriveOptions = DeriveOptions { -- | How to build field names for generated data types fieldNameBuilder :: TypeName -> Field -> T.Text + + -- | Determines field representation of generated data types + , fieldRepresentation :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness) } deriving Generic -- | Default deriving options @@ -65,10 +82,12 @@ -- @ -- defaultDeriveOptions = 'DeriveOptions' -- { fieldNameBuilder = 'mkPrefixedFieldName' +-- , fieldStrictness = 'mkLazyField' -- } -- @ defaultDeriveOptions = DeriveOptions - { fieldNameBuilder = mkPrefixedFieldName + { fieldNameBuilder = mkPrefixedFieldName + , fieldRepresentation = mkLazyField } -- | Generates a field name that is prefixed with the type name. @@ -83,6 +102,38 @@ mkPrefixedFieldName (TN dn) fld = sanitiseName $ updateFirst T.toLower dn <> updateFirst T.toUpper (fldName fld) + +-- | Marks any field as non-strict in the generated data types. +mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness) +mkLazyField _ _ = + (LazyField, NonUnpackedField) + + +-- | Make a field strict and unpacked if it has a primitive representation. +-- Primitive types are types which GHC has either a static or an unlifted +-- representation: `()`, `Boolean`, `Int32`, `Int64`, `Float`, `Double`. +mkStrictPrimitiveField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness) +mkStrictPrimitiveField _ field = + if shouldStricten + then (StrictField, unpackedness) + else (LazyField, NonUnpackedField) + where + unpackedness = + case S.fldType field of + S.Null -> NonUnpackedField + S.Boolean -> NonUnpackedField + _ -> UnpackedField + + shouldStricten = + case S.fldType field of + S.Null -> True + S.Boolean -> True + S.Int -> True + S.Long -> True + S.Float -> True + S.Double -> True + _ -> False + -- | Generates a field name that matches the field name in schema -- (sanitised for Haskell, so first letter is lower cased) -- @@ -332,7 +383,7 @@ where numericLit = litE . IntegerL . fromIntegral mkMap (HM.toList -> xs) = [e| HM.fromList $(ListE <$> mapM mkKVPair xs) |] - mkKVPair (k, v) = [e| ($(mkText k), $(mkDefaultValue v)) e|] + mkKVPair (k, v) = [e| ($(mkText k), $(mkDefaultValue v)) |] mkNE (NE.toList -> xs) = [e| NE.fromList $(ListE <$> mapM mkSchema xs) |] @@ -415,26 +466,33 @@ mkField opts prefix field = do ftype <- mkFieldTypeName (fldType field) let fName = mkTextName $ (fieldNameBuilder opts) prefix field - pure (fName, defaultStrictness, ftype) + (fieldStrictness, fieldUnpackedness) = + fieldRepresentation opts prefix field + strictness = + case fieldStrictness of + StrictField -> strict fieldUnpackedness + LazyField -> notStrict + pure (fName, strictness, ftype) + genNewtype :: Name -> Q Dec #if MIN_VERSION_template_haskell(2,12,0) genNewtype dn = do ders <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]] fldType <- [t|ByteString|] - let ctor = RecC dn [(mkName ("un" ++ nameBase dn), defaultStrictness, fldType)] + let ctor = RecC dn [(mkName ("un" ++ nameBase dn), notStrict, fldType)] pure $ NewtypeD [] dn [] Nothing ctor [DerivClause Nothing ders] #elif MIN_VERSION_template_haskell(2,11,0) genNewtype dn = do ders <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]] fldType <- [t|ByteString|] - let ctor = RecC dn [(mkName ("un" ++ nameBase dn), defaultStrictness, fldType)] + let ctor = RecC dn [(mkName ("un" ++ nameBase dn), notStrict, fldType)] pure $ NewtypeD [] dn [] Nothing ctor ders #else genNewtype dn = do [ConT eq, ConT sh] <- sequenceA [[t|Eq|], [t|Show|], [t|Generic|]] fldType <- [t|ByteString|] - let ctor = RecC dn [(mkName ("un" ++ nameBase dn), defaultStrictness, fldType)] + let ctor = RecC dn [(mkName ("un" ++ nameBase dn), notStrict, fldType)] pure $ NewtypeD [] dn [] ctor [eq, sh] #endif @@ -468,11 +526,20 @@ pure $ DataD [] dn [] [RecC dn flds] [eq, sh] #endif -defaultStrictness :: Strict +notStrict :: Strict #if MIN_VERSION_template_haskell(2,11,0) -defaultStrictness = Bang SourceNoUnpack NoSourceStrictness +notStrict = Bang SourceNoUnpack NoSourceStrictness #else -defaultStrictness = NotStrict +notStrict = NotStrict +#endif + +strict :: FieldUnpackedness -> Strict +#if MIN_VERSION_template_haskell(2,11,0) +strict UnpackedField = Bang SourceUnpack SourceStrict +strict NonUnpackedField = Bang SourceNoUnpack SourceStrict +#else +strict UnpackedField = Unpacked +strict NonUnpackedField = IsStrict #endif mkTextName :: Text -> Name diff --git a/src/Data/Avro/JSON.hs b/src/Data/Avro/JSON.hs --- a/src/Data/Avro/JSON.hs +++ b/src/Data/Avro/JSON.hs @@ -75,32 +75,50 @@ import qualified Data.Avro.Schema as Schema import qualified Data.Avro.Types as Avro +decodeAvroJSON :: Schema -> Aeson.Value -> Result (Avro.Value Schema) +decodeAvroJSON schema json = + parseAvroJSON union env schema json + where + env = + Schema.buildTypeEnvironment missing schema . Schema.TN + missing name = + fail ("Type " <> show name <> " not in schema") + + union (Schema.Union schemas _) Aeson.Null + | Schema.Null `elem` schemas = + pure $ Avro.Union schemas Schema.Null Avro.Null + | otherwise = + fail "Null not in union." + union (Schema.Union schemas _) (Aeson.Object obj) + | null obj = + fail "Invalid encoding of union: empty object ({})." + | length obj > 1 = + fail "Invalid encoding of union: object with too many fields." + | otherwise = + let + branch = + head (HashMap.keys obj) + names = + HashMap.fromList [(Schema.typeName t, t) | t <- NE.toList schemas] + in case HashMap.lookup branch names of + Just t -> do + nested <- parseAvroJSON union env t (obj ! branch) + return (Avro.Union schemas t nested) + Nothing -> fail ("Type '" <> Text.unpack branch <> "' not in union: " <> show schemas) + union Schema.Union{} _ = + Avro.Error "Invalid JSON representation for union: has to be a JSON object with exactly one field." + union _ _ = + error "Impossible: function given non-union schema." + -- | Convert a 'Aeson.Value' into a type that has an Avro schema. The -- schema is used to validate the JSON and will return an 'Error' if -- the JSON object is not encoded correctly or does not match the schema. fromJSON :: forall a. (FromAvro a) => Aeson.Value -> Result a -fromJSON json = parseAvroJSON union env schema json >>= fromAvro - where schema = untag (Avro.schema :: Tagged a Schema) - env = Schema.buildTypeEnvironment missing schema . Schema.TN - missing name = fail $ "Type " <> show name <> " not in schema." - - union (Schema.Union schemas _) Aeson.Null - | Schema.Null `elem` schemas = pure $ Avro.Union schemas Schema.Null Avro.Null - | otherwise = fail "Null not in union." - union (Schema.Union schemas _) (Aeson.Object obj) - | length obj < 1 = fail "Invalid encoding of union: empty object ({})." - | length obj > 1 = fail "Invalid encoding of union: object with too many fields." - | otherwise = - let branch = head $ HashMap.keys obj - names = HashMap.fromList [(Schema.typeName t, t) | t <- NE.toList schemas] - in case HashMap.lookup branch names of - Just t -> do - nested <- parseAvroJSON union env t $ obj ! branch - return $ Avro.Union schemas t nested - Nothing -> fail $ "Type '" <> Text.unpack branch <> "' not in union: " <> show schemas - union Schema.Union{} _ = - Avro.Error "Invalid JSON representation for union: has to be a JSON object with exactly one field." - union _ _ = error "Impossible: function given non-union schema." +fromJSON json = do + value <- decodeAvroJSON schema json + fromAvro value + where + schema = untag (Avro.schema :: Tagged a Schema) -- | Parse a 'ByteString' as JSON and convert it to a type with an -- Avro schema. Will return 'Error' if the input is not valid JSON or