tagliatelle (empty) → 0.9.0
raw patch · 8 files changed
+1262/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, deepseq, hedgehog, insert-ordered-containers, microlens, openapi3, tagliatelle, tasty, tasty-hedgehog, tasty-hunit, text, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- README.md +74/−0
- library/Data/Tagliatelle.hs +769/−0
- library/Data/Tagliatelle/OpenApi.hs +67/−0
- library/Data/Tagliatelle/Properties.hs +85/−0
- tagliatelle.cabal +70/−0
- test/Spec.hs +181/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for tagliatelle++## 0.9.0 -- 2026-06-02++* First release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2026 Victor Miraldo++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,74 @@+# Tagliatelle++Simple codec-style library for `ToJSON`, `FromJSON` and `ToSchema`. Main design goals are:++1. Fast and Lean: tagliatelle codecs are cheap to compile and cheap to run. The performance is comparable to+hand-written `ToJSON/FromJSON` instances, even beating it for some types.+2. Explicit: You control the representation, no automatic anything. This makes it eaiser to keep the API backwards compatible+while the code itself evolves as needed.+3. Easy to use: Tries to minimise the boilerplate you need to maintain your codecs.+4. Domain Specific: it's meant for helping maintaining Haskell services with a large HTTP API; there won't be other formats. The librrary has been designed to make it easy to write codecs for Haskell datatypes in the sum-of-products with record accessors, because that's how I write most of my types.++This library was inspired by [`autodocodec`](https://github.com/NorfairKing/autodocodec); but I wanted something+that did less, so I could get a lighter footprint.++## Example++```haskell+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}++data TaskBody =+ Unstructured {body :: Text}+ | Absent+ | SubtasksMap { subtasksMap :: Map.Map TaskId TaskBody }+ | SubtasksList { subtasksList :: [TaskBody] }+ deriving (Eq, Show)++newtype TaskId = TaskId { taskId :: Int32 }+ deriving newtype (Eq, Show, Ord, IsKey, HasCodec)++instance HasCodec TaskBody where+ codec = coprod @"type" "TaskBody"+ (\case+ Unstructured {} -> unstructuredFields+ Absent {} -> absentFields+ SubtasksList {} -> subtasksListFields+ SubtasksMap {} -> subtasksMapFields+ )+ [unstructuredFields, absentFields, subtasksListFields, subtasksMapFields]+ where+ unstructuredFields = Tagged "unstructured" $ Unstructured <$> field "body" body codec+ absentFields = Tagged "absent" $ pure Absent+ subtasksListFields = Tagged "subtasks_list" $ SubtasksList <$> field "subtasks" subtasksList codec+ subtasksMapFields = Tagged "subtasks_map" $ SubtasksMap <$> field "subtasks" subtasksMap codec+```++This codec will produce JSON that, once formatted, looks like:++```+{+ "type": "subtasks_map",+ "subtasks": {+ "42": {+ "type": "subtasks_list",+ "subtasks": [+ {+ "type": "unstructured",+ "body": "test 1"+ },+ {+ "type": "absent"+ },+ {+ "type": "unstructured",+ "body": "test 2"+ }+ ]+ }+ }+}+```++Note that each hardcoded `Text` only shows up once: this makes it impossible to have spelling errors on tags between+encoder and decoder.
+ library/Data/Tagliatelle.hs view
@@ -0,0 +1,769 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Tagliatelle where++import Control.Monad (zipWithM)+import Data.Aeson+ ( Encoding,+ FromJSON,+ Key,+ Object,+ Series,+ ToJSON,+ Value,+ )+import Data.Aeson qualified as Aeson+import Data.Aeson.Encoding qualified as Enc+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, typeMismatch)+import Data.Aeson.Types qualified as Aeson+import Data.Data (Proxy (..))+import Data.HashMap.Strict.InsOrd qualified as InsOrd+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.OpenApi qualified as OA+import Data.Tagliatelle.OpenApi+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Text.Lazy.Builder.Int qualified as TB+import Data.Text.Read qualified as TR+import Data.Typeable (Typeable)+import Data.Vector qualified as V+import Data.Vector.Mutable qualified as VM+import Data.Word (Word32, Word64, Word8)+import GHC.Int (Int32, Int64)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Lens.Micro ((&), (.~))++-- * Codecs++-- | A tagliatelle @Codec@ provides a 'Value' encoder, decoder and corresponding OpenApi+-- specification for values of type @a@.+--+-- Codecs are made to fuse well, yielding core that is very close to hand-written+-- instances, if not better in some cases.+data Codec a = Codec+ { codecToEncoding :: a -> Encoding,+ codecToValue :: a -> Value,+ codecFromJSON :: Value -> Parser a,+ codecSchema :: Decl OA.NamedSchema+ }++-- | Codec's are not really functors, but we can transport them over isomorphisms.+codecMap :: (b -> a) -> (a -> b) -> Codec a -> Codec b+{-# INLINE codecMap #-}+codecMap from to c =+ Codec+ { codecToEncoding = codecToEncoding c . from,+ codecToValue = codecToValue c . from,+ codecFromJSON = fmap to . codecFromJSON c,+ codecSchema = codecSchema c+ }++-- ** DerivingVia helpers #derivingvia#++-- $derivingviaexample+-- The easiest way to use tagliatelle is to derive 'ToJSON', 'FromJSON'+-- and 'OA.ToSchema' @via ViaCodec@:+--+-- > data Sauce = Red { redSauce :: RedSauce } | Bechamel { whiteSauce :: WhiteSauce }+-- > deriving (ToJSON, FromJSON, ToSchema) via ViaCodec Sauce+-- >+-- > instance HasCodec Sauce where+-- > codec = ...++class HasCodec a where+ codec :: Codec a++-- | Newtype for @deriving via@. Requires a 'HasCodec' instance. Check <#g:derivingvia DerivingVia>+-- for an example.+newtype ViaCodec a = ViaCodec {unViaCodec :: a}++instance (HasCodec a) => ToJSON (ViaCodec a) where+ {-# INLINE toEncoding #-}+ toEncoding (ViaCodec a) = codecToEncoding (codec @a) a++ {-# INLINE toJSON #-}+ toJSON (ViaCodec a) = codecToValue (codec @a) a++instance (HasCodec a) => FromJSON (ViaCodec a) where+ {-# INLINE parseJSON #-}+ parseJSON v = ViaCodec <$> codecFromJSON (codec @a) v++instance (HasCodec a, Typeable a) => OA.ToSchema (ViaCodec a) where+ declareNamedSchema _ = codecSchema (codec @a)++-- ** Products++-- | Wraps a 'ProductCodec' into a JSON Object, giving us a 'Codec'+prod :: Text -> ProductCodec a -> Codec a+{-# INLINE prod #-}+prod name oc =+ Codec+ { codecToEncoding = Aeson.pairs . prodSeries oc,+ codecToValue = \v -> Aeson.Object $ prodObject oc v mempty,+ codecFromJSON = Aeson.withObject (Text.unpack name) (prodDecode oc),+ codecSchema = do+ props <- traverse (\(k, d, req) -> (req,) . (k,) <$> d) (prodSchema oc)+ pure $+ OA.NamedSchema (Just name) $+ mempty+ & OA.type_ .~ Just OA.OpenApiObject+ & OA.properties .~ InsOrd.fromList (map snd props)+ & OA.required .~ map (fst . snd) (filter fst props)+ }++-- | A @PartialProdCodec s a@ encodes/decodes an @a@ that is a component within+-- a product-like type @s@. This type is pretty much the same as @ObjectCodec@+-- from @autodocodec@, where we drew inspiration from.+data PartialProdCodec s a = PartialProdCodec+ { prodSeries :: s -> Series,+ prodObject :: s -> Object -> Object,+ prodDecode :: Object -> Parser a,+ prodSchema ::+ [ ( Text,+ Decl (OA.Referenced OA.Schema),+ Bool -- is this field required?+ )+ ]+ }++-- | In a @PartialProdCodec s a@, when @s ~ a@, the codec is no longer /partial/,+-- it encodes/decodes the shole @s@. 'ProductCodec' is just a synonym for that.+type ProductCodec a = PartialProdCodec a a++instance Functor (PartialProdCodec s) where+ fmap f oc = oc {prodDecode = fmap (fmap f) (prodDecode oc)}++instance Applicative (PartialProdCodec s) where+ {-# INLINE pure #-}+ pure a = PartialProdCodec (const mempty) (const id) (const (pure a)) []+ {-# INLINE (<*>) #-}+ f <*> x =+ PartialProdCodec+ { prodSeries = \s -> prodSeries f s <> prodSeries x s,+ prodObject = \v -> prodObject f v . prodObject x v,+ prodDecode = \o -> prodDecode f o <*> prodDecode x o,+ prodSchema = prodSchema f <> prodSchema x+ }++-- | Fields are used in the context of a 'PartialProdCodec':+--+-- > data Version = Version { major :: Int, minor :: Maybe Int }+-- >+-- > instance HasCodec Version where+-- > codec = prod "Version" $ Version+-- > <$> T.field "major" major codec+-- > <*> T.optField "minor" minor codec+field :: Key -> (s -> a) -> Codec a -> PartialProdCodec s a+{-# INLINE field #-}+field key acc c =+ PartialProdCodec+ { prodSeries = \s -> Enc.pair key (codecToEncoding c (acc s)),+ prodObject = \v ->+ let !r = codecToValue c (acc v)+ in KeyMap.insert key r,+ prodDecode = \o ->+ case KeyMap.lookup key o of+ Nothing -> fail ("missing key: " <> Key.toString key)+ Just v -> codecFromJSON c v Aeson.<?> Aeson.Key key,+ prodSchema = [(Key.toText key, declareSchemaRef (codecSchema c), True)] -- required = True+ }++-- | Just like 'field', but optional. Check 'field' for an example.+-- Absent or 'Aeson.Null' decodes to 'Nothing'; 'Nothing' is omitted on encode.+optField :: Key -> (s -> Maybe a) -> Codec a -> PartialProdCodec s (Maybe a)+{-# INLINE optField #-}+optField key acc c =+ PartialProdCodec+ { prodSeries = \s -> case acc s of+ Nothing -> mempty -- omit+ Just a -> Enc.pair key (codecToEncoding c a),+ prodObject = \v -> case acc v of+ Nothing -> id+ Just a -> KeyMap.insert key (codecToValue c a),+ prodDecode = \o ->+ case KeyMap.lookup key o of+ Nothing -> pure Nothing -- absent = Nothing+ Just Aeson.Null -> pure Nothing -- accept null too (lenient)+ Just v -> Just <$> (codecFromJSON c v Aeson.<?> Aeson.Key key),+ prodSchema = [(Key.toText key, declareSchemaRef (codecSchema c), False)] -- required = False+ }++-- ** Coproducts #coproducts#++-- $coproductsexample+-- Tagliatelle produces tagged encodings, as the name hints. Every coproduct case, then,+-- must be specified by a @TaggedCodec t@; the type variable @t@ is a type-level 'Symbol'+-- used to specify the label for the tag:+--+-- > data Sauce = Red { redSauce :: RedSauce } | Bechamel { bechSauce :: WhiteSauce }+-- >+-- > instance HasCodec Sauce where+-- > codec = coprod @"sauce_type" "Sauce"+-- > ( \case+-- > Red {} -> redFields+-- > Bechamel {} -> bechamelFields+-- > )+-- > [redFields, bechamelFields]+-- > where+-- > redFields :: TaggedCodec t Sauce+-- > redFields = Tagged "red" (Red <$> field "sauce" redSauce codec)+-- >+-- > bechamelFields = Tagged "bechamel" (Bechamel <$> field "sauce" bechSauce codec)+--+-- This codec will produce JSON 'Value's discriminated by @"sauce_type"@, which can take the+-- values either @"red"@ or @"bechamel"@. Note that to specify this codec, the programmer+-- only wrote each tag once, this removes the chance of misspelling a tag and having+-- a decoder that wont work.++-- | Same as adding another 'field' to the 'ProductCodec', but this field+-- name is passed at the type level, through @t@.+data TaggedCodec (t :: Symbol) a where+ Tagged :: forall t a. Text -> ProductCodec a -> TaggedCodec t a++-- | Creates a codec for a coproduct-like type. The type-level @Symbol@ is the label+-- that tagliatelle will use for tagging the values. Check <#g:coproducts Coproducts Section>+-- for an example.+--+-- This is slightly more expensive than a hand-written @case@ statement, but we have no+-- choice but to keep a map of tags to dispatchers in memory, so we know which codec+-- to use by each constructor. A design goal of @coprod@ is that you never write a+-- magic string twice: removing the chance of spelling errors.+coprod ::+ forall t a.+ (KnownSymbol t) =>+ Text ->+ (a -> TaggedCodec t a) ->+ [TaggedCodec t a] ->+ Codec a+{-# INLINE coprod #-}+coprod name dispatch decoders =+ Codec+ { codecToEncoding = \a -> case dispatch a of+ Tagged tag pc -> Aeson.pairs $ Enc.pair tagField (Enc.text tag) <> prodSeries pc a,+ codecToValue = \v -> case dispatch v of+ Tagged tag pc -> Aeson.Object (prodObject pc v (KeyMap.singleton tagField (Aeson.String tag))),+ codecFromJSON = Aeson.withObject (Text.unpack name) $ \o -> do+ tag <- o Aeson..: tagField+ case Map.lookup tag decoderMap of+ Nothing -> fail ("unknown tag: " <> Text.unpack tag)+ Just dec -> Aeson.modifyFailure (("On case " <> Text.unpack tag) <>) (prodDecode dec o),+ codecSchema = do+ refs <-+ traverse+ ( \(tag, pc) -> declareSchemaRef $ do+ props <- traverse (\(k, d, _) -> (k,) <$> d) (prodSchema pc)+ let reqs = [k | (k, _, True) <- prodSchema pc]+ tagValSchema =+ mempty+ & OA.type_+ .~ Just OA.OpenApiString+ & OA.enum_+ .~ Just [Aeson.String tag]+ schema =+ mempty+ & OA.type_+ .~ Just OA.OpenApiObject+ & OA.properties+ .~ InsOrd.fromList+ ((tagFieldName, OA.Inline tagValSchema) : props)+ & OA.required+ .~ (tagFieldName : reqs)+ pure $ OA.NamedSchema (Just (name <> "." <> tag)) $ schema+ )+ decoderList+ pure $+ OA.NamedSchema (Just name) $+ mempty+ & OA.oneOf+ .~ Just refs+ & OA.discriminator+ .~ Just (OA.Discriminator tagFieldName mempty)+ }+ where+ pt = Proxy @t+ !tagFieldName = Text.pack $ symbolVal pt+ !tagField = Key.fromText tagFieldName++ decoderList :: [(Text, ProductCodec a)]+ decoderList = [(tagVal, pc) | Tagged tagVal pc <- decoders]++ !decoderMap =+ Map.fromListWith+ (\_ _ -> error $ "coprod: duplicate tag for field " <> Text.unpack tagFieldName)+ decoderList++-- ** Enums++-- | Explicit enumeration codec. Keeps two 'Map.Map' for encoding and+-- decoding, hence the @Ord a@ constraint.+enum :: (Ord a) => Text -> [(a, Text)] -> Codec a+enum name pairs =+ Codec+ { codecToEncoding = Aeson.toEncoding . encode',+ codecToValue = Aeson.String . encode',+ codecFromJSON = \case+ Aeson.String t ->+ maybe+ (fail $ "unknown " <> Text.unpack name <> ": " <> Text.unpack t)+ pure+ (Map.lookup t decodeMap)+ v -> typeMismatch "String" v,+ codecSchema =+ pure $+ OA.NamedSchema (Just name) $+ mempty+ & OA.type_ .~ Just OA.OpenApiString+ & OA.enum_ .~ Just (map (Aeson.String . snd) pairs)+ }+ where+ !encodeMap = Map.fromList pairs+ !decodeMap = Map.fromList (map (\(a, t) -> (t, a)) pairs)+ encode' a =+ maybe+ (error $ "Servanter.Codec.enum: non-exhaustive table for " <> Text.unpack name)+ id+ (Map.lookup a encodeMap)++-- ** Tuples and Triples++instance (HasCodec a, HasCodec b) => HasCodec (a, b) where+ codec = tuple codec codec++-- | Encodes a tuple as an array, just like @Aeson.toJSON ("a", 4)@ would.+tuple :: Codec a -> Codec b -> Codec (a, b)+{-# INLINE tuple #-}+tuple codecA codecB =+ Codec+ { codecToEncoding = \(a, b) -> Enc.list id [codecToEncoding codecA a, codecToEncoding codecB b],+ codecToValue = \(a, b) -> Aeson.Array $ V.create $ do+ mv <- VM.unsafeNew 2+ VM.unsafeWrite mv 0 (codecToValue codecA a)+ VM.unsafeWrite mv 1 (codecToValue codecB b)+ pure mv,+ codecFromJSON =+ Aeson.withArray "tuple" $ \arr ->+ if V.length arr /= 2+ then fail "Expecting exactly two elements"+ else+ (,)+ <$> codecFromJSON codecA (arr V.! 0) Aeson.<?> Aeson.Index 0+ <*> codecFromJSON codecB (arr V.! 1) Aeson.<?> Aeson.Index 1,+ codecSchema = do+ refA <- declareSchemaRef $ codecSchema codecA+ refB <- declareSchemaRef $ codecSchema codecB+ pure $+ OA.NamedSchema Nothing $+ mempty+ & OA.type_ .~ Just OA.OpenApiArray+ & OA.items .~ Just (OA.OpenApiItemsArray [refA, refB])+ & OA.maxItems .~ Just 2+ & OA.minItems .~ Just 2+ }++instance (HasCodec a, HasCodec b, HasCodec c) => HasCodec (a, b, c) where+ codec = triple codec codec codec++-- | Encodes a triple as an array, just like @Aeson.toJSON ("a", 4, "b")@ would.+triple :: Codec a -> Codec b -> Codec c -> Codec (a, b, c)+{-# INLINE triple #-}+triple codecA codecB codecC =+ Codec+ { codecToEncoding = \(a, b, c) -> Enc.list id [codecToEncoding codecA a, codecToEncoding codecB b, codecToEncoding codecC c],+ codecToValue = \(a, b, c) -> Aeson.Array $ V.create $ do+ mv <- VM.unsafeNew 3+ VM.unsafeWrite mv 0 (codecToValue codecA a)+ VM.unsafeWrite mv 1 (codecToValue codecB b)+ VM.unsafeWrite mv 2 (codecToValue codecC c)+ pure mv,+ codecFromJSON =+ Aeson.withArray "triple" $ \arr ->+ if V.length arr /= 3+ then fail "Expecting exactly three elements"+ else+ (,,)+ <$> codecFromJSON codecA (arr V.! 0) Aeson.<?> Aeson.Index 0+ <*> codecFromJSON codecB (arr V.! 1) Aeson.<?> Aeson.Index 1+ <*> codecFromJSON codecC (arr V.! 2) Aeson.<?> Aeson.Index 2,+ codecSchema = do+ refA <- declareSchemaRef $ codecSchema codecA+ refB <- declareSchemaRef $ codecSchema codecB+ refC <- declareSchemaRef $ codecSchema codecC+ pure $+ OA.NamedSchema Nothing $+ mempty+ & OA.type_ .~ Just OA.OpenApiArray+ & OA.items .~ Just (OA.OpenApiItemsArray [refA, refB, refC])+ & OA.maxItems .~ Just 3+ & OA.minItems .~ Just 3+ }++-- ** List++instance (HasCodec a) => HasCodec [a] where+ codec = list codec++-- | Encodes lists as JSON arrays. This is significantly more efficient than+-- a recursive encoding and is just like @aeson@ does it.+list :: Codec a -> Codec [a]+{-# INLINE list #-}+list Codec {..} =+ Codec+ { codecToEncoding = Enc.list codecToEncoding,+ codecToValue = Aeson.Array . V.fromList . map codecToValue,+ codecFromJSON =+ Aeson.withArray "list" $ \a ->+ zipWithM (\ix v -> codecFromJSON v Aeson.<?> Aeson.Index ix) [0 ..] $ V.toList a,+ codecSchema = do+ ref <- declareSchemaRef codecSchema+ pure $+ OA.NamedSchema Nothing $+ mempty+ & OA.type_ .~ Just OA.OpenApiArray+ & OA.items .~ Just (OA.OpenApiItemsObject ref)+ }++-- ** Maybe++instance (HasCodec a) => HasCodec (Maybe a) where+ codec = nullable codec++-- | Encodes a @Maybe a@, mapping @Nothing@ to 'Aeson.Null'. This is not meant to be+-- used for marking fields of a produc codec optional, use 'optField' for that.+nullable :: Codec a -> Codec (Maybe a)+{-# INLINE nullable #-}+nullable c =+ Codec+ { codecToEncoding = \case+ Nothing -> Aeson.toEncoding Aeson.Null+ Just a -> codecToEncoding c a,+ codecToValue = \case+ Nothing -> Aeson.Null+ Just v -> codecToValue c v,+ codecFromJSON = \case+ Aeson.Null -> pure Nothing+ v -> Just <$> codecFromJSON c v,+ codecSchema = mkNullable <$> declareSchemaRef (codecSchema c)+ }++-- ** Map++parseBoundedSigned :: forall a. (Integral a, Bounded a) => Text -> Parser a+{-# INLINE parseBoundedSigned #-}+parseBoundedSigned t =+ case TR.signed TR.decimal t of+ Right (n :: Integer, rest)+ | not (Text.null rest) ->+ fail $ "trailing characters after integer: " <> Text.unpack rest+ | n < toInteger (minBound :: a) || n > toInteger (maxBound :: a) ->+ fail $ "integer out of range: " <> show n+ | otherwise -> pure (fromInteger n)+ Left e -> fail e++parseBoundedUnsigned :: forall a. (Integral a, Bounded a) => Text -> Parser a+{-# INLINE parseBoundedUnsigned #-}+parseBoundedUnsigned t =+ case TR.decimal t of+ Right (n :: Integer, rest)+ | not (Text.null rest) ->+ fail $ "trailing characters after integer: " <> Text.unpack rest+ | n < 0 || n > toInteger (maxBound :: a) ->+ fail $ "unsigned integer out of range: " <> show n+ | otherwise -> pure (fromInteger n)+ Left e -> fail e++-- | Converts an integral type into a 'Aeson.Key'; for small numbers,+-- it is faster to just call:+--+-- > Key.fromText (Text.pack (show n))+--+-- But I don't want to be maintaining a million specialised helpers.+intDecToKey :: (Integral a) => a -> Key+{-# INLINE intDecToKey #-}+intDecToKey = Key.fromText . TL.toStrict . TB.toLazyText . TB.decimal++-- | 'IsKey' tells tagliatelle how to convert values of a type @k@ for them to appear as+-- JSON keys. We're deliberately not relying on 'Aeson.ToJSONKey' infrastructure: it does+-- some magic when deciding the representation. We don't do magic in this library.+-- For example, for @Int@ keys, @"1000"@ and @"1e3"@ parse to the same key according to+-- 'Aeson.FromJSONKey' instance for @Int@. Tagliatelle will give you an error:+--+-- > ghci> let v = Aeson.object [("1000",Aeson.String "a"),("1e3",Aeson.String "b")]+-- > ghci> Aeson.parseEither Aeson.parseJSON v :: Either String (Map.Map Int32 String)+-- > Right (fromList [(1000,"a")])+-- > ghci> Aeson.parseEither (codecFromJSON codec) v :: Either String (Map.Map Int32 String)+-- > Left "Error in $['1e3']: trailing characters after integer: e3"+class (Ord k) => IsKey k where+ toKey :: k -> Key+ encodeKey :: k -> Enc.Encoding' Key+ parseKey :: Key -> Parser k++instance IsKey Int32 where+ {-# INLINE encodeKey #-}+ encodeKey = Enc.int32Text+ {-# INLINE parseKey #-}+ parseKey = parseBoundedSigned . Key.toText+ {-# INLINE toKey #-}+ toKey = intDecToKey++instance IsKey Int64 where+ {-# INLINE encodeKey #-}+ encodeKey = Enc.int64Text+ {-# INLINE parseKey #-}+ parseKey = parseBoundedSigned . Key.toText+ {-# INLINE toKey #-}+ toKey = intDecToKey++instance IsKey Word8 where+ {-# INLINE encodeKey #-}+ encodeKey = Enc.word8Text+ {-# INLINE parseKey #-}+ parseKey = parseBoundedUnsigned . Key.toText+ {-# INLINE toKey #-}+ toKey = intDecToKey++instance IsKey Word32 where+ {-# INLINE encodeKey #-}+ encodeKey = Enc.word32Text+ {-# INLINE parseKey #-}+ parseKey = parseBoundedUnsigned . Key.toText+ {-# INLINE toKey #-}+ toKey = intDecToKey++instance IsKey Word64 where+ {-# INLINE encodeKey #-}+ encodeKey = Enc.word64Text+ {-# INLINE parseKey #-}+ parseKey = parseBoundedUnsigned . Key.toText+ {-# INLINE toKey #-}+ toKey = intDecToKey++instance {-# OVERLAPPING #-} (HasCodec v) => HasCodec (Map Text v) where+ codec = kvmapText codec++instance {-# OVERLAPPABLE #-} (IsKey k, HasCodec v) => HasCodec (Map k v) where+ codec = kvmap codec++-- | Encodes a map as a JSON object, this means we need to be able to translate+-- @k@ into JSON keys. The @IsKey@ instance will do that for you. If you rather+-- encode your map as an array of pairs, check 'kvmapAsList' instead.+--+-- If @k ~ Text@, you're better of using 'kvmapText'+kvmap :: (IsKey k) => Codec v -> Codec (Map k v)+{-# INLINE kvmap #-}+kvmap Codec {..} =+ Codec+ { codecToEncoding = \m -> Enc.dict encodeKey codecToEncoding Map.foldrWithKey m,+ codecToValue = \m ->+ Aeson.Object $+ -- KeyMap.fromMap is just coerce when Aeson is built with ordered-keymap,+ -- which it is, by default.+ KeyMap.fromMap $+ Map.foldlWithKey'+ (\acc k v -> Map.insert (toKey k) (codecToValue v) acc)+ Map.empty+ m,+ codecFromJSON =+ Aeson.withObject "kvmap" $+ -- When @k~Text@, this is horrible: we're building a whole map when that is not+ -- needed at all! Check 'kvmapText'+ KeyMap.foldrWithKey+ ( \k v m ->+ Map.insert+ <$> (parseKey k Aeson.<?> Aeson.Key k)+ <*> (codecFromJSON v Aeson.<?> Aeson.Key k)+ <*> m+ )+ (pure Map.empty),+ codecSchema = do+ ref <- declareSchemaRef $ codecSchema+ pure $+ OA.NamedSchema Nothing $+ mempty+ & OA.type_+ .~ Just OA.OpenApiObject+ & OA.additionalProperties+ .~ Just (OA.AdditionalPropertiesSchema ref)+ }++-- | Sometimes your key type is more involved and you don't want to write @IsKey k@+-- instance. In those cases, just represent the map as a list of tuples. This is what+-- Aeson does when you define the 'Aeson.ToJSONKeyFunction'to be a @ToJSONKeyValue@.+kvmapAsList :: (Ord k) => Codec k -> Codec v -> Codec (Map k v)+{-# INLINE kvmapAsList #-}+kvmapAsList codecK codecV = codecMap Map.toList Map.fromList (list (tuple codecK codecV))++-- | If your map is already keyed by 'Text', then we can do a lot better than 'kvmap' :)+--+-- This codec assumes that 'Key.toText' and 'Key.fromText' is monotonic, which should be because+-- as of @aeson-2.x.x.x@, 'Key.Key' is just a newtype wrapper over 'Text' and 'Ord'+-- is either derived or newtype-derived, in both cases, perfectly safe to run it+-- on a 'Map.mapKeysMonotonic'+--+-- Aeson manages this with a complex definition of @FromJSONKeyFunction@, which does some+-- magic when the right constructor is chosen. Tagliatelle does no magic, therefore,+-- we expose this specialised codec.+kvmapText :: Codec v -> Codec (Map Text v)+{-# INLINE kvmapText #-}+kvmapText Codec {..} =+ Codec+ { codecToEncoding = \m -> Enc.dict Enc.text codecToEncoding Map.foldrWithKey m,+ codecToValue = \m ->+ Aeson.Object $+ -- KeyMap.fromMap is just coerce when Aeson is built with ordered-keymap, which it is, by default.+ KeyMap.fromMap $+ fmap codecToValue $+ Map.mapKeysMonotonic Key.fromText m,+ codecFromJSON =+ Aeson.withObject "kvmapText" $+ fmap (Map.mapKeysMonotonic Key.toText)+ . Map.traverseWithKey (\k v -> codecFromJSON v Aeson.<?> Aeson.Key k)+ . KeyMap.toMap,+ codecSchema = do+ ref <- declareSchemaRef $ codecSchema+ pure $+ OA.NamedSchema Nothing $+ mempty+ & OA.type_+ .~ Just OA.OpenApiObject+ & OA.additionalProperties+ .~ Just (OA.AdditionalPropertiesSchema ref)+ }++-- * Primitives++-- | Lifts a type for which we have a 'ToJSON', 'FromJSON' and a 'OA.NamedSchema' into+-- a codec. This should be used for primitive types, otherwise you'd be forfeiting+-- the fusing benefits from tagliatelle.+primitive :: (ToJSON a, FromJSON a) => OA.NamedSchema -> Codec a+{-# INLINE primitive #-}+primitive ns =+ Codec+ { codecToEncoding = Aeson.toEncoding,+ codecToValue = Aeson.toJSON,+ codecFromJSON = Aeson.parseJSON,+ codecSchema = pure ns+ }++instance HasCodec Bool where codec = bool++-- | Codec for booleans+bool :: Codec Bool+bool = primitive $ OA.NamedSchema Nothing (mempty & OA.type_ .~ Just OA.OpenApiBoolean)++instance HasCodec Int where codec = int++-- | Codec for ints+int :: Codec Int+int =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiInteger+ & OA.format .~ Just "int"+ & OA.default_ .~ Just (Aeson.toJSON (7 :: Int))+ )++instance HasCodec Int32 where codec = int32++-- | Codec for 'Int32'+int32 :: Codec Int32+int32 =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiInteger+ & OA.format .~ Just "int32"+ & OA.default_ .~ Just (Aeson.toJSON (7 :: Int32))+ )++instance HasCodec Int64 where codec = int64++-- | Codec for 'Int64'+int64 :: Codec Int64+int64 =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiInteger+ & OA.format .~ Just "int64"+ & OA.default_ .~ Just (Aeson.toJSON (7 :: Int64))+ )++instance HasCodec Integer where codec = integer++-- | Codec for 'Integer'+integer :: Codec Integer+integer =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiInteger+ & OA.default_ .~ Just (Aeson.toJSON (7 :: Integer))+ )++instance HasCodec Double where codec = double++-- | Codec for 'Double'+double :: Codec Double+double =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiNumber+ & OA.format .~ Just "double"+ & OA.default_ .~ Just (Aeson.toJSON (4.25 :: Double))+ )++instance HasCodec Float where codec = float++-- | Codec for 'Float+float :: Codec Float+float =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiNumber+ & OA.format .~ Just "float"+ & OA.default_ .~ Just (Aeson.toJSON (4.25 :: Float))+ )++instance HasCodec Text where codec = text++-- | Codec for 'Text', adds an example value making it clear this accepts utf8 text.+text :: Codec Text+text =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiString+ & OA.default_ .~ Just (Aeson.String "utf8 text 🌍")+ )++instance {-# OVERLAPPING #-} HasCodec String where codec = string++-- | Codec for 'String, adds an example value making it clear this accepts only ASCII chars.+string :: Codec String+string =+ primitive $+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.type_ .~ Just OA.OpenApiString+ & OA.default_ .~ Just (Aeson.String "ascii string")+ )
+ library/Data/Tagliatelle/OpenApi.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE LambdaCase #-}++-- | Haskell's @Data.OpenApi@ has functions that rely on+-- @Proxy a@ and a @ToSchema a@ instance:+--+-- > declareSchemaRef :: Data.OpenApi.ToSchema a => Proxy a -> ...+--+-- We can't just use these functions like that. As a codec-combinator library,+-- tagliatelle's functions need to explicitly pass the schema codec:+--+-- > declareSchemaRef' :: Declare (Definitions Schema) -> ...+--+-- This module modifies the few @Data.OpenApi@ functions we need to build+-- some reasonable OpenApi definitions for our codecs, removing the need+-- for typeclasses and receiving explicit codecs.+module Data.Tagliatelle.OpenApi where++import Control.Monad (void, when)+import Data.HashMap.Strict.InsOrd qualified as InsOrd+import Data.OpenApi qualified as OA+import Data.OpenApi.Declare qualified as DC+import Data.Text qualified as Text+import Lens.Micro ((&), (.~))++type Decl = DC.Declare (OA.Definitions OA.Schema)++toNamedSchema :: Decl OA.NamedSchema -> OA.NamedSchema+toNamedSchema = DC.undeclare++declareSchema :: Decl OA.NamedSchema -> Decl OA.Schema+declareSchema = fmap OA._namedSchemaSchema++declareSchemaRef :: Decl OA.NamedSchema -> Decl (OA.Referenced OA.Schema)+declareSchemaRef act = do+ case toNamedSchema act of+ OA.NamedSchema (Just name) schema -> do+ known <- DC.looks (InsOrd.member name)+ when (not known) $ do+ DC.declare (InsOrd.singleton name schema)+ void act+ return $ OA.Ref (OA.Reference name)+ _ -> OA.Inline <$> declareSchema act++resolveRef ::+ OA.Definitions OA.Schema ->+ OA.Referenced OA.Schema ->+ OA.Schema+resolveRef defs = \case+ OA.Inline s -> s+ OA.Ref (OA.Reference name) ->+ case InsOrd.lookup name defs of+ Just s -> s+ Nothing -> error $ "resolveRef: dangling reference " <> Text.unpack name++mkNullable :: OA.Referenced OA.Schema -> OA.NamedSchema+mkNullable (OA.Inline schema) =+ OA.NamedSchema Nothing (schema & OA.nullable .~ Just True)+mkNullable ref@(OA.Ref _) =+ -- Can't mutate a referenced schema; the inner schema is shared+ -- across all uses of that type. Wrap in an anonymous schema that+ -- adds nullability via allOf.+ OA.NamedSchema+ Nothing+ ( mempty+ & OA.allOf .~ Just [ref]+ & OA.nullable .~ Just True+ )
+ library/Data/Tagliatelle/Properties.hs view
@@ -0,0 +1,85 @@+-- | Provide some important properties for you to integrate+-- into your own test suite. We use @tasty@ and @hedgehog@ here.+module Data.Tagliatelle.Properties where++import Data.Aeson qualified as Aeson+import Data.Aeson.Types qualified as Aeson+import Data.OpenApi qualified as OpenApi+import Data.OpenApi.Declare qualified as OpenApi+import Data.Tagliatelle+import Data.Tagliatelle.OpenApi (declareSchemaRef, resolveRef)+import Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog (testProperty)++-- | 'codecToValue' and 'codecFromJSON' should roundtrip.+toFromValueRoundtrip ::+ forall a m.+ (Eq a, Show a, HasCodec a, Monad m) =>+ a -> PropertyT m ()+toFromValueRoundtrip x = do+ let v = codecToValue codec x+ case Aeson.parse (codecFromJSON codec) v :: Aeson.Result a of+ Aeson.Error e -> annotateShow v >> footnote e >> failure+ Aeson.Success y -> y === x++-- | 'codecToValue' and 'codecFromJSON' should roundtrip.+toFromEncodingRoundtrip ::+ forall a m.+ (Eq a, Show a, HasCodec a, Monad m) =>+ a -> PropertyT m ()+toFromEncodingRoundtrip x = do+ let bs = Aeson.encode (ViaCodec x)+ case Aeson.eitherDecode bs :: Either String (ViaCodec a) of+ Left e -> annotateShow x >> footnote e >> failure+ Right (ViaCodec y) -> y === x++-- | Encoding the 'Aeson.Value' resulting from 'codecToValue',+-- then decoding back to @a@ should be the identity, too.+toValueDecodeRoundtrip ::+ forall a m.+ (Eq a, Show a, HasCodec a, Monad m) =>+ a -> PropertyT m ()+toValueDecodeRoundtrip x = do+ let value = codecToValue codec x+ encodedValue = Aeson.encode value+ decodedX = Aeson.decode encodedValue+ Just x === fmap unViaCodec decodedX++-- | Check that the tagliatelle generated schema validates the 'Aeson.Value' produced.+schemaValidates ::+ forall a m.+ (Show a, HasCodec a, Monad m) =>+ (OpenApi.Definitions OpenApi.Schema, OpenApi.Referenced OpenApi.Schema) -> a -> PropertyT m ()+schemaValidates (defs, ref) x =+ let schema = resolveRef defs ref+ v = codecToValue codec x+ in do+ case OpenApi.validateJSON defs schema v of+ [] -> success+ es -> do+ annotateShow v+ annotateShow schema+ mapM_ annotateShow es+ failure++-- | Conveniently wrap the codec laws into a 'TestTree' for your test suite.+codecLawsBundle ::+ forall a. (Eq a, Show a, HasCodec a) => TestName -> Gen a -> TestTree+codecLawsBundle name gen =+ let defsref = OpenApi.runDeclare (declareSchemaRef $ codecSchema (codec @a)) mempty+ in testGroup+ name+ [ testProperty "toFromValue roundrip: fromJSON . toValue == id" $+ property $+ forAll gen >>= toFromValueRoundtrip,+ testProperty "toFromEncoding roundrip: decode . toEncoding == id" $+ property $+ forAll gen >>= toFromEncodingRoundtrip,+ testProperty "toValueDecode roundtrip: decode . toEncoding . toValue == id" $+ property $+ forAll gen >>= toValueDecodeRoundtrip,+ testProperty "OpenApi toValue validation" $+ property $+ forAll gen >>= schemaValidates defsref+ ]
+ tagliatelle.cabal view
@@ -0,0 +1,70 @@+cabal-version: 3.4+name: tagliatelle+version: 0.9.0+synopsis: Tagged encodings that are not spaghetti+license: BSD-3-Clause+license-file: LICENSE+category: Text, Web, JSON+author: Victor Miraldo <vcm.oss@fastmail.com>+maintainer: Victor Miraldo <vcm.oss@fastmail.com>+homepage: https://codeberg.org/VictorCMiraldo/tagliatelle+bug-reports: https://codeberg.org/VictorCMiraldo/tagliatelle/issues++description:+ A simple codec library for producing @Data.Aeson.Value@s and a @Data.OpenApi.Schema@, focused+ on simplicity and performance.++extra-source-files:+ CHANGELOG.md+ README.md++tested-with:+ GHC == 9.12.3+ , GHC == 9.10.3+ , GHC == 9.6.7++common defaults+ default-language: GHC2021+ default-extensions: OverloadedStrings+ ghc-options: -Wall -Wunused-imports++library+ import: defaults+ hs-source-dirs: library+ exposed-modules:+ Data.Tagliatelle+ Data.Tagliatelle.Properties+ Data.Tagliatelle.OpenApi+ build-depends:+ aeson >= 2.2.5 && < 2.3+ , base >= 4.18 && < 5+ , bytestring >= 0.11.5 && < 0.13+ , containers >= 0.6.7 && < 1+ , deepseq >= 1.4.8 && < 1.6+ , hedgehog >= 1.7 && < 1.8+ , insert-ordered-containers >= 0.2.7 && < 0.3+ , microlens >= 0.5 && < 0.6+ , openapi3 >= 3.2.5 && < 3.3+ , tasty >= 1.5.4 && < 1.6+ , tasty-hedgehog >= 1.4 && < 1.5+ , text >= 2.0.2 && < 3+ , vector >= 0.13.2 && < 0.14++test-suite tests+ import: defaults+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ tagliatelle+ , aeson >= 2.2.5 && < 2.3+ , base >= 4.18 && < 5+ , bytestring >= 0.11.5 && < 0.13+ , containers >= 0.6.7 && < 1+ , deepseq >= 1.4.8 && < 1.6+ , hedgehog >= 1.7 && < 1.8+ , openapi3 >= 3.2.5 && < 3.3+ , tasty >= 1.5.4 && < 1.6+ , tasty-hedgehog >= 1.4 && < 1.5+ , tasty-hunit >= 0.10.2 && < 0.11+ , text >= 2.0.2 && < 3
+ test/Spec.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Main (main) where++import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.OpenApi qualified as OpenApi+import Data.Tagliatelle+import Data.Tagliatelle.Properties+import Data.Text (Text)+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Hedgehog (testProperty)++main :: IO ()+main =+ defaultMain $+ testGroup+ "Tagliatelle"+ [ codecsLawful,+ testGroup+ "Dependency Assumptions"+ [ aesonAssumptions+ ]+ ]++-- kvmapText relies on fromText and toText being monotonic+aesonAssumptions :: TestTree+aesonAssumptions =+ testGroup+ "aeson"+ [ testProperty "Key.fromText is monotonic" $ property $ do+ a <- forAll genText+ b <- forAll $ Gen.filter (>= a) genText+ assert (Key.fromText a <= Key.fromText b),+ testProperty "Key.toText is monotonic" $ property $ do+ a <- fmap Key.fromText $ forAll genText+ b <- forAll $ Gen.filter (>= a) $ fmap Key.fromText genText+ assert (Key.toText a <= Key.toText b)+ ]+ where+ genText = Gen.text (Range.linear 0 20) Gen.unicode++codecsLawful :: TestTree+codecsLawful =+ let s = 4+ r = Range.linear 3 20+ genInt = Gen.int64 (Range.linearFrom 0 minBound maxBound)+ in testGroup+ "Codecs are Lawful"+ [ -- Our test types:+ codecLawsBundle "TestProd" genTestProd,+ codecLawsBundle "TestCoprod" genTestCoprod,+ codecLawsBundle "TestRecursive" (genTestRecursive s),+ -- Compositions of them+ codecLawsBundle+ "(TestProd, TestEnum, TestProd)"+ ((,,) <$> genTestProd <*> genEnum <*> genTestProd),+ codecLawsBundle+ "[(TestProd, TestCoprod)]"+ (Gen.list r ((,) <$> genTestProd <*> genTestCoprod)),+ codecLawsBundle+ "Map Int TestRecursive"+ (Gen.map r ((,) <$> genInt <*> genTestRecursive s)),+ codecLawsBundle+ "Map Text TestCoprod"+ (Gen.map r ((,) <$> Gen.text r Gen.unicodeAll <*> genTestCoprod)),+ codecLawsBundle+ "[Map Int (TestProd, Map Text TestCoprod)]"+ ( Gen.list+ r+ ( Gen.map+ r+ ( (,)+ <$> genInt+ <*> ( (,)+ <$> genTestProd+ <*> (Gen.map r ((,) <$> Gen.text r Gen.unicodeAll <*> genTestCoprod))+ )+ )+ )+ )+ ]++data TestProd = TestProd+ { fieldInt :: Int,+ fieldText :: Text,+ fieldBool :: Bool,+ fieldFloat :: Float+ }+ deriving (Eq, Ord, Show)+ deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestProd++instance HasCodec TestProd where+ codec =+ prod "TestProd" $+ TestProd+ <$> field "fieldInt" fieldInt codec+ <*> field "fieldText" fieldText codec+ <*> field "fieldBool" fieldBool codec+ <*> field "fieldFloat" fieldFloat codec++genTestProd :: Gen TestProd+genTestProd =+ TestProd+ <$> Gen.int Range.linearBounded+ <*> Gen.text (Range.linear 3 25) Gen.alphaNum+ <*> Gen.bool+ <*> Gen.float (Range.linearFracFrom 0 (-1e35) 1e35)++data TestCoprod+ = TestCoprodString {coprodString :: String}+ | TestCoprodDouble {coprodDouble :: Double}+ deriving (Eq, Ord, Show)+ deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestCoprod++instance HasCodec TestCoprod where+ codec =+ coprod @"type"+ "TestCoprod"+ ( \case+ TestCoprodString {} -> stringCase+ TestCoprodDouble {} -> doubleCase+ )+ [stringCase, doubleCase]+ where+ stringCase = Tagged "string" $ TestCoprodString <$> field "val" coprodString codec+ doubleCase = Tagged "double" $ TestCoprodDouble <$> field "val" coprodDouble codec++genTestCoprod :: Gen TestCoprod+genTestCoprod =+ Gen.frequency+ [ (1, TestCoprodString <$> Gen.string (Range.linear 3 15) Gen.alphaNum),+ (1, TestCoprodDouble <$> Gen.double (Range.linearFracFrom 0 (-1e305) 1e305))+ ]++data TestRecursive+ = TestRecursiveBranch {left :: TestRecursive, right :: TestRecursive}+ | TestRecursiveLeaf {val :: TestProd}+ deriving (Eq, Ord, Show)+ deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestRecursive++instance HasCodec TestRecursive where+ codec =+ coprod @"type"+ "TestRecursive"+ ( \case+ TestRecursiveBranch {} -> branch+ TestRecursiveLeaf {} -> leaf+ )+ [branch, leaf]+ where+ branch = Tagged "branch" $ TestRecursiveBranch <$> field "left" left codec <*> field "right" right codec+ leaf = Tagged "leaf" $ TestRecursiveLeaf <$> field "val" val codec++genTestRecursive :: Int -> Gen TestRecursive+genTestRecursive d+ | d <= 0 = TestRecursiveLeaf <$> genTestProd+ | otherwise =+ Gen.frequency+ [ (3, TestRecursiveBranch <$> genTestRecursive (d - 1) <*> genTestRecursive (d - 1)),+ (1, TestRecursiveLeaf <$> genTestProd)+ ]++data TestEnum = One | Two | Three+ deriving (Eq, Ord, Show)+ deriving (Aeson.ToJSON, Aeson.FromJSON, OpenApi.ToSchema) via ViaCodec TestEnum++instance HasCodec TestEnum where+ codec = enum "TestEnum" [(One, "one"), (Two, "two"), (Three, "three")]++genEnum :: Gen TestEnum+genEnum = Gen.element [One, Two, Three]