diff --git a/argo.cabal b/argo.cabal --- a/argo.cabal +++ b/argo.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: argo -version: 0.2022.1.15 +version: 0.2022.2.2 build-type: Simple category: JSON @@ -67,9 +67,7 @@ autogen-modules: Paths_argo exposed-modules: Argo - Argo.Class.FromValue Argo.Class.HasCodec - Argo.Class.ToValue Argo.Codec.Array Argo.Codec.Codec Argo.Codec.List @@ -92,6 +90,7 @@ Argo.Pointer.Pointer Argo.Pointer.Token Argo.QuasiQuoter + Argo.Schema.Identifier Argo.Schema.Schema Argo.Type.Config Argo.Type.Decimal @@ -134,6 +133,7 @@ import: executable build-depends: + , tasty >= 1.4.2 && < 1.5 , tasty-bench >= 0.2.5 && < 0.4 hs-source-dirs: source/benchmark main-is: Main.hs diff --git a/source/benchmark/Main.hs b/source/benchmark/Main.hs --- a/source/benchmark/Main.hs +++ b/source/benchmark/Main.hs @@ -1,232 +1,144 @@ -{-# LANGUAGE OverloadedStrings #-} - import qualified Argo +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import qualified Control.Monad.Trans.Writer as Writer import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.List as List import qualified Data.Text as Text -import qualified Test.Tasty.Bench as Tasty +import qualified Data.Text.Encoding as Encoding +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Bench as Bench main :: IO () -main = Tasty.defaultMain - [ Tasty.bgroup - "encode" - [ Tasty.bgroup "Null" [Tasty.bench "null" $ Tasty.nf encode Argo.Null] - , Tasty.bgroup - "Boolean" - [Tasty.bench "false" . Tasty.nf encode $ Argo.Boolean False] - , Tasty.bgroup - "Number" - [ Tasty.bench "zero" . Tasty.nf encode . Argo.Number $ Argo.Decimal - 0 - 0 - ] - , Tasty.bgroup - "String" - [ Tasty.bench "empty" . Tasty.nf encode $ Argo.String "" - , Tasty.bench "1 character" - . Tasty.nf encode - . Argo.String - . Text.pack - $ replicate 1 'a' - , Tasty.bench "10 characters" - . Tasty.nf encode - . Argo.String - . Text.pack - $ replicate 10 'a' - , Tasty.bench "100 characters" - . Tasty.nf encode - . Argo.String - . Text.pack - $ replicate 100 'a' - , Tasty.bench "1000 characters" - . Tasty.nf encode - . Argo.String - . Text.pack - $ replicate 1000 'a' - , Tasty.bench "10000 characters" - . Tasty.nf encode - . Argo.String - . Text.pack - $ replicate 10000 'a' - ] - , Tasty.bgroup - "Array" - [ Tasty.bench "empty" . Tasty.nf encode $ Argo.Array [] - , Tasty.bench "1 element" - . Tasty.nf encode - . Argo.Array - $ replicate 1 Argo.Null - , Tasty.bench "10 elements" - . Tasty.nf encode - . Argo.Array - $ replicate 10 Argo.Null - , Tasty.bench "100 elements" - . Tasty.nf encode - . Argo.Array - $ replicate 100 Argo.Null - , Tasty.bench "1000 elements" - . Tasty.nf encode - . Argo.Array - $ replicate 1000 Argo.Null - , Tasty.bench "10000 elements" - . Tasty.nf encode - . Argo.Array - $ replicate 10000 Argo.Null - ] - , Tasty.bgroup - "Object" - [ Tasty.bench "empty" . Tasty.nf encode $ Argo.Object [] - , Tasty.bench "1 element" - . Tasty.nf encode - . Argo.Object - . replicate 1 - $ Argo.Member (Argo.Name "") Argo.Null - , Tasty.bench "10 elements" - . Tasty.nf encode - . Argo.Object - . replicate 10 - $ Argo.Member (Argo.Name "") Argo.Null - , Tasty.bench "100 elements" - . Tasty.nf encode - . Argo.Object - . replicate 100 - $ Argo.Member (Argo.Name "") Argo.Null - , Tasty.bench "1000 elements" - . Tasty.nf encode - . Argo.Object - . replicate 1000 - $ Argo.Member (Argo.Name "") Argo.Null - , Tasty.bench "10000 elements" - . Tasty.nf encode - . Argo.Object - . replicate 10000 - $ Argo.Member (Argo.Name "") Argo.Null - ] - ] - , Tasty.bgroup - "decode" - [ Tasty.bgroup "Null" [Tasty.bench "null" $ Tasty.nf decode "null"] - , Tasty.bgroup - "Boolean" - [Tasty.bench "false" $ Tasty.nf decode "false"] - , Tasty.bgroup "Number" [Tasty.bench "zero" $ Tasty.nf decode "0"] - , Tasty.bgroup - "String" - [ Tasty.bench "empty" $ Tasty.nf decode "\"\"" - , Tasty.bench "one byte" $ Tasty.nf decode "\"$\"" - , Tasty.bench "two bytes" $ Tasty.nf decode "\"\xc2\xa2\"" - , Tasty.bench "three bytes" $ Tasty.nf decode "\"\xe2\x82\xac\"" - , Tasty.bench "four bytes" $ Tasty.nf decode "\"\xf0\x90\x8d\x88\"" - , Tasty.bench "short escape" $ Tasty.nf decode "\"\\n\"" - , Tasty.bench "long escape" $ Tasty.nf decode "\"\\u001f\"" - , Tasty.bench "surrogate pair" - $ Tasty.nf decode "\"\\ud834\\udd1e\"" - , Tasty.bench "1 character" - . Tasty.nf decode - $ "\"" - <> ByteString.replicate 1 0x61 - <> "\"" - , Tasty.bench "10 characters" - . Tasty.nf decode - $ "\"" - <> ByteString.replicate 10 0x61 - <> "\"" - , Tasty.bench "100 characters" - . Tasty.nf decode - $ "\"" - <> ByteString.replicate 100 0x61 - <> "\"" - , Tasty.bench "1000 characters" - . Tasty.nf decode - $ "\"" - <> ByteString.replicate 1000 0x61 - <> "\"" - , Tasty.bench "10000 characters" - . Tasty.nf decode - $ "\"" - <> ByteString.replicate 10000 0x61 - <> "\"" - ] - , Tasty.bgroup - "Array" - [ Tasty.bench "empty" $ Tasty.nf decode "[]" - , Tasty.bench "1 element" $ Tasty.nf decode "[null]" - , Tasty.bench "10 elements" - . Tasty.nf decode - $ "[null" - <> ByteString.pack - (take (5 * 9) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) - <> "]" - , Tasty.bench "100 elements" - . Tasty.nf decode - $ "[null" - <> ByteString.pack - (take (5 * 99) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) - <> "]" - , Tasty.bench "1000 elements" - . Tasty.nf decode - $ "[null" - <> ByteString.pack - (take (5 * 999) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) - <> "]" - , Tasty.bench "10000 elements" - . Tasty.nf decode - $ "[null" - <> ByteString.pack - (take (5 * 9999) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) - <> "]" - ] - , Tasty.bgroup - "Object" - [ Tasty.bench "empty" $ Tasty.nf decode "{}" - , Tasty.bench "1 element" $ Tasty.nf decode "{\"\":null}" - , Tasty.bench "10 elements" - . Tasty.nf decode - $ "{\"\":null" - <> ByteString.pack - (take (5 * 9) $ cycle - [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c] - ) - <> "}" - , Tasty.bench "100 elements" - . Tasty.nf decode - $ "{\"\":null" - <> ByteString.pack - (take (5 * 99) $ cycle - [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c] - ) - <> "}" - , Tasty.bench "1000 elements" - . Tasty.nf decode - $ "{\"\":null" - <> ByteString.pack - (take (5 * 999) $ cycle - [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c] - ) - <> "}" - , Tasty.bench "10000 elements" - . Tasty.nf decode - $ "{\"\":null" - <> ByteString.pack - (take (5 * 9999) $ cycle - [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c] - ) - <> "}" - ] - ] - , Tasty.bgroup - "Pointer" - [ Tasty.bench "decode" $ Tasty.nf Argo.decodePointer "" - , Tasty.bench "encode" - . Tasty.nf Builder.toLazyByteString - . Argo.encodePointer - $ Argo.Pointer [] - ] - ] +main = Bench.defaultMain . Writer.execWriter $ do -encode :: Argo.Value -> LazyByteString.ByteString -encode = Builder.toLazyByteString . Argo.encode + group "encode" $ do -decode :: ByteString.ByteString -> Either String Argo.Value -decode = Argo.decode + group "Null" $ do + bench "null" Argo.Null encode + + group "Boolean" $ do + bench "false" (Argo.Boolean False) encode + bench "true" (Argo.Boolean True) encode + + group "Number" $ do + bench "zero" (Argo.Number $ Argo.Decimal 0 0) encode + + group "String" $ do + let f n = Argo.String . Text.replicate n $ Text.singleton 'a' + bench "empty" (f 0) encode + bench "1 character" (f 1) encode + bench "10 characters" (f 10) encode + bench "100 characters" (f 100) encode + bench "1000 characters" (f 1000) encode + bench "10000 characters" (f 10000) encode + + group "Array" $ do + let f n = Argo.Array $ replicate n Argo.Null + bench "empty" (f 0) encode + bench "1 element" (f 1) encode + bench "10 elements" (f 10) encode + bench "100 elements" (f 100) encode + bench "1000 elements" (f 1000) encode + bench "10000 elements" (f 10000) encode + + group "Object" $ do + let + f n = Argo.Object . replicate n $ Argo.Member + (Argo.Name Text.empty) + Argo.Null + bench "empty" (f 0) encode + bench "1 element" (f 1) encode + bench "10 elements" (f 10) encode + bench "100 elements" (f 100) encode + bench "1000 elements" (f 1000) encode + bench "10000 elements" (f 10000) encode + + group "decode" $ do + + group "Null" $ do + bench "null" (utf8 "null") decode + + group "Boolean" $ do + bench "false" (utf8 "false") decode + bench "true" (utf8 "true") decode + + group "Number" $ do + bench "zero" (utf8 "0") decode + + group "String" $ do + let f n = utf8 . wrap "\"" "\"" $ replicate n 'a' + bench "empty" (f 0) decode + bench "one byte" (utf8 "\"$\"") decode + bench "two bytes" (utf8 "\"\xc2\xa2\"") decode + bench "three bytes" (utf8 "\"\xe2\x82\xac\"") decode + bench "four bytes" (utf8 "\"\xf0\x90\x8d\x88\"") decode + bench "short escape" (utf8 "\"\\n\"") decode + bench "long escape" (utf8 "\"\\u001f\"") decode + bench "surrogate pair" (utf8 "\"\\ud834\\udd1e\"") decode + bench "1 element" (f 1) decode + bench "10 elements" (f 10) decode + bench "100 elements" (f 100) decode + bench "1000 elements" (f 1000) decode + bench "10000 elements" (f 10000) decode + + group "Array" $ do + let + f n = utf8 . wrap "[" "]" . List.intercalate "," $ replicate + n + "null" + bench "empty" (f 0) decode + bench "1 element" (f 1) decode + bench "10 elements" (f 10) decode + bench "100 elements" (f 100) decode + bench "1000 elements" (f 1000) decode + bench "10000 elements" (f 10000) decode + + group "Object" $ do + let + f n = utf8 . wrap "{" "}" . List.intercalate "," $ replicate + n + "\"\":null" + bench "empty" (f 0) decode + bench "1 element" (f 1) decode + bench "10 elements" (f 10) decode + bench "100 elements" (f 100) decode + bench "1000 elements" (f 1000) decode + bench "10000 elements" (f 10000) decode + +bench + :: (DeepSeq.NFData a, DeepSeq.NFData b) + => String + -> a + -> (a -> IO b) + -> Writer.Writer [Bench.Benchmark] () +bench name x f = + Writer.tell + . pure + . Tasty.withResource (Exception.evaluate $ DeepSeq.force x) discard + $ Bench.bench name + . Bench.nfIO + . (>>= f) + +decode :: ByteString.ByteString -> IO Argo.Value +decode = either fail pure . Argo.decode + +discard :: Applicative f => a -> f () +discard = const $ pure () + +encode :: Argo.Value -> IO LazyByteString.ByteString +encode = pure . Builder.toLazyByteString . Argo.encode + +group + :: String + -> Writer.Writer [Bench.Benchmark] a + -> Writer.Writer [Bench.Benchmark] () +group x = Writer.tell . pure . Bench.bgroup x . Writer.execWriter + +utf8 :: String -> ByteString.ByteString +utf8 = Encoding.encodeUtf8 . Text.pack + +wrap :: Monoid a => a -> a -> a -> a +wrap l r x = l <> x <> r diff --git a/source/library/Argo.hs b/source/library/Argo.hs --- a/source/library/Argo.hs +++ b/source/library/Argo.hs @@ -13,8 +13,6 @@ , Encode.encodeWith , Indent.Indent(Spaces, Tab) , Decode.decode - , FromValue.fromValue - , ToValue.toValue , HasCodec.HasCodec(codec) , QuasiQuoter.value , QuasiQuoter.pointer @@ -28,9 +26,7 @@ , Schema.Schema ) where -import qualified Argo.Class.FromValue as FromValue import qualified Argo.Class.HasCodec as HasCodec -import qualified Argo.Class.ToValue as ToValue import qualified Argo.Decode as Decode import qualified Argo.Encode as Encode import qualified Argo.Json.Member as Member diff --git a/source/library/Argo/Class/FromValue.hs b/source/library/Argo/Class/FromValue.hs deleted file mode 100644 --- a/source/library/Argo/Class/FromValue.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Argo.Class.FromValue where - -import qualified Argo.Class.HasCodec as HasCodec -import qualified Argo.Codec.Value as Codec -import qualified Argo.Json.Value as Value - -fromValue :: HasCodec.HasCodec a => Value.Value -> Either String a -fromValue = Codec.decodeWith HasCodec.codec diff --git a/source/library/Argo/Class/HasCodec.hs b/source/library/Argo/Class/HasCodec.hs --- a/source/library/Argo/Class/HasCodec.hs +++ b/source/library/Argo/Class/HasCodec.hs @@ -34,577 +34,956 @@ import qualified Data.Functor.Identity as Identity import qualified Data.Int as Int import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Word as Word -import qualified Numeric.Natural as Natural - -class HasCodec a where - codec :: Codec.Value a - -instance HasCodec Value.Value where - codec = Codec.Codec - { Codec.decode = Trans.ask - , Codec.encode = Codec.tap $ Trans.lift . Trans.put - , Codec.schema = Schema.true - } - -instance HasCodec Null.Null where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "null" - ) - ] - in - basicCodec "Null" schema Value.Null $ \value -> case value of - Value.Null null_ -> Just null_ - _ -> Nothing - -instance HasCodec Boolean.Boolean where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "boolean" - ) - ] - in - basicCodec "Boolean" schema Value.Boolean $ \value -> case value of - Value.Boolean boolean -> Just boolean - _ -> Nothing - -instance HasCodec Number.Number where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "number" - ) - ] - in - basicCodec "Number" schema Value.Number $ \value -> case value of - Value.Number number -> Just number - _ -> Nothing - -instance HasCodec String.String where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "string" - ) - ] - in - basicCodec "String" schema Value.String $ \value -> case value of - Value.String string -> Just string - _ -> Nothing - -instance HasCodec a => HasCodec (Array.Array a) where - codec = Codec.Codec - { Codec.decode = do - array <- castValue "Array" $ \value -> case value of - Value.Array array -> Just array - _ -> Nothing - either (Trans.lift . Trans.throwE) (pure . Array.fromList) - . traverse (Codec.decodeWith codec) - $ Array.toList array - , Codec.encode = - Codec.tap - $ Trans.lift - . Trans.put - . Value.Array - . Array.fromList - . fmap (Codec.encodeWith codec) - . Array.toList - , Codec.schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "array" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "items" - , Schema.toValue $ Codec.schema (codec :: Codec.Value a) - ) - ] - } - -instance HasCodec a => HasCodec (Object.Object a) where - codec = Codec.Codec - { Codec.decode = do - object <- castValue "Object" $ \value -> case value of - Value.Object object -> Just object - _ -> Nothing - either (Trans.lift . Trans.throwE) (pure . Object.fromList) - . traverse - (\(Member.Member k v) -> - Member.Member k <$> Codec.decodeWith codec v - ) - $ Object.toList object - , Codec.encode = - Codec.tap - $ Trans.lift - . Trans.put - . Value.Object - . Object.fromList - . fmap - (\(Member.Member k v) -> - Member.Member k $ Codec.encodeWith codec v - ) - . Object.toList - , Codec.schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "object" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "additionalProperties" - , Schema.toValue $ Codec.schema (codec :: Codec.Value a) - ) - ] - } - -instance HasCodec a => HasCodec (Maybe a) where - codec = - Codec.mapMaybe (Just . Just) id codec - <|> Codec.map (const Nothing) (const $ Null.fromUnit ()) codec - -instance (HasCodec a, HasCodec b) => HasCodec (Either a b) where - codec = - Codec.mapMaybe - (Just . Left) - (either Just $ const Nothing) - (Codec.tagged "Left" codec) - <|> Codec.mapMaybe - (Just . Right) - (either (const Nothing) Just) - (Codec.tagged "Right" codec) - -instance HasCodec () where - codec = Codec.fromArrayCodec Permission.Forbid $ pure () - -instance (HasCodec a, HasCodec b) => HasCodec (a, b) where - codec = - Codec.fromArrayCodec Permission.Forbid - $ (,) - <$> Codec.project fst (Codec.element codec) - <*> Codec.project snd (Codec.element codec) - -instance HasCodec Bool where - codec = Codec.map Boolean.toBool Boolean.fromBool codec - -instance HasCodec Decimal.Decimal where - codec = Codec.map Number.toDecimal Number.fromDecimal codec - -instance HasCodec Text.Text where - codec = Codec.map String.toText String.fromText codec - -instance {-# OVERLAPPABLE #-} HasCodec a => HasCodec [a] where - codec = Codec.map Array.toList Array.fromList codec - -instance HasCodec a => HasCodec (Map.Map Name.Name a) where - codec = Codec.map - (Map.fromList . fmap Member.toTuple . Object.toList) - (Object.fromList . fmap Member.fromTuple . Map.toList) - codec - -instance HasCodec String where - codec = Codec.map Text.unpack Text.pack codec - -instance HasCodec Char where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "string" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minLength" - , Value.Number . Number.fromDecimal $ Decimal.fromInteger 1 - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maxLength" - , Value.Number . Number.fromDecimal $ Decimal.fromInteger 1 - ) - ] - in - Codec.mapMaybe - (\x -> case Text.uncons x of - Just (y, z) | Text.null z -> Just y - _ -> Nothing - ) - (Just . Text.singleton) - codec { Codec.schema = schema } - -instance HasCodec Text.LazyText where - codec = Codec.map Text.fromStrict Text.toStrict codec - -instance HasCodec a => HasCodec (NonEmpty.NonEmpty a) where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "array" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "items" - , Schema.toValue $ Codec.schema (codec :: Codec.Value a) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minItems" - , Value.Number . Number.fromDecimal $ Decimal.fromInteger 1 - ) - ] - in - Codec.mapMaybe - NonEmpty.nonEmpty - (Just . NonEmpty.toList) - codec { Codec.schema = schema } - -instance HasCodec Integer where - codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - ] - in - Codec.mapMaybe - Decimal.toInteger - (Just . Decimal.fromInteger) - codec { Codec.schema = schema } - -instance HasCodec Int where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int - into = fromIntegral :: Int -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Int.Int8 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int8 - into = fromIntegral :: Int.Int8 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int8) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int8) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Int.Int16 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int16 - into = fromIntegral :: Int.Int16 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int16) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int16) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Int.Int32 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int32 - into = fromIntegral :: Int.Int32 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int32) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int32) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Int.Int64 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int64 - into = fromIntegral :: Int.Int64 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int64) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int64) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Natural.Natural where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Natural.Natural - into = fromIntegral :: Natural.Natural -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number . Number.fromDecimal $ Decimal.fromInteger 0 - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Word where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word - into = fromIntegral :: Word -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Word.Word8 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word8 - into = fromIntegral :: Word.Word8 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word8) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word8) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Word.Word16 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word16 - into = fromIntegral :: Word.Word16 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word16) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word16) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Word.Word32 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word32 - into = fromIntegral :: Word.Word32 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word32) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word32) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Word.Word64 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word64 - into = fromIntegral :: Word.Word64 -> Integer - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word64) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word64) - ) - ] - in Codec.mapMaybe from (Just . into) codec { Codec.schema = schema } - -instance HasCodec Float where - codec = - Codec.mapMaybe (Just . Decimal.toRealFloat) Decimal.fromRealFloat codec - -instance HasCodec Double where - codec = - Codec.mapMaybe (Just . Decimal.toRealFloat) Decimal.fromRealFloat codec - -instance HasCodec Pointer.Pointer where - codec = Codec.mapMaybe - (either (const Nothing) Just - . Decoder.run Pointer.decode - . Text.encodeUtf8 - ) - (either (const Nothing) Just - . Text.decodeUtf8' - . ByteString.toStrict - . Builder.toLazyByteString - . Encoder.run Config.initial - . Pointer.encode - ) - codec - -instance HasCodec Schema.Schema where - codec = Codec.map Schema.fromValue Schema.toValue codec - -basicCodec - :: String - -> Schema.Schema - -> (a -> Value.Value) - -> (Value.Value -> Maybe a) - -> Codec.Value a -basicCodec expected schema toValue fromValue = Codec.Codec - { Codec.decode = castValue expected fromValue - , Codec.encode = Codec.tap $ Trans.lift . Trans.put . toValue - , Codec.schema = schema +import qualified Data.Typeable as Typeable +import qualified Data.Word as Word +import qualified Numeric.Natural as Natural + +class HasCodec a where + codec :: Codec.Value a + +instance HasCodec Value.Value where + codec = basicCodec Schema.true id Just + +instance HasCodec Null.Null where + codec = + let + schema = Schema.fromValue . Value.Object $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack "type" + , Value.String . String.fromText $ Text.pack "null" + ) + ] + in + basicCodec schema Value.Null $ \value -> case value of + Value.Null null_ -> Just null_ + _ -> Nothing + +instance HasCodec Boolean.Boolean where + codec = + let + schema = Schema.fromValue . Value.Object $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack "type" + , Value.String . String.fromText $ Text.pack "boolean" + ) + ] + in + basicCodec schema Value.Boolean $ \value -> case value of + Value.Boolean boolean -> Just boolean + _ -> Nothing + +instance HasCodec Number.Number where + codec = + let + schema = Schema.fromValue . Value.Object $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack "type" + , Value.String . String.fromText $ Text.pack "number" + ) + ] + in + basicCodec schema Value.Number $ \value -> case value of + Value.Number number -> Just number + _ -> Nothing + +instance HasCodec String.String where + codec = + let + schema = Schema.fromValue . Value.Object $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack "type" + , Value.String . String.fromText $ Text.pack "string" + ) + ] + in + basicCodec schema Value.String $ \value -> case value of + Value.String string -> Just string + _ -> Nothing + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Array.Array a) where + codec = Codec.identified Codec.Codec + { Codec.decode = do + array <- castValue "Array" $ \value -> case value of + Value.Array array -> Just array + _ -> Nothing + either (Trans.lift . Trans.throwE) (pure . Array.fromList) + . traverse (Codec.decodeWith codec) + $ Array.toList array + , Codec.encode = + Codec.tap + $ Trans.lift + . Trans.put + . Value.Array + . Array.fromList + . fmap (Codec.encodeWith codec) + . Array.toList + , Codec.schema = do + ref <- Codec.getRef (codec :: Codec.Value a) + pure + . Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack "array" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "items" + , Codec.ref ref + ) + ] + } + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Object.Object a) where + codec = Codec.identified Codec.Codec + { Codec.decode = do + object <- castValue "Object" $ \value -> case value of + Value.Object object -> Just object + _ -> Nothing + either (Trans.lift . Trans.throwE) (pure . Object.fromList) + . traverse + (\(Member.Member k v) -> + Member.Member k <$> Codec.decodeWith codec v + ) + $ Object.toList object + , Codec.encode = + Codec.tap + $ Trans.lift + . Trans.put + . Value.Object + . Object.fromList + . fmap + (\(Member.Member k v) -> + Member.Member k $ Codec.encodeWith codec v + ) + . Object.toList + , Codec.schema = do + ref <- Codec.getRef (codec :: Codec.Value a) + pure + . Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack "object" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "additionalProperties" + , Codec.ref ref + ) + ] + } + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Maybe a) where + codec = + Codec.identified + $ Codec.mapMaybe (Just . Just) id codec + <|> Codec.map (const Nothing) (const $ Null.fromUnit ()) codec + +instance + ( HasCodec a + , HasCodec b + , Typeable.Typeable a + , Typeable.Typeable b + ) => HasCodec (Either a b) where + codec = + Codec.identified + $ Codec.mapMaybe + (Just . Left) + (either Just $ const Nothing) + (Codec.tagged "Left" codec) + <|> Codec.mapMaybe + (Just . Right) + (either (const Nothing) Just) + (Codec.tagged "Right" codec) + +instance HasCodec () where + codec = + Codec.identified . Codec.fromArrayCodec Permission.Forbid $ pure () + +instance + ( HasCodec a + , HasCodec b + , Typeable.Typeable a + , Typeable.Typeable b + ) => HasCodec (a, b) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,) + <$> Codec.project fst (Codec.element codec) + <*> Codec.project snd (Codec.element codec) + +instance + ( HasCodec a + , HasCodec b + , HasCodec c + , Typeable.Typeable a + , Typeable.Typeable b + , Typeable.Typeable c + ) => HasCodec (a, b, c) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,,) + <$> Codec.project (\(a, _, _) -> a) (Codec.element codec) + <*> Codec.project (\(_, b, _) -> b) (Codec.element codec) + <*> Codec.project (\(_, _, c) -> c) (Codec.element codec) + +instance + ( HasCodec a + , HasCodec b + , HasCodec c + , HasCodec d + , Typeable.Typeable a + , Typeable.Typeable b + , Typeable.Typeable c + , Typeable.Typeable d + ) => HasCodec (a, b, c, d) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,,,) + <$> Codec.project (\(a, _, _, _) -> a) (Codec.element codec) + <*> Codec.project (\(_, b, _, _) -> b) (Codec.element codec) + <*> Codec.project (\(_, _, c, _) -> c) (Codec.element codec) + <*> Codec.project (\(_, _, _, d) -> d) (Codec.element codec) + +instance + ( HasCodec a + , HasCodec b + , HasCodec c + , HasCodec d + , HasCodec e + , Typeable.Typeable a + , Typeable.Typeable b + , Typeable.Typeable c + , Typeable.Typeable d + , Typeable.Typeable e + ) => HasCodec (a, b, c, d, e) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,,,,) + <$> Codec.project (\(a, _, _, _, _) -> a) (Codec.element codec) + <*> Codec.project (\(_, b, _, _, _) -> b) (Codec.element codec) + <*> Codec.project (\(_, _, c, _, _) -> c) (Codec.element codec) + <*> Codec.project (\(_, _, _, d, _) -> d) (Codec.element codec) + <*> Codec.project (\(_, _, _, _, e) -> e) (Codec.element codec) + +instance + ( HasCodec a + , HasCodec b + , HasCodec c + , HasCodec d + , HasCodec e + , HasCodec f + , Typeable.Typeable a + , Typeable.Typeable b + , Typeable.Typeable c + , Typeable.Typeable d + , Typeable.Typeable e + , Typeable.Typeable f + ) => HasCodec (a, b, c, d, e, f) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,,,,,) + <$> Codec.project (\(a, _, _, _, _, _) -> a) (Codec.element codec) + <*> Codec.project (\(_, b, _, _, _, _) -> b) (Codec.element codec) + <*> Codec.project (\(_, _, c, _, _, _) -> c) (Codec.element codec) + <*> Codec.project (\(_, _, _, d, _, _) -> d) (Codec.element codec) + <*> Codec.project (\(_, _, _, _, e, _) -> e) (Codec.element codec) + <*> Codec.project (\(_, _, _, _, _, f) -> f) (Codec.element codec) + +instance + ( HasCodec a + , HasCodec b + , HasCodec c + , HasCodec d + , HasCodec e + , HasCodec f + , HasCodec g + , Typeable.Typeable a + , Typeable.Typeable b + , Typeable.Typeable c + , Typeable.Typeable d + , Typeable.Typeable e + , Typeable.Typeable f + , Typeable.Typeable g + ) => HasCodec (a, b, c, d, e, f, g) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,,,,,,) + <$> Codec.project + (\(a, _, _, _, _, _, _) -> a) + (Codec.element codec) + <*> Codec.project + (\(_, b, _, _, _, _, _) -> b) + (Codec.element codec) + <*> Codec.project + (\(_, _, c, _, _, _, _) -> c) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, d, _, _, _) -> d) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, e, _, _) -> e) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, _, f, _) -> f) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, _, _, g) -> g) + (Codec.element codec) + +instance + ( HasCodec a + , HasCodec b + , HasCodec c + , HasCodec d + , HasCodec e + , HasCodec f + , HasCodec g + , HasCodec h + , Typeable.Typeable a + , Typeable.Typeable b + , Typeable.Typeable c + , Typeable.Typeable d + , Typeable.Typeable e + , Typeable.Typeable f + , Typeable.Typeable g + , Typeable.Typeable h + ) => HasCodec (a, b, c, d, e, f, g, h) where + codec = + Codec.identified + . Codec.fromArrayCodec Permission.Forbid + $ (,,,,,,,) + <$> Codec.project + (\(a, _, _, _, _, _, _, _) -> a) + (Codec.element codec) + <*> Codec.project + (\(_, b, _, _, _, _, _, _) -> b) + (Codec.element codec) + <*> Codec.project + (\(_, _, c, _, _, _, _, _) -> c) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, d, _, _, _, _) -> d) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, e, _, _, _) -> e) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, _, f, _, _) -> f) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, _, _, g, _) -> g) + (Codec.element codec) + <*> Codec.project + (\(_, _, _, _, _, _, _, h) -> h) + (Codec.element codec) + +instance HasCodec Bool where + codec = Codec.identified $ Codec.map Boolean.toBool Boolean.fromBool codec + +instance HasCodec Decimal.Decimal where + codec = + Codec.identified $ Codec.map Number.toDecimal Number.fromDecimal codec + +instance HasCodec Text.Text where + codec = Codec.identified $ Codec.map String.toText String.fromText codec + +instance {-# OVERLAPPABLE #-} (HasCodec a, Typeable.Typeable a) => HasCodec [a] where + codec = Codec.identified $ Codec.map Array.toList Array.fromList codec + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map Name.Name a) where + codec = Codec.identified $ Codec.map + (Map.fromList . fmap Member.toTuple . Object.toList) + (Object.fromList . fmap Member.fromTuple . Map.toList) + codec + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map String.String a) where + codec = Codec.identified $ Codec.map + (Map.mapKeys Name.toString) + (Map.mapKeys Name.fromString) + codec + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map Text.Text a) where + codec = Codec.identified $ Codec.map + (Map.mapKeys String.toText) + (Map.mapKeys String.fromText) + codec + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map Text.LazyText a) where + codec = Codec.identified $ Codec.map + (Map.mapKeys Text.fromStrict) + (Map.mapKeys Text.toStrict) + codec + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map String a) where + codec = Codec.identified + $ Codec.map (Map.mapKeys Text.unpack) (Map.mapKeys Text.pack) codec + +instance HasCodec String where + codec = Codec.identified $ Codec.map Text.unpack Text.pack codec + +instance HasCodec Char where + codec = + let + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "string" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minLength" + , Value.Number + . Number.fromDecimal + $ Decimal.fromInteger 1 + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maxLength" + , Value.Number + . Number.fromDecimal + $ Decimal.fromInteger 1 + ) + ] + in + Codec.identified $ Codec.mapMaybe + (\x -> case Text.uncons x of + Just (y, z) | Text.null z -> Just y + _ -> Nothing + ) + (Just . Text.singleton) + codec { Codec.schema = pure schema } + +instance HasCodec Text.LazyText where + codec = Codec.identified $ Codec.map Text.fromStrict Text.toStrict codec + +instance (HasCodec a, Typeable.Typeable a) => HasCodec (NonEmpty.NonEmpty a) where + codec = + let + schema = do + (_, itemSchema) <- Codec.schema (codec :: Codec.Value a) + pure + . Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "array" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "items" + , Schema.toValue itemSchema + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minItems" + , Value.Number + . Number.fromDecimal + $ Decimal.fromInteger 1 + ) + ] + in + Codec.identified $ Codec.mapMaybe + NonEmpty.nonEmpty + (Just . NonEmpty.toList) + codec { Codec.schema = schema } + +instance HasCodec Integer where + codec = + let + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + ] + in + Codec.identified $ Codec.mapMaybe + Decimal.toInteger + (Just . Decimal.fromInteger) + codec { Codec.schema = pure schema } + +instance HasCodec Int where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Int + into = fromIntegral :: Int -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Int) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Int) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Int.Int8 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Int.Int8 + into = fromIntegral :: Int.Int8 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Int.Int8) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Int.Int8) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Int.Int16 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Int.Int16 + into = fromIntegral :: Int.Int16 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Int.Int16) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Int.Int16) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Int.Int32 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Int.Int32 + into = fromIntegral :: Int.Int32 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Int.Int32) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Int.Int32) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Int.Int64 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Int.Int64 + into = fromIntegral :: Int.Int64 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Int.Int64) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Int.Int64) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Natural.Natural where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Natural.Natural + into = fromIntegral :: Natural.Natural -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + $ Decimal.fromInteger 0 + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Word where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Word + into = fromIntegral :: Word -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Word) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Word) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Word.Word8 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Word.Word8 + into = fromIntegral :: Word.Word8 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Word.Word8) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Word.Word8) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Word.Word16 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Word.Word16 + into = fromIntegral :: Word.Word16 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Word.Word16) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Word.Word16) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Word.Word32 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Word.Word32 + into = fromIntegral :: Word.Word32 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Word.Word32) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Word.Word32) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Word.Word64 where + codec = + let + from = Bits.toIntegralSized :: Integer -> Maybe Word.Word64 + into = fromIntegral :: Word.Word64 -> Integer + schema = + Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "integer" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "minimum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (minBound :: Word.Word64) + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "maximum" + , Value.Number + . Number.fromDecimal + . Decimal.fromInteger + $ toInteger (maxBound :: Word.Word64) + ) + ] + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +instance HasCodec Float where + codec = Codec.identified $ Codec.mapMaybe + (Just . Decimal.toRealFloat) + Decimal.fromRealFloat + codec + +instance HasCodec Double where + codec = Codec.identified $ Codec.mapMaybe + (Just . Decimal.toRealFloat) + Decimal.fromRealFloat + codec + +instance HasCodec Pointer.Pointer where + codec = Codec.identified $ Codec.mapMaybe + (either (const Nothing) Just + . Decoder.run Pointer.decode + . Text.encodeUtf8 + ) + (either (const Nothing) Just + . Text.decodeUtf8' + . ByteString.toStrict + . Builder.toLazyByteString + . Encoder.run Config.initial + . Pointer.encode + ) + codec + +instance HasCodec Schema.Schema where + codec = Codec.identified $ Codec.map Schema.fromValue Schema.toValue codec + +basicCodec + :: forall a + . Typeable.Typeable a + => Schema.Schema + -> (a -> Value.Value) + -> (Value.Value -> Maybe a) + -> Codec.Value a +basicCodec schema toValue fromValue = Codec.identified Codec.Codec + { Codec.decode = castValue + (show $ Typeable.typeRep (Typeable.Proxy :: Typeable.Proxy a)) + fromValue + , Codec.encode = Codec.tap $ Trans.lift . Trans.put . toValue + , Codec.schema = pure $ Schema.unidentified schema } castValue diff --git a/source/library/Argo/Class/ToValue.hs b/source/library/Argo/Class/ToValue.hs deleted file mode 100644 --- a/source/library/Argo/Class/ToValue.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Argo.Class.ToValue where - -import qualified Argo.Class.HasCodec as HasCodec -import qualified Argo.Codec.Value as Codec -import qualified Argo.Json.Value as Value - -toValue :: HasCodec.HasCodec a => a -> Value.Value -toValue = Codec.encodeWith HasCodec.codec diff --git a/source/library/Argo/Codec/Array.hs b/source/library/Argo/Codec/Array.hs --- a/source/library/Argo/Codec/Array.hs +++ b/source/library/Argo/Codec/Array.hs @@ -10,36 +10,57 @@ import qualified Argo.Json.Object as Object import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Permission as Permission +import qualified Argo.Vendor.Map as Map import qualified Argo.Vendor.Text as Text import qualified Argo.Vendor.Transformers as Trans +import qualified Data.Functor.Identity as Identity -type Array a = Codec.List [Schema.Schema] Value.Value a +type Array a + = Codec.List + ( Trans.AccumT + (Map.Map Identifier.Identifier Schema.Schema) + Identity.Identity + [(Maybe Identifier.Identifier, Schema.Schema)] + ) + Value.Value + a fromArrayCodec :: Permission.Permission -> Array a -> Codec.Value a fromArrayCodec = Codec.fromListCodec - (\permission schemas -> - Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "array" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "items" - , Value.Array . Array.fromList $ fmap - Schema.toValue - schemas - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "additionalItems" - , Value.Boolean . Boolean.fromBool $ case permission of - Permission.Allow -> True - Permission.Forbid -> False - ) - ] + (\permission schemasM -> do + schemas <- schemasM + pure + . Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "array" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "items" + , Value.Array . Array.fromList $ fmap + (Schema.toValue . snd) + schemas + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "additionalItems" + , Value.Boolean + . Boolean.fromBool + $ case permission of + Permission.Allow -> True + Permission.Forbid -> False + ) + ] ) $ Codec.map Array.toList Array.fromList Codec.arrayCodec @@ -57,5 +78,10 @@ , Codec.encode = \x -> do Trans.tell [Codec.encodeWith c x] pure x - , Codec.schema = [Codec.schema c] + , Codec.schema = + pure + . Schema.unidentified + . Schema.fromValue + . Codec.ref + <$> Codec.getRef c } diff --git a/source/library/Argo/Codec/Codec.hs b/source/library/Argo/Codec/Codec.hs --- a/source/library/Argo/Codec/Codec.hs +++ b/source/library/Argo/Codec/Codec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + module Argo.Codec.Codec where import Control.Applicative ((<|>)) @@ -17,29 +19,38 @@ , schema = schema c } -instance (Applicative r, Applicative w, Monoid s) => Applicative (Codec r w s i) where - pure x = - Codec { decode = pure x, encode = const $ pure x, schema = mempty } +instance + ( Applicative r + , Applicative w + , Applicative s + , Monoid a + ) => Applicative (Codec r w (s a) i) where + pure x = Codec + { decode = pure x + , encode = const $ pure x + , schema = pure mempty + } cf <*> cx = Codec { decode = decode cf <*> decode cx , encode = \i -> encode cf i <*> encode cx i - , schema = schema cf <> schema cx + , schema = (<>) <$> schema cf <*> schema cx } instance ( Applicative.Alternative r , Applicative.Alternative w - , Monoid s - ) => Applicative.Alternative (Codec r w s i) where + , Applicative s + , Monoid a + ) => Applicative.Alternative (Codec r w (s a) i) where empty = Codec { decode = Applicative.empty , encode = const Applicative.empty - , schema = mempty + , schema = pure mempty } cx <|> cy = Codec { decode = decode cx <|> decode cy , encode = \i -> encode cx i <|> encode cy i - , schema = schema cx <> schema cy + , schema = (<>) <$> schema cx <*> schema cy } map diff --git a/source/library/Argo/Codec/List.hs b/source/library/Argo/Codec/List.hs --- a/source/library/Argo/Codec/List.hs +++ b/source/library/Argo/Codec/List.hs @@ -2,8 +2,10 @@ import qualified Argo.Codec.Codec as Codec import qualified Argo.Codec.Value as Codec +import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Permission as Permission +import qualified Argo.Vendor.Map as Map import qualified Argo.Vendor.Transformers as Trans import qualified Control.Monad as Monad import qualified Data.Functor.Identity as Identity @@ -17,7 +19,13 @@ a fromListCodec - :: (Permission.Permission -> s -> Schema.Schema) + :: ( Permission.Permission + -> s + -> Trans.AccumT + (Map.Map Identifier.Identifier Schema.Schema) + Identity.Identity + (Maybe Identifier.Identifier, Schema.Schema) + ) -> Codec.Value [e] -> Permission.Permission -> List s e a diff --git a/source/library/Argo/Codec/Object.hs b/source/library/Argo/Codec/Object.hs --- a/source/library/Argo/Codec/Object.hs +++ b/source/library/Argo/Codec/Object.hs @@ -7,59 +7,80 @@ import qualified Argo.Json.Boolean as Boolean import qualified Argo.Json.Member as Member import qualified Argo.Json.Name as Name +import qualified Argo.Json.Null as Null import qualified Argo.Json.Object as Object import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Permission as Permission +import qualified Argo.Vendor.Map as Map import qualified Argo.Vendor.Text as Text import qualified Argo.Vendor.Transformers as Trans import qualified Control.Monad as Monad +import qualified Data.Functor.Identity as Identity import qualified Data.List as List import qualified Data.Maybe as Maybe type Object a = Codec.List - [(Name.Name, Bool, Schema.Schema)] + ( Trans.AccumT + (Map.Map Identifier.Identifier Schema.Schema) + Identity.Identity + [ ( (Name.Name, Bool) + , (Maybe Identifier.Identifier, Schema.Schema) + ) + ] + ) (Member.Member Value.Value) a fromObjectCodec :: Permission.Permission -> Object a -> Codec.Value a fromObjectCodec = Codec.fromListCodec - (\permission schemas -> - Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "object" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "properties" - , Value.Object . Object.fromList $ fmap - (\(k, _, s) -> - Member.fromTuple (k, Schema.toValue s) - ) - schemas - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "required" - , Value.Array . Array.fromList $ Maybe.mapMaybe - (\(k, r, _) -> if r - then Just . Value.String $ Name.toString k - else Nothing - ) - schemas - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "additionalProperties" - , Value.Boolean . Boolean.fromBool $ case permission of - Permission.Allow -> True - Permission.Forbid -> False - ) - ] + (\permission schemasM -> do + schemas <- schemasM + pure + . Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "type" + , Value.String . String.fromText $ Text.pack + "object" + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "properties" + , Value.Object . Object.fromList $ fmap + (\((k, _), (_, s)) -> + Member.fromTuple (k, Schema.toValue s) + ) + schemas + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "required" + , Value.Array . Array.fromList $ Maybe.mapMaybe + (\((k, r), _) -> if r + then Just . Value.String $ Name.toString + k + else Nothing + ) + schemas + ) + , Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack + "additionalProperties" + , Value.Boolean + . Boolean.fromBool + $ case permission of + Permission.Allow -> True + Permission.Forbid -> False + ) + ] ) $ Codec.map Object.toList Object.fromList Codec.objectCodec @@ -77,7 +98,13 @@ , Codec.encode = \x -> do Monad.void . Codec.encode (optional k c) $ Just x pure x - , Codec.schema = [(k, True, Codec.schema c)] + , Codec.schema = + pure + . (,) (k, True) + . Schema.unidentified + . Schema.fromValue + . Codec.ref + <$> Codec.getRef c } optional :: Name.Name -> Codec.Value a -> Object (Maybe a) @@ -86,7 +113,9 @@ xs <- Trans.get case List.partition (\(Member.Member j _) -> j == k) xs of (Member.Member _ x : _, ys) -> case Codec.decodeWith c x of - Left y -> Trans.lift $ Trans.throwE y + Left y -> if x == Value.Null (Null.fromUnit ()) + then pure Nothing + else Trans.lift $ Trans.throwE y Right y -> do Trans.put ys pure $ Just y @@ -96,7 +125,13 @@ Nothing -> pure () Just y -> Trans.tell [Member.Member k $ Codec.encodeWith c y] pure x - , Codec.schema = [(k, False, Codec.schema c)] + , Codec.schema = + pure + . (,) (k, False) + . Schema.unidentified + . Schema.fromValue + . Codec.ref + <$> Codec.getRef c } tagged :: String -> Codec.Value a -> Codec.Value a diff --git a/source/library/Argo/Codec/Value.hs b/source/library/Argo/Codec/Value.hs --- a/source/library/Argo/Codec/Value.hs +++ b/source/library/Argo/Codec/Value.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Argo.Codec.Value where import qualified Argo.Codec.Codec as Codec @@ -8,11 +10,14 @@ import qualified Argo.Json.Object as Object import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema +import qualified Argo.Vendor.Map as Map import qualified Argo.Vendor.Text as Text import qualified Argo.Vendor.Transformers as Trans import qualified Control.Monad as Monad import qualified Data.Functor.Identity as Identity +import qualified Data.Typeable as Typeable decodeWith :: Value a -> Value.Value -> Either String a decodeWith c = @@ -30,7 +35,11 @@ = Codec.Codec (Trans.ReaderT Value.Value (Trans.ExceptT String Identity.Identity)) (Trans.MaybeT (Trans.StateT Value.Value Identity.Identity)) - Schema.Schema + ( Trans.AccumT + (Map.Map Identifier.Identifier Schema.Schema) + Identity.Identity + (Maybe Identifier.Identifier, Schema.Schema) + ) a a @@ -45,7 +54,7 @@ , Codec.encode = \x -> do Trans.lift . Trans.put $ Value.Array x pure x - , Codec.schema = Schema.false + , Codec.schema = pure $ Schema.unidentified Schema.false } objectCodec :: Value (Object.Object Value.Value) @@ -62,7 +71,7 @@ , Codec.encode = \x -> do Trans.lift . Trans.put $ Value.Object x pure x - , Codec.schema = Schema.false + , Codec.schema = pure $ Schema.unidentified Schema.false } literalCodec :: Value.Value -> Value () @@ -77,8 +86,56 @@ <> " but got " <> show actual , Codec.encode = const . Trans.lift $ Trans.put expected - , Codec.schema = Schema.fromValue . Value.Object $ Object.fromList + , Codec.schema = + pure + . Schema.unidentified + . Schema.fromValue + . Value.Object + $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack "const" + , expected + ) + ] + } + +identified :: forall a . Typeable.Typeable a => Value a -> Value a +identified c = + let + i = Identifier.fromText . Text.pack . show $ Typeable.typeRep + (Typeable.Proxy :: Typeable.Proxy a) + in c { Codec.schema = Schema.identified i . snd <$> Codec.schema c } + +getRef + :: Value a + -> Trans.AccumT + (Map.Map Identifier.Identifier Schema.Schema) + Identity.Identity + (Either Schema.Schema Identifier.Identifier) +getRef codec = do + let + (maybeIdentifier, schema) = + fst . Identity.runIdentity $ Trans.runAccumT + (Codec.schema codec) + Map.empty + case maybeIdentifier of + Nothing -> pure $ Left schema + Just identifier -> do + schemas <- Trans.look + Monad.unless (Map.member identifier schemas) $ do + Trans.add $ Map.singleton identifier schema + Monad.void $ Codec.schema codec + pure $ Right identifier + +ref :: Either Schema.Schema Identifier.Identifier -> Value.Value +ref e = case e of + Left s -> Schema.toValue s + Right i -> Value.Object $ Object.fromList [ Member.fromTuple - (Name.fromString . String.fromText $ Text.pack "const", expected) + ( Name.fromString . String.fromText $ Text.pack "$ref" + , Value.String + . String.fromText + . mappend (Text.pack "#/definitions/") + $ Identifier.toText i + ) ] - } diff --git a/source/library/Argo/Decode.hs b/source/library/Argo/Decode.hs --- a/source/library/Argo/Decode.hs +++ b/source/library/Argo/Decode.hs @@ -1,7 +1,7 @@ module Argo.Decode where -import qualified Argo.Class.FromValue as FromValue import qualified Argo.Class.HasCodec as HasCodec +import qualified Argo.Codec.Value as Codec import qualified Argo.Json.Value as Value import qualified Argo.Pointer.Pointer as Pointer import qualified Argo.Type.Decoder as Decoder @@ -10,7 +10,7 @@ decode :: HasCodec.HasCodec a => ByteString.ByteString -> Either String a decode x = do y <- Decoder.run (Decoder.spaces *> Value.decode) x - FromValue.fromValue y + Codec.decodeWith HasCodec.codec y decodePointer :: ByteString.ByteString -> Either String Pointer.Pointer decodePointer = Decoder.run Pointer.decode diff --git a/source/library/Argo/Encode.hs b/source/library/Argo/Encode.hs --- a/source/library/Argo/Encode.hs +++ b/source/library/Argo/Encode.hs @@ -1,7 +1,7 @@ module Argo.Encode where import qualified Argo.Class.HasCodec as HasCodec -import qualified Argo.Class.ToValue as ToValue +import qualified Argo.Codec.Value as Codec import qualified Argo.Json.Value as Value import qualified Argo.Literal as Literal import qualified Argo.Pointer.Pointer as Pointer @@ -20,7 +20,7 @@ let c = Config.initial { Config.indent = i } in Encoder.run c $ do - Value.encode $ ToValue.toValue x + Value.encode $ Codec.encodeWith HasCodec.codec x Monad.when (Config.hasIndent c) . Trans.lift . Trans.tell diff --git a/source/library/Argo/Schema/Identifier.hs b/source/library/Argo/Schema/Identifier.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Schema/Identifier.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Schema.Identifier where + +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Text as Text +import qualified Data.String as String +import qualified GHC.Generics as Generics + +newtype Identifier + = Identifier Text.Text + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Ord, Show) + +instance String.IsString Identifier where + fromString = fromText . String.fromString + +instance Semigroup Identifier where + x <> y = fromText $ toText x <> toText y -- TODO: remove this + +fromText :: Text.Text -> Identifier +fromText = Identifier + +toText :: Identifier -> Text.Text +toText (Identifier x) = x diff --git a/source/library/Argo/Schema/Schema.hs b/source/library/Argo/Schema/Schema.hs --- a/source/library/Argo/Schema/Schema.hs +++ b/source/library/Argo/Schema/Schema.hs @@ -11,6 +11,7 @@ import qualified Argo.Json.Object as Object import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Vendor.DeepSeq as DeepSeq import qualified Argo.Vendor.TemplateHaskell as TH import qualified Argo.Vendor.Text as Text @@ -44,3 +45,10 @@ true :: Schema true = fromValue . Value.Boolean $ Boolean.fromBool True + +unidentified :: Schema -> (Maybe Identifier.Identifier, Schema) +unidentified s = (Nothing, s) + +identified + :: Identifier.Identifier -> Schema -> (Maybe Identifier.Identifier, Schema) +identified i s = (Just i, s) diff --git a/source/library/Argo/Vendor/Map.hs b/source/library/Argo/Vendor/Map.hs --- a/source/library/Argo/Vendor/Map.hs +++ b/source/library/Argo/Vendor/Map.hs @@ -1,6 +1,10 @@ module Argo.Vendor.Map ( Map.Map + , Map.empty , Map.fromList + , Map.mapKeys + , Map.member + , Map.singleton , Map.toList ) where diff --git a/source/library/Argo/Vendor/Transformers.hs b/source/library/Argo/Vendor/Transformers.hs --- a/source/library/Argo/Vendor/Transformers.hs +++ b/source/library/Argo/Vendor/Transformers.hs @@ -1,26 +1,31 @@ module Argo.Vendor.Transformers - ( ExceptT.ExceptT - , MaybeT.MaybeT - , ReaderT.ReaderT - , StateT.StateT - , WriterT.WriterT - , ReaderT.ask - , StateT.get + ( Accum.AccumT + , Except.ExceptT + , Maybe.MaybeT + , Reader.ReaderT + , State.StateT + , Writer.WriterT + , Accum.add + , Reader.ask + , State.get , Trans.lift - , ReaderT.local - , StateT.put - , ExceptT.runExceptT - , MaybeT.runMaybeT - , ReaderT.runReaderT - , StateT.runStateT - , WriterT.runWriterT - , WriterT.tell - , ExceptT.throwE + , Reader.local + , Accum.look + , State.put + , Accum.runAccumT + , Except.runExceptT + , Maybe.runMaybeT + , Reader.runReaderT + , State.runStateT + , Writer.runWriterT + , Writer.tell + , Except.throwE ) where +import qualified Control.Monad.Trans.Accum as Accum import qualified Control.Monad.Trans.Class as Trans -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.Maybe as MaybeT -import qualified Control.Monad.Trans.Reader as ReaderT -import qualified Control.Monad.Trans.State as StateT -import qualified Control.Monad.Trans.Writer as WriterT +import qualified Control.Monad.Trans.Except as Except +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State as State +import qualified Control.Monad.Trans.Writer as Writer diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -17,12 +17,15 @@ import qualified Argo.Json.Number as Number import qualified Argo.Json.Object as Object import qualified Argo.Json.String as String +import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Decimal as Decimal import qualified Argo.Type.Permission as Permission +import qualified Control.Monad.Trans.Accum as Accum import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Functor.Identity as Identity import qualified Data.Int as Int import qualified Data.Map as Map import qualified Data.Text as Text @@ -362,121 +365,119 @@ , Tasty.testGroup "fromValue" [ Tasty.testCase "Value" $ do - Argo.fromValue Argo.Null @?= Right Argo.Null + fromValue Argo.Null @?= Right Argo.Null , Tasty.testCase "Bool" $ do - Argo.fromValue (Argo.Boolean False) @?= Right False + fromValue (Argo.Boolean False) @?= Right False , Tasty.testCase "Char" $ do - Argo.fromValue (Argo.String "a") @?= Right 'a' + fromValue (Argo.String "a") @?= Right 'a' , Tasty.testCase "Int" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int) + fromValue (number 0 0) @?= Right (0 :: Int) , Tasty.testCase "Int8" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int8) + fromValue (number 0 0) @?= Right (0 :: Int.Int8) , Tasty.testCase "Int16" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int16) + fromValue (number 0 0) @?= Right (0 :: Int.Int16) , Tasty.testCase "Int32" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int32) + fromValue (number 0 0) @?= Right (0 :: Int.Int32) , Tasty.testCase "Int64" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int64) + fromValue (number 0 0) @?= Right (0 :: Int.Int64) , Tasty.testCase "Word" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word) + fromValue (number 0 0) @?= Right (0 :: Word) , Tasty.testCase "Word8" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word8) + fromValue (number 0 0) @?= Right (0 :: Word.Word8) , Tasty.testCase "Word16" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word16) + fromValue (number 0 0) @?= Right (0 :: Word.Word16) , Tasty.testCase "Word32" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word32) + fromValue (number 0 0) @?= Right (0 :: Word.Word32) , Tasty.testCase "Word64" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word64) + fromValue (number 0 0) @?= Right (0 :: Word.Word64) , Tasty.testCase "Integer" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Integer) + fromValue (number 0 0) @?= Right (0 :: Integer) , Tasty.testCase "Float" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Float) + fromValue (number 0 0) @?= Right (0 :: Float) , Tasty.testCase "Double" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Double) + fromValue (number 0 0) @?= Right (0 :: Double) , Tasty.testCase "String" $ do - Argo.fromValue (Argo.String "") @?= Right ("" :: String) + fromValue (Argo.String "") @?= Right ("" :: String) , Tasty.testCase "Text" $ do - Argo.fromValue (Argo.String "") @?= Right ("" :: Text.Text) + fromValue (Argo.String "") @?= Right ("" :: Text.Text) , Tasty.testCase "LazyText" $ do - Argo.fromValue (Argo.String "") @?= Right ("" :: LazyText.Text) + fromValue (Argo.String "") @?= Right ("" :: LazyText.Text) , Tasty.testCase "Maybe a" $ do - Argo.fromValue (Argo.Boolean False) @?= Right (Just False) + fromValue (Argo.Boolean False) @?= Right (Just False) , Tasty.testCase "()" $ do - Argo.fromValue (Argo.Array []) @?= Right () + fromValue (Argo.Array []) @?= Right () , Tasty.testCase "(a, b)" $ do - Argo.fromValue (Argo.Array [Argo.Boolean False, Argo.String "a"]) + fromValue (Argo.Array [Argo.Boolean False, Argo.String "a"]) @?= Right (False, 'a') , Tasty.testCase "[a]" $ do - Argo.fromValue (Argo.Array []) @?= Right ([] :: [Bool]) + fromValue (Argo.Array []) @?= Right ([] :: [Bool]) , Tasty.testCase "NonEmpty a" $ do - Argo.fromValue (Argo.Array [Argo.Boolean False]) - @?= Right (False :| []) + fromValue (Argo.Array [Argo.Boolean False]) @?= Right (False :| []) , Tasty.testCase "Map Name a" $ do - Argo.fromValue + fromValue (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Boolean False] ) @?= Right (Map.fromList [(Argo.Name "a", False)]) , Tasty.testCase "Pointer" $ do - Argo.fromValue (Argo.String "") @?= Right (Argo.Pointer []) + fromValue (Argo.String "") @?= Right (Argo.Pointer []) ] , Tasty.testGroup "toValue" [ Tasty.testCase "Value" $ do - Argo.toValue Argo.Null @?= Argo.Null + toValue Argo.Null @?= Argo.Null , Tasty.testCase "Bool" $ do - Argo.toValue False @?= Argo.Boolean False + toValue False @?= Argo.Boolean False , Tasty.testCase "Char" $ do - Argo.toValue 'a' @?= Argo.String "a" + toValue 'a' @?= Argo.String "a" , Tasty.testCase "Int" $ do - Argo.toValue (0 :: Int) @?= number 0 0 + toValue (0 :: Int) @?= number 0 0 , Tasty.testCase "Int8" $ do - Argo.toValue (0 :: Int.Int8) @?= number 0 0 + toValue (0 :: Int.Int8) @?= number 0 0 , Tasty.testCase "Int16" $ do - Argo.toValue (0 :: Int.Int16) @?= number 0 0 + toValue (0 :: Int.Int16) @?= number 0 0 , Tasty.testCase "Int32" $ do - Argo.toValue (0 :: Int.Int32) @?= number 0 0 + toValue (0 :: Int.Int32) @?= number 0 0 , Tasty.testCase "Int64" $ do - Argo.toValue (0 :: Int.Int64) @?= number 0 0 + toValue (0 :: Int.Int64) @?= number 0 0 , Tasty.testCase "Word" $ do - Argo.toValue (0 :: Word) @?= number 0 0 + toValue (0 :: Word) @?= number 0 0 , Tasty.testCase "Word8" $ do - Argo.toValue (0 :: Word.Word8) @?= number 0 0 + toValue (0 :: Word.Word8) @?= number 0 0 , Tasty.testCase "Word16" $ do - Argo.toValue (0 :: Word.Word16) @?= number 0 0 + toValue (0 :: Word.Word16) @?= number 0 0 , Tasty.testCase "Word32" $ do - Argo.toValue (0 :: Word.Word32) @?= number 0 0 + toValue (0 :: Word.Word32) @?= number 0 0 , Tasty.testCase "Word64" $ do - Argo.toValue (0 :: Word.Word64) @?= number 0 0 + toValue (0 :: Word.Word64) @?= number 0 0 , Tasty.testCase "Integer" $ do - Argo.toValue (0 :: Integer) @?= number 0 0 + toValue (0 :: Integer) @?= number 0 0 , Tasty.testCase "Float" $ do - Argo.toValue (0 :: Float) @?= number 0 0 + toValue (0 :: Float) @?= number 0 0 , Tasty.testCase "Double" $ do - Argo.toValue (0 :: Double) @?= number 0 0 + toValue (0 :: Double) @?= number 0 0 , Tasty.testCase "String" $ do - Argo.toValue ("" :: String) @?= Argo.String "" + toValue ("" :: String) @?= Argo.String "" , Tasty.testCase "Text" $ do - Argo.toValue ("" :: Text.Text) @?= Argo.String "" + toValue ("" :: Text.Text) @?= Argo.String "" , Tasty.testCase "LazyText" $ do - Argo.toValue ("" :: LazyText.Text) @?= Argo.String "" + toValue ("" :: LazyText.Text) @?= Argo.String "" , Tasty.testCase "Maybe a" $ do - Argo.toValue (Just False) @?= Argo.Boolean False + toValue (Just False) @?= Argo.Boolean False , Tasty.testCase "()" $ do - Argo.toValue () @?= Argo.Array [] + toValue () @?= Argo.Array [] , Tasty.testCase "(a, b)" $ do - Argo.toValue (False, 'a') + toValue (False, 'a') @?= Argo.Array [Argo.Boolean False, Argo.String "a"] , Tasty.testCase "[a]" $ do - Argo.toValue ([] :: [Bool]) @?= Argo.Array [] + toValue ([] :: [Bool]) @?= Argo.Array [] , Tasty.testCase "NonEmpty a" $ do - Argo.toValue (False :| []) @?= Argo.Array [Argo.Boolean False] + toValue (False :| []) @?= Argo.Array [Argo.Boolean False] , Tasty.testCase "Map Name a" $ do - Argo.toValue (Map.fromList [(Argo.Name "a", False)]) - @?= Argo.Object - [Argo.Member (Argo.Name "a") $ Argo.Boolean False] + toValue (Map.fromList [(Argo.Name "a", False)]) @?= Argo.Object + [Argo.Member (Argo.Name "a") $ Argo.Boolean False] , Tasty.testCase "Pointer" $ do - Argo.toValue (Argo.Pointer []) @?= Argo.String "" + toValue (Argo.Pointer []) @?= Argo.String "" ] , Tasty.testGroup "quasi quoter" @@ -511,72 +512,63 @@ === Right (x :: Argo.Value) , Tasty.testGroup "fromValue . toValue" - [ property "Value" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Argo.Value) - , property "Bool" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Bool) + [ property "Value" + $ \x -> fromValue (toValue x) === Right (x :: Argo.Value) + , property "Bool" + $ \x -> fromValue (toValue x) === Right (x :: Bool) , property "Char" $ \x -> - Argo.fromValue (Argo.toValue x) - === if '\xd800' <= x && x <= '\xdfff' - then Right '\xfffd' - else Right x - , property "Int" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Int) - , property "Int8" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Int.Int8) - , property "Int16" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Int.Int16) - , property "Int32" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Int.Int32) - , property "Int64" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Int.Int64) - , property "Word" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Word) - , property "Word8" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Word.Word8) + fromValue (toValue x) === if '\xd800' <= x && x <= '\xdfff' + then Right '\xfffd' + else Right x + , property "Int" $ \x -> fromValue (toValue x) === Right (x :: Int) + , property "Int8" + $ \x -> fromValue (toValue x) === Right (x :: Int.Int8) + , property "Int16" + $ \x -> fromValue (toValue x) === Right (x :: Int.Int16) + , property "Int32" + $ \x -> fromValue (toValue x) === Right (x :: Int.Int32) + , property "Int64" + $ \x -> fromValue (toValue x) === Right (x :: Int.Int64) + , property "Word" + $ \x -> fromValue (toValue x) === Right (x :: Word) + , property "Word8" + $ \x -> fromValue (toValue x) === Right (x :: Word.Word8) , property "Word16" - $ \x -> Argo.fromValue (Argo.toValue x) - === Right (x :: Word.Word16) - , property "Word32" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Word.Word32) + $ \x -> fromValue (toValue x) === Right (x :: Word.Word16) + , property "Word32" + $ \x -> fromValue (toValue x) === Right (x :: Word.Word32) , property "Word64" - $ \x -> Argo.fromValue (Argo.toValue x) - === Right (x :: Word.Word64) - , property "Integer" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Integer) + $ \x -> fromValue (toValue x) === Right (x :: Word.Word64) + , property "Integer" + $ \x -> fromValue (toValue x) === Right (x :: Integer) , property "Float" $ \x -> - Argo.fromValue (Argo.toValue x) === if isNaN x || isInfinite x + fromValue (toValue x) === if isNaN x || isInfinite x then Left "expected Float but got Null (Null ())" else Right (x :: Float) , property "Double" $ \x -> - Argo.fromValue (Argo.toValue x) === if isNaN x || isInfinite x + fromValue (toValue x) === if isNaN x || isInfinite x then Left "expected Double but got Null (Null ())" else Right (x :: Double) - , property "String" - $ \x -> Argo.fromValue (Argo.toValue x) - === Right (Text.unpack $ Text.pack x) - , property "Text" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Text.Text) - , property "LazyText" - $ \x -> Argo.fromValue (Argo.toValue x) - === Right (x :: LazyText.Text) - , property "Maybe a" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Maybe Bool) - , property "()" - $ \x -> Argo.fromValue (Argo.toValue x) === Right (x :: ()) - , property "(a, b)" - $ \x -> Argo.fromValue (Argo.toValue x) - === Right (x :: (Bool, Int.Int8)) + , property "String" $ \x -> + fromValue (toValue x) === Right (Text.unpack $ Text.pack x) + , property "Text" + $ \x -> fromValue (toValue x) === Right (x :: Text.Text) + , property "LazyText" $ \x -> + fromValue (toValue x) === Right (x :: LazyText.Text) + , property "Maybe a" + $ \x -> fromValue (toValue x) === Right (x :: Maybe Bool) + , property "()" $ \x -> fromValue (toValue x) === Right (x :: ()) + , property "(a, b)" $ \x -> + fromValue (toValue x) === Right (x :: (Bool, Int.Int8)) , property "[a]" - $ \x -> Argo.fromValue (Argo.toValue x) === Right (x :: [Bool]) - , property "NonEmpty a" - $ \x -> Argo.fromValue (Argo.toValue x) - === Right (x :: NonEmpty Bool) + $ \x -> fromValue (toValue x) === Right (x :: [Bool]) + , property "NonEmpty a" $ \x -> + fromValue (toValue x) === Right (x :: NonEmpty Bool) , property "Map Name a" - $ \x -> Argo.fromValue (Argo.toValue x) + $ \x -> fromValue (toValue x) === Right (x :: Map.Map Argo.Name Bool) - , property "Pointer" $ \x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Argo.Pointer) + , property "Pointer" + $ \x -> fromValue (toValue x) === Right (x :: Argo.Pointer) ] ] , Tasty.testGroup @@ -745,231 +737,533 @@ , Tasty.testGroup "Schema" [ Tasty.testCase "value" $ do - let expected = [Argo.schema| true |] + let expected = schemafy (Just "Value") [Argo.schema| true |] actual = Codec.schema (Argo.codec :: Codec.Value Argo.Value) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "null" $ do - let expected = [Argo.schema| { "type": "null" } |] + let expected = + schemafy (Just "Null") [Argo.schema| { "type": "null" } |] actual = Codec.schema (Argo.codec :: Codec.Value Null.Null) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "boolean" $ do - let expected = [Argo.schema| { "type": "boolean" } |] + let expected = schemafy + (Just "Boolean") + [Argo.schema| { "type": "boolean" } |] actual = Codec.schema (Argo.codec :: Codec.Value Boolean.Boolean) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "number" $ do - let expected = [Argo.schema| { "type": "number" } |] + let expected = schemafy + (Just "Number") + [Argo.schema| { "type": "number" } |] actual = Codec.schema (Argo.codec :: Codec.Value Number.Number) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "string" $ do - let expected = [Argo.schema| { "type": "string" } |] + let expected = schemafy + (Just "String") + [Argo.schema| { "type": "string" } |] actual = Codec.schema (Argo.codec :: Codec.Value String.String) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "array boolean" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "array", "items": { "type": "boolean" } } |] + let expected = schemafy + (Just "Array Boolean") + [Argo.schema| { "type": "array", "items": { "$ref": "#/definitions/Boolean" } } |] actual = Codec.schema (Argo.codec :: Codec.Value (Array.Array Boolean.Boolean) ) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "object boolean" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "object", "additionalProperties": { "type": "boolean" } } |] + let expected = schemafy + (Just "Object Boolean") + [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] actual = Codec.schema (Argo.codec :: Codec.Value (Object.Object Boolean.Boolean) ) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "maybe boolean" $ do - let expected = - Schema.fromValue - [Argo.value| { "oneOf": [ { "type": "boolean" }, { "type": "null" } ] } |] + let expected = schemafy + (Just "Maybe Boolean") + [Argo.schema| { "oneOf": [ { "type": "boolean" }, { "type": "null" } ] } |] actual = Codec.schema (Argo.codec :: Codec.Value (Maybe Boolean.Boolean)) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "either boolean number" $ do - let expected = - Schema.fromValue - [Argo.value| { "oneOf": [ { "type": "object", "properties": { "type": { "const": "Left" }, "value": { "type": "boolean" } }, "required": [ "type", "value" ], "additionalProperties": false }, { "type": "object", "properties": { "type": { "const": "Right" }, "value": { "type": "number" } }, "required": [ "type", "value" ], "additionalProperties": false } ] } |] + let expected = schemafy + (Just "Either Boolean Number") + [Argo.schema| { "oneOf": [ { "type": "object", "properties": { "type": { "const": "Left" }, "value": { "$ref": "#/definitions/Boolean" } }, "required": [ "type", "value" ], "additionalProperties": false }, { "type": "object", "properties": { "type": { "const": "Right" }, "value": { "$ref": "#/definitions/Number" } }, "required": [ "type", "value" ], "additionalProperties": false } ] } |] actual = Codec.schema (Argo.codec :: Codec.Value (Either Boolean.Boolean Number.Number) ) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "()" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "array", "items": [], "additionalItems": false } |] + let expected = schemafy + (Just "()") + [Argo.schema| { "type": "array", "items": [], "additionalItems": false } |] actual = Codec.schema (Argo.codec :: Codec.Value ()) - actual @?= expected - , Tasty.testCase "(boolean, number)" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "array", "items": [ { "type": "boolean" }, { "type": "number" } ], "additionalItems": false } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Boolean.Boolean, Number.Number) - ) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "2-tuple" $ do + let expected = schemafy + (Just "(Value,Null)") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value (Argo.Value, Null.Null)) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "3-tuple" $ do + let expected = schemafy + (Just "(Value,Null,Boolean)") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + , { "$ref": "#/definitions/Boolean" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + (Argo.Value, Null.Null, Boolean.Boolean) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "4-tuple" $ do + let expected = schemafy + (Just "(Value,Null,Boolean,Number)") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + , { "$ref": "#/definitions/Boolean" } + , { "$ref": "#/definitions/Number" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + ( Argo.Value + , Null.Null + , Boolean.Boolean + , Number.Number + ) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "5-tuple" $ do + let expected = schemafy + (Just "(Value,Null,Boolean,Number,Integer)") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + , { "$ref": "#/definitions/Boolean" } + , { "$ref": "#/definitions/Number" } + , { "$ref": "#/definitions/Integer" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + ( Argo.Value + , Null.Null + , Boolean.Boolean + , Number.Number + , Integer + ) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "6-tuple" $ do + let expected = schemafy + (Just "(Value,Null,Boolean,Number,Integer,String)") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + , { "$ref": "#/definitions/Boolean" } + , { "$ref": "#/definitions/Number" } + , { "$ref": "#/definitions/Integer" } + , { "$ref": "#/definitions/String" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + ( Argo.Value + , Null.Null + , Boolean.Boolean + , Number.Number + , Integer + , String.String + ) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "7-tuple" $ do + let expected = schemafy + (Just "(Value,Null,Boolean,Number,Integer,String,())") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + , { "$ref": "#/definitions/Boolean" } + , { "$ref": "#/definitions/Number" } + , { "$ref": "#/definitions/Integer" } + , { "$ref": "#/definitions/String" } + , { "$ref": "#/definitions/()" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + ( Argo.Value + , Null.Null + , Boolean.Boolean + , Number.Number + , Integer + , String.String + , () + ) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "8-tuple" $ do + let expected = schemafy + (Just "(Value,Null,Boolean,Number,Integer,String,(),Char)") + [Argo.schema| { "type": "array", "items": + [ { "$ref": "#/definitions/Value" } + , { "$ref": "#/definitions/Null" } + , { "$ref": "#/definitions/Boolean" } + , { "$ref": "#/definitions/Number" } + , { "$ref": "#/definitions/Integer" } + , { "$ref": "#/definitions/String" } + , { "$ref": "#/definitions/()" } + , { "$ref": "#/definitions/Char" } + ], "additionalItems": false } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + ( Argo.Value + , Null.Null + , Boolean.Boolean + , Number.Number + , Integer + , String.String + , () + , Char + ) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "bool" $ do - let expected = [Argo.schema| { "type": "boolean" } |] + let expected = schemafy + (Just "Bool") + [Argo.schema| { "type": "boolean" } |] actual = Codec.schema (Argo.codec :: Codec.Value Bool) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "decimal" $ do - let expected = [Argo.schema| { "type": "number" } |] + let expected = schemafy + (Just "Decimal") + [Argo.schema| { "type": "number" } |] actual = Codec.schema (Argo.codec :: Codec.Value Decimal.Decimal) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "text" $ do - let expected = [Argo.schema| { "type": "string" } |] + let expected = schemafy + (Just "Text") + [Argo.schema| { "type": "string" } |] actual = Codec.schema (Argo.codec :: Codec.Value Text.Text) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "list boolean" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "array", "items": { "type": "boolean" } } |] + let expected = schemafy + (Just "[Boolean]") + [Argo.schema| { "type": "array", "items": { "$ref": "#/definitions/Boolean" } } |] actual = Codec.schema (Argo.codec :: Codec.Value [Boolean.Boolean]) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "map name boolean" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "object", "additionalProperties": { "type": "boolean" } } |] + let expected = schemafy + (Just "Map Name Boolean") + [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] actual = Codec.schema (Argo.codec :: Codec.Value (Map.Map Name.Name Boolean.Boolean) ) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "map (argo) string boolean" $ do + let expected = schemafy + (Just "Map String Boolean") + [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + (Map.Map String.String Boolean.Boolean) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "map (strict) text boolean" $ do + let expected = schemafy + (Just "Map Text Boolean") + [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] + actual = + Codec.schema + (Argo.codec :: Codec.Value + (Map.Map Text.Text Boolean.Boolean) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "map (lazy) text boolean" $ do + let expected = schemafy + (Just "Map Text Boolean") + [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] + actual = Codec.schema + (Argo.codec :: Codec.Value + (Map.Map LazyText.Text Boolean.Boolean) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "map (base) string boolean" $ do + let expected = schemafy + (Just "Map [Char] Boolean") + [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] + actual = + Codec.schema + (Argo.codec :: Codec.Value + (Map.Map String Boolean.Boolean) + ) + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "string" $ do - let expected = [Argo.schema| { "type": "string" } |] + let expected = schemafy + (Just "[Char]") + [Argo.schema| { "type": "string" } |] actual = Codec.schema (Argo.codec :: Codec.Value String) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "char" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "string", "minLength": 1, "maxLength": 1 } |] + let expected = schemafy + (Just "Char") + [Argo.schema| { "type": "string", "minLength": 1, "maxLength": 1 } |] actual = Codec.schema (Argo.codec :: Codec.Value Char) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "lazy text" $ do - let expected = [Argo.schema| { "type": "string" } |] + let expected = schemafy + (Just "Text") + [Argo.schema| { "type": "string" } |] actual = Codec.schema (Argo.codec :: Codec.Value LazyText.Text) - actual @?= expected - , Tasty.testCase "list boolean" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "array", "items": { "type": "boolean" }, "minItems": 1 } |] + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + , Tasty.testCase "non-empty boolean" $ do + let expected = schemafy + (Just "NonEmpty Boolean") + [Argo.schema| { "type": "array", "items": { "type": "boolean" }, "minItems": 1 } |] actual = Codec.schema (Argo.codec :: Codec.Value (NonEmpty Boolean.Boolean)) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "integer" $ do - let expected = [Argo.schema| { "type": "integer" } |] + let expected = schemafy + (Just "Integer") + [Argo.schema| { "type": "integer" } |] actual = Codec.schema (Argo.codec :: Codec.Value Integer) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "int" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] + let expected = schemafy + (Just "Int") + [Argo.schema| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] actual = Codec.schema (Argo.codec :: Codec.Value Int) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "int8" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": -128, "maximum": 127 } |] + let expected = schemafy + (Just "Int8") + [Argo.schema| { "type": "integer", "minimum": -128, "maximum": 127 } |] actual = Codec.schema (Argo.codec :: Codec.Value Int.Int8) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "int16" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": -32768, "maximum": 32767 } |] + let expected = schemafy + (Just "Int16") + [Argo.schema| { "type": "integer", "minimum": -32768, "maximum": 32767 } |] actual = Codec.schema (Argo.codec :: Codec.Value Int.Int16) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "int32" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": -2147483648, "maximum": 2147483647 } |] + let expected = schemafy + (Just "Int32") + [Argo.schema| { "type": "integer", "minimum": -2147483648, "maximum": 2147483647 } |] actual = Codec.schema (Argo.codec :: Codec.Value Int.Int32) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "int64" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] + let expected = schemafy + (Just "Int64") + [Argo.schema| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] actual = Codec.schema (Argo.codec :: Codec.Value Int.Int64) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "natural" $ do - let expected = Schema.fromValue - [Argo.value| { "type": "integer", "minimum": 0 } |] + let expected = schemafy + (Just "Natural") + [Argo.schema| { "type": "integer", "minimum": 0 } |] actual = Codec.schema (Argo.codec :: Codec.Value Natural.Natural) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "word" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] + let expected = schemafy + (Just "Word") + [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] actual = Codec.schema (Argo.codec :: Codec.Value Word) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "word8" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": 0, "maximum": 255 } |] + let expected = schemafy + (Just "Word8") + [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 255 } |] actual = Codec.schema (Argo.codec :: Codec.Value Word.Word8) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "word16" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": 0, "maximum": 65535 } |] + let expected = schemafy + (Just "Word16") + [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 65535 } |] actual = Codec.schema (Argo.codec :: Codec.Value Word.Word16) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "word32" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": 0, "maximum": 4294967295 } |] + let expected = schemafy + (Just "Word32") + [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 4294967295 } |] actual = Codec.schema (Argo.codec :: Codec.Value Word.Word32) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "word64" $ do - let expected = - Schema.fromValue - [Argo.value| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] + let expected = schemafy + (Just "Word64") + [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] actual = Codec.schema (Argo.codec :: Codec.Value Word.Word64) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "float" $ do - let expected = [Argo.schema| { "type": "number" } |] + let expected = schemafy + (Just "Float") + [Argo.schema| { "type": "number" } |] actual = Codec.schema (Argo.codec :: Codec.Value Float) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "double" $ do - let expected = [Argo.schema| { "type": "number" } |] + let expected = schemafy + (Just "Double") + [Argo.schema| { "type": "number" } |] actual = Codec.schema (Argo.codec :: Codec.Value Double) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "pointer" $ do - let expected = [Argo.schema| { "type": "string" } |] + let expected = schemafy + (Just "Pointer") + [Argo.schema| { "type": "string" } |] actual = Codec.schema (Argo.codec :: Codec.Value Argo.Pointer) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "schema" $ do - let expected = [Argo.schema| true |] + let expected = schemafy (Just "Schema") [Argo.schema| true |] actual = Codec.schema (Argo.codec :: Codec.Value Schema.Schema) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty , Tasty.testCase "record" $ do - let expected - = [Argo.schema| { "type": "object", "properties": { "bool": { "type": "boolean" }, "text": { "type": "string" } }, "required": [ "bool" ], "additionalProperties": true } |] + let expected = schemafy + Nothing + [Argo.schema| { "type": "object", "properties": { "bool": { "$ref": "#/definitions/Bool" }, "text": { "$ref": "#/definitions/Text" } }, "required": [ "bool" ], "additionalProperties": true } |] actual = Codec.schema (Argo.codec :: Codec.Value Record) - actual @?= expected + Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty ] + , Tasty.testGroup "T1" + $ let codec = Argo.codec :: Codec.Value T1 + in + [ Tasty.testCase "schema" $ do + let expected = schemafy + Nothing + [Argo.schema| + { + "type": "object", + "properties": { + "t1c1f1": { "$ref": "#/definitions/Float" }, + "t1c1f2": { "$ref": "#/definitions/Maybe Float" }, + "t1c1f3": { "$ref": "#/definitions/Float" }, + "t1c1f4": { "$ref": "#/definitions/Maybe Float" } + }, + "required": [ "t1c1f1", "t1c1f2" ], + "additionalProperties": true + } + |] + actual = Codec.schema codec + Accum.evalAccumT actual mempty + @?= Accum.evalAccumT expected mempty + , Tasty.testCase "decode" $ do + hush (Argo.decode "{ \"t1c1f1\": 0 }") + @?= (Nothing :: Maybe T1) + Argo.decode "{ \"t1c1f1\": 0, \"t1c1f2\": null }" + @?= Right (T1C1 0 Nothing Nothing Nothing) + Argo.decode "{ \"t1c1f1\": 1, \"t1c1f2\": 0 }" + @?= Right (T1C1 1 (Just 0) Nothing Nothing) + Argo.decode + "{ \"t1c1f1\": 2, \"t1c1f2\": null, \"t1c1f3\": null }" + @?= Right (T1C1 2 Nothing Nothing Nothing) + Argo.decode + "{ \"t1c1f1\": 3, \"t1c1f2\": null, \"t1c1f3\": 0 }" + @?= Right (T1C1 3 Nothing (Just 0) Nothing) + Argo.decode + "{ \"t1c1f1\": 4, \"t1c1f2\": null, \"t1c1f4\": null }" + @?= Right (T1C1 4 Nothing Nothing (Just Nothing)) + Argo.decode + "{ \"t1c1f1\": 5, \"t1c1f2\": null, \"t1c1f4\": 0 }" + @?= Right (T1C1 5 Nothing Nothing (Just (Just 0))) + hush (Argo.decode "{ \"t1c1f1\": 6, \"t1c1f2\": [] }") + @?= (Nothing :: Maybe T1) + hush + (Argo.decode + "{ \"t1c1f1\": 7, \"t1c1f2\": null, \"t1c1f3\": [] }" + ) + @?= (Nothing :: Maybe T1) + hush + (Argo.decode + "{ \"t1c1f1\": 8, \"t1c1f2\": null, \"t1c1f4\": [] }" + ) + @?= (Nothing :: Maybe T1) + , Tasty.testCase "encode" $ do + let + encode = + Builder.toLazyByteString . Argo.encode :: T1 + -> LazyByteString.ByteString + encode (T1C1 0 Nothing Nothing Nothing) + @?= "{\"t1c1f1\":0,\"t1c1f2\":null}" + encode (T1C1 1 (Just 0) Nothing Nothing) + @?= "{\"t1c1f1\":1,\"t1c1f2\":0}" + encode (T1C1 2 Nothing (Just 0) Nothing) + @?= "{\"t1c1f1\":2,\"t1c1f2\":null,\"t1c1f3\":0}" + encode (T1C1 3 Nothing Nothing (Just Nothing)) + @?= "{\"t1c1f1\":3,\"t1c1f2\":null,\"t1c1f4\":null}" + encode (T1C1 4 Nothing Nothing (Just (Just 0))) + @?= "{\"t1c1f1\":4,\"t1c1f2\":null,\"t1c1f4\":0}" + ] + , Tasty.testCase "T2" $ do + let schema = [Argo.schema| + { "type": "object" + , "properties": { "t2c1f1": { "$ref": "#/definitions/T2" } } + , "required": [] + , "additionalProperties": true + } |] + expected = schemafy (Just "T2") schema + actual = Codec.schema (Argo.codec :: Codec.Value T2) + Accum.runAccum actual mempty + @?= (Accum.evalAccum expected mempty, Map.singleton "T2" schema) ] +fromValue :: Argo.HasCodec a => Argo.Value -> Either String a +fromValue = Codec.decodeWith Argo.codec + +toValue :: Argo.HasCodec a => a -> Argo.Value +toValue = Codec.encodeWith Argo.codec + number :: Integer -> Integer -> Argo.Value number s = Argo.Number . Argo.Decimal s +newtype T2 = T2C1 + { t2c1f1 :: Maybe T2 + } deriving (Eq, Show) + +instance Argo.HasCodec T2 where + codec = + Codec.identified + . Codec.fromObjectCodec Permission.Allow + $ T2C1 + <$> Codec.project t2c1f1 (Codec.optional "t2c1f1" Argo.codec) + +data T1 = T1C1 + { t1c1f1 :: Float + , t1c1f2 :: Maybe Float + , t1c1f3 :: Maybe Float + , t1c1f4 :: Maybe (Maybe Float) + } + deriving (Eq, Show) + +instance Argo.HasCodec T1 where + codec = + Codec.fromObjectCodec Permission.Allow + $ T1C1 + <$> Codec.project t1c1f1 (Codec.required "t1c1f1" Argo.codec) + <*> Codec.project t1c1f2 (Codec.required "t1c1f2" Argo.codec) + <*> Codec.project t1c1f3 (Codec.optional "t1c1f3" Argo.codec) + <*> Codec.project t1c1f4 (Codec.optional "t1c1f4" Argo.codec) + data Record = Record { recordBool :: Bool , recordText :: Maybe Text.Text @@ -1006,3 +1300,12 @@ hush :: Either String a -> Maybe a hush = either (const Nothing) Just + +schemafy + :: Maybe Identifier.Identifier + -> Schema.Schema + -> Accum.AccumT + (Map.Map Identifier.Identifier Schema.Schema) + Identity.Identity + (Maybe Identifier.Identifier, Schema.Schema) +schemafy m = pure . maybe Schema.unidentified Schema.identified m