diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Taylor Fausak + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/LICENSE.txt b/LICENSE.txt deleted file mode 100644 --- a/LICENSE.txt +++ /dev/null @@ -1,21 +0,0 @@ -MIT License - -Copyright (c) 2021 Taylor Fausak - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/argo.cabal b/argo.cabal --- a/argo.cabal +++ b/argo.cabal @@ -1,13 +1,13 @@ cabal-version: 2.2 name: argo -version: 0.2021.11.13 +version: 0.2022.1.15 build-type: Simple category: JSON description: Argo parses and renders JSON. extra-source-files: CHANGELOG.md README.md -license-file: LICENSE.txt +license-file: LICENSE.md license: MIT maintainer: Taylor Fausak synopsis: Parse and render JSON. @@ -70,6 +70,11 @@ Argo.Class.FromValue Argo.Class.HasCodec Argo.Class.ToValue + Argo.Codec.Array + Argo.Codec.Codec + Argo.Codec.List + Argo.Codec.Object + Argo.Codec.Value Argo.Decode Argo.Encode Argo.Json.Array @@ -87,7 +92,7 @@ Argo.Pointer.Pointer Argo.Pointer.Token Argo.QuasiQuoter - Argo.Type.Codec + Argo.Schema.Schema Argo.Type.Config Argo.Type.Decimal Argo.Type.Decoder diff --git a/source/benchmark/Main.hs b/source/benchmark/Main.hs --- a/source/benchmark/Main.hs +++ b/source/benchmark/Main.hs @@ -9,52 +9,110 @@ main :: IO () main = Tasty.defaultMain - [ Tasty.bgroup "encode" $ let encode = Builder.toLazyByteString . Argo.encode :: Argo.Value -> LazyByteString.ByteString in - [ 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 + "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.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.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.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.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.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.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" $ let decode = Argo.decode :: ByteString.ByteString -> Either String Argo.Value in - [ 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.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\"" @@ -62,32 +120,113 @@ , 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.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.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.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.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.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.bgroup + "Pointer" [ Tasty.bench "decode" $ Tasty.nf Argo.decodePointer "" - , Tasty.bench "encode" . Tasty.nf Builder.toLazyByteString . Argo.encodePointer $ Argo.Pointer [] + , Tasty.bench "encode" + . Tasty.nf Builder.toLazyByteString + . Argo.encodePointer + $ Argo.Pointer [] ] ] + +encode :: Argo.Value -> LazyByteString.ByteString +encode = Builder.toLazyByteString . Argo.encode + +decode :: ByteString.ByteString -> Either String Argo.Value +decode = Argo.decode diff --git a/source/library/Argo.hs b/source/library/Argo.hs --- a/source/library/Argo.hs +++ b/source/library/Argo.hs @@ -1,16 +1,14 @@ -{-# LANGUAGE PatternSynonyms #-} - module Argo ( Value.Value - ( Pattern.Null + ( Pattern.Array , Pattern.Boolean + , Pattern.Null , Pattern.Number - , Pattern.String - , Pattern.Array , Pattern.Object + , Pattern.String ) , Name.Name(Pattern.Name) - , Member.MemberOf(Member) + , Member.Member(Member) , Encode.encode , Encode.encodeWith , Indent.Indent(Spaces, Tab) @@ -20,12 +18,14 @@ , HasCodec.HasCodec(codec) , QuasiQuoter.value , QuasiQuoter.pointer + , QuasiQuoter.schema , Pointer.Pointer(Pointer) , Token.Token(Token) , Pointer.evaluate , Encode.encodePointer , Decode.decodePointer , Decimal.Decimal(Pattern.Decimal) + , Schema.Schema ) where import qualified Argo.Class.FromValue as FromValue @@ -40,5 +40,6 @@ import qualified Argo.Pointer.Pointer as Pointer import qualified Argo.Pointer.Token as Token import qualified Argo.QuasiQuoter as QuasiQuoter +import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Decimal as Decimal import qualified Argo.Type.Indent as Indent diff --git a/source/library/Argo/Class/FromValue.hs b/source/library/Argo/Class/FromValue.hs --- a/source/library/Argo/Class/FromValue.hs +++ b/source/library/Argo/Class/FromValue.hs @@ -1,8 +1,8 @@ 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 -import qualified Argo.Type.Codec as Codec 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 @@ -1,9 +1,14 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Argo.Class.HasCodec where import Control.Applicative ((<|>)) +import qualified Argo.Codec.Array as Codec +import qualified Argo.Codec.Codec as Codec +import qualified Argo.Codec.Object as Codec +import qualified Argo.Codec.Value as Codec import qualified Argo.Json.Array as Array import qualified Argo.Json.Boolean as Boolean import qualified Argo.Json.Member as Member @@ -14,7 +19,7 @@ import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value import qualified Argo.Pointer.Pointer as Pointer -import qualified Argo.Type.Codec as Codec +import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Config as Config import qualified Argo.Type.Decimal as Decimal import qualified Argo.Type.Decoder as Decoder @@ -30,196 +35,555 @@ 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.ValueCodec a + 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 = basicCodec "Null" Value.Null $ \ value -> case value of - Value.Null null_ -> Just null_ - _ -> Nothing + 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 = basicCodec "Boolean" Value.Boolean $ \ value -> case value of - Value.Boolean boolean -> Just boolean - _ -> Nothing + 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 = basicCodec "Number" Value.Number $ \ value -> case value of - Value.Number number -> Just number - _ -> Nothing + 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 = basicCodec "String" Value.String $ \ value -> case value of - Value.String string -> Just string - _ -> Nothing + 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.ArrayOf a) where +instance HasCodec a => HasCodec (Array.Array a) where codec = Codec.Codec { Codec.decode = do - array <- castValue "Array" $ \ value -> case value of + 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 + , 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.ObjectOf a) where +instance HasCodec a => HasCodec (Object.Object a) where codec = Codec.Codec { Codec.decode = do - object <- castValue "Object" $ \ value -> case value of + 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) + . traverse + (\(Member.Member k v) -> + Member.Member k <$> Codec.decodeWith codec v + ) $ Object.toList object - , Codec.encode = Codec.tap + , Codec.encode = + Codec.tap $ Trans.lift . Trans.put . Value.Object . Object.fromList - . fmap (\ (Member.Member k v) -> Member.Member k $ Codec.encodeWith codec v) + . 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.dimap (const Nothing) (const $ Null.fromUnit ()) codec + 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) + 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) + codec = + Codec.fromArrayCodec Permission.Forbid + $ (,) + <$> Codec.project fst (Codec.element codec) + <*> Codec.project snd (Codec.element codec) instance HasCodec Bool where - codec = Codec.dimap Boolean.toBool Boolean.fromBool codec + codec = Codec.map Boolean.toBool Boolean.fromBool codec instance HasCodec Decimal.Decimal where - codec = Codec.dimap Number.toDecimal Number.fromDecimal codec + codec = Codec.map Number.toDecimal Number.fromDecimal codec instance HasCodec Text.Text where - codec = Codec.dimap String.toText String.fromText codec + codec = Codec.map String.toText String.fromText codec instance {-# OVERLAPPABLE #-} HasCodec a => HasCodec [a] where - codec = Codec.dimap Array.toList Array.fromList codec + codec = Codec.map Array.toList Array.fromList codec instance HasCodec a => HasCodec (Map.Map Name.Name a) where - codec = Codec.dimap + codec = Codec.map (Map.fromList . fmap Member.toTuple . Object.toList) (Object.fromList . fmap Member.fromTuple . Map.toList) codec instance HasCodec String where - codec = Codec.dimap Text.unpack Text.pack codec + codec = Codec.map Text.unpack Text.pack codec instance HasCodec Char where - codec = Codec.mapMaybe (\ x -> case Text.uncons x of - Just (y, z) | Text.null z -> Just y - _ -> Nothing) (Just . Text.singleton) codec + 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.dimap Text.fromStrict Text.toStrict codec + codec = Codec.map Text.fromStrict Text.toStrict codec instance HasCodec a => HasCodec (NonEmpty.NonEmpty a) where - codec = Codec.mapMaybe NonEmpty.nonEmpty (Just . NonEmpty.toList) codec + 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 = Codec.mapMaybe Decimal.toInteger (Just . Decimal.fromInteger) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 - in Codec.mapMaybe from (Just . into) codec + 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 + codec = + Codec.mapMaybe (Just . Decimal.toRealFloat) Decimal.fromRealFloat codec instance HasCodec Double where - codec = Codec.mapMaybe (Just . Decimal.toRealFloat) Decimal.fromRealFloat codec + codec = + Codec.mapMaybe (Just . Decimal.toRealFloat) Decimal.fromRealFloat codec instance HasCodec Pointer.Pointer where codec = Codec.mapMaybe - ( either (const Nothing) Just + (either (const Nothing) Just . Decoder.run Pointer.decode . Text.encodeUtf8 ) - ( either (const Nothing) Just + (either (const Nothing) Just . Text.decodeUtf8' . ByteString.toStrict . Builder.toLazyByteString @@ -228,16 +592,28 @@ ) codec -basicCodec :: String -> (a -> Value.Value) -> (Value.Value -> Maybe a) -> Codec.ValueCodec a -basicCodec expected toValue fromValue = Codec.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 } castValue :: String -> (Value.Value -> Maybe a) - -> Trans.ReaderT Value.Value (Trans.ExceptT String Identity.Identity) a + -> Trans.ReaderT + Value.Value + (Trans.ExceptT String Identity.Identity) + a castValue expected fromValue = do value <- Trans.ask case fromValue value of diff --git a/source/library/Argo/Class/ToValue.hs b/source/library/Argo/Class/ToValue.hs --- a/source/library/Argo/Class/ToValue.hs +++ b/source/library/Argo/Class/ToValue.hs @@ -1,8 +1,8 @@ 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 -import qualified Argo.Type.Codec as Codec 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 new file mode 100644 --- /dev/null +++ b/source/library/Argo/Codec/Array.hs @@ -0,0 +1,61 @@ +module Argo.Codec.Array where + +import qualified Argo.Codec.Codec as Codec +import qualified Argo.Codec.List as Codec +import qualified Argo.Codec.Value as Codec +import qualified Argo.Json.Array as Array +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.Object as Object +import qualified Argo.Json.String as String +import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Schema as Schema +import qualified Argo.Type.Permission as Permission +import qualified Argo.Vendor.Text as Text +import qualified Argo.Vendor.Transformers as Trans + +type Array a = Codec.List [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 + ) + ] + ) + $ Codec.map Array.toList Array.fromList Codec.arrayCodec + +element :: Codec.Value a -> Array a +element c = Codec.Codec + { Codec.decode = do + l <- Trans.get + case l of + [] -> Trans.lift $ Trans.throwE "unexpected empty list" + h : t -> case Codec.decodeWith c h of + Left y -> Trans.lift $ Trans.throwE y + Right y -> do + Trans.put t + pure y + , Codec.encode = \x -> do + Trans.tell [Codec.encodeWith c x] + pure x + , Codec.schema = [Codec.schema c] + } diff --git a/source/library/Argo/Codec/Codec.hs b/source/library/Argo/Codec/Codec.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Codec/Codec.hs @@ -0,0 +1,81 @@ +module Argo.Codec.Codec where + +import Control.Applicative ((<|>)) + +import qualified Control.Applicative as Applicative + +data Codec r w s i o = Codec + { decode :: r o + , encode :: i -> w o + , schema :: s + } + +instance (Functor r, Functor w) => Functor (Codec r w s i) where + fmap f c = Codec + { decode = f <$> decode c + , encode = fmap f . encode c + , 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 } + cf <*> cx = Codec + { decode = decode cf <*> decode cx + , encode = \i -> encode cf i <*> encode cx i + , schema = schema cf <> schema cx + } + +instance + ( Applicative.Alternative r + , Applicative.Alternative w + , Monoid s + ) => Applicative.Alternative (Codec r w s i) where + empty = Codec + { decode = Applicative.empty + , encode = const Applicative.empty + , schema = mempty + } + cx <|> cy = Codec + { decode = decode cx <|> decode cy + , encode = \i -> encode cx i <|> encode cy i + , schema = schema cx <> schema cy + } + +map + :: (Functor r, Functor w) + => (a -> b) + -> (b -> a) + -> Codec r w s a a + -> Codec r w s b b +map f g c = Codec + { decode = f <$> decode c + , encode = fmap f . encode c . g + , schema = schema c + } + +mapMaybe + :: (Applicative.Alternative r, Applicative.Alternative w, Monad r, Monad w) + => (o2 -> Maybe o1) + -> (i1 -> Maybe i2) + -> Codec r w s i2 o2 + -> Codec r w s i1 o1 +mapMaybe f g c = Codec + { decode = do + o2 <- decode c + toAlternative $ f o2 + , encode = \i1 -> do + i2 <- toAlternative $ g i1 + o2 <- encode c i2 + toAlternative $ f o2 + , schema = schema c + } + +project :: (i -> f) -> Codec r w s f o -> Codec r w s i o +project f c = c { encode = encode c . f } + +tap :: Functor f => (a -> f b) -> a -> f a +tap f x = x <$ f x + +toAlternative :: Applicative.Alternative m => Maybe a -> m a +toAlternative = maybe Applicative.empty pure diff --git a/source/library/Argo/Codec/List.hs b/source/library/Argo/Codec/List.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Codec/List.hs @@ -0,0 +1,49 @@ +module Argo.Codec.List where + +import qualified Argo.Codec.Codec as Codec +import qualified Argo.Codec.Value as Codec +import qualified Argo.Schema.Schema as Schema +import qualified Argo.Type.Permission as Permission +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified Data.Functor.Identity as Identity + +type List s e a + = Codec.Codec + (Trans.StateT [e] (Trans.ExceptT String Identity.Identity)) + (Trans.WriterT [e] Identity.Identity) + s + a + a + +fromListCodec + :: (Permission.Permission -> s -> Schema.Schema) + -> Codec.Value [e] + -> Permission.Permission + -> List s e a + -> Codec.Value a +fromListCodec f ce p ca = Codec.Codec + { Codec.decode = do + xs <- Codec.decode ce + case + Identity.runIdentity . Trans.runExceptT $ Trans.runStateT + (Codec.decode ca) + xs + of + Left x -> Trans.lift $ Trans.throwE x + Right (x, ys) -> do + case (p, ys) of + (Permission.Forbid, _ : _) -> + Trans.lift $ Trans.throwE "leftover elements" + _ -> pure () + pure x + , Codec.encode = \x -> do + Monad.void + . Codec.encode ce + . snd + . Identity.runIdentity + . Trans.runWriterT + $ Codec.encode ca x + pure x + , Codec.schema = f p $ Codec.schema ca + } diff --git a/source/library/Argo/Codec/Object.hs b/source/library/Argo/Codec/Object.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Codec/Object.hs @@ -0,0 +1,122 @@ +module Argo.Codec.Object where + +import qualified Argo.Codec.Codec as Codec +import qualified Argo.Codec.List as Codec +import qualified Argo.Codec.Value as Codec +import qualified Argo.Json.Array as Array +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.Object as Object +import qualified Argo.Json.String as String +import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Schema as Schema +import qualified Argo.Type.Permission as Permission +import qualified Argo.Vendor.Text as Text +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified Data.List as List +import qualified Data.Maybe as Maybe + +type Object a + = Codec.List + [(Name.Name, Bool, 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 + ) + ] + ) + $ Codec.map Object.toList Object.fromList Codec.objectCodec + +required :: Name.Name -> Codec.Value a -> Object a +required k c = Codec.Codec + { Codec.decode = do + m <- Codec.decode (optional k c) + case m of + Nothing -> + Trans.lift + . Trans.throwE + $ "missing required member: " + <> show k + Just x -> pure x + , Codec.encode = \x -> do + Monad.void . Codec.encode (optional k c) $ Just x + pure x + , Codec.schema = [(k, True, Codec.schema c)] + } + +optional :: Name.Name -> Codec.Value a -> Object (Maybe a) +optional k c = Codec.Codec + { Codec.decode = do + 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 + Right y -> do + Trans.put ys + pure $ Just y + _ -> pure Nothing + , Codec.encode = \x -> do + case x of + Nothing -> pure () + Just y -> Trans.tell [Member.Member k $ Codec.encodeWith c y] + pure x + , Codec.schema = [(k, False, Codec.schema c)] + } + +tagged :: String -> Codec.Value a -> Codec.Value a +tagged t c = + Codec.map snd ((,) ()) + . fromObjectCodec Permission.Forbid + $ (,) + <$> Codec.project + fst + (required + (Name.fromString . String.fromText $ Text.pack "type") + (Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack t + ) + ) + <*> Codec.project + snd + (required + (Name.fromString . String.fromText $ Text.pack "value") + c + ) diff --git a/source/library/Argo/Codec/Value.hs b/source/library/Argo/Codec/Value.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Codec/Value.hs @@ -0,0 +1,84 @@ +module Argo.Codec.Value where + +import qualified Argo.Codec.Codec as Codec +import qualified Argo.Json.Array as Array +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.Schema as Schema +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 + +decodeWith :: Value a -> Value.Value -> Either String a +decodeWith c = + Identity.runIdentity . Trans.runExceptT . Trans.runReaderT (Codec.decode c) + +encodeWith :: Value a -> a -> Value.Value +encodeWith c x = + snd + . Identity.runIdentity + . Trans.runStateT (Trans.runMaybeT $ Codec.encode c x) + . Value.Null + $ Null.fromUnit () + +type Value a + = Codec.Codec + (Trans.ReaderT Value.Value (Trans.ExceptT String Identity.Identity)) + (Trans.MaybeT (Trans.StateT Value.Value Identity.Identity)) + Schema.Schema + a + a + +arrayCodec :: Value (Array.Array Value.Value) +arrayCodec = Codec.Codec + { Codec.decode = do + x <- Trans.ask + case x of + Value.Array y -> pure y + _ -> + Trans.lift . Trans.throwE $ "expected Array but got " <> show x + , Codec.encode = \x -> do + Trans.lift . Trans.put $ Value.Array x + pure x + , Codec.schema = Schema.false + } + +objectCodec :: Value (Object.Object Value.Value) +objectCodec = Codec.Codec + { Codec.decode = do + x <- Trans.ask + case x of + Value.Object y -> pure y + _ -> + Trans.lift + . Trans.throwE + $ "expected Object but got " + <> show x + , Codec.encode = \x -> do + Trans.lift . Trans.put $ Value.Object x + pure x + , Codec.schema = Schema.false + } + +literalCodec :: Value.Value -> Value () +literalCodec expected = Codec.Codec + { Codec.decode = do + actual <- Trans.ask + Monad.when (actual /= expected) + . Trans.lift + . Trans.throwE + $ "expected " + <> show expected + <> " but got " + <> show actual + , Codec.encode = const . Trans.lift $ Trans.put expected + , Codec.schema = Schema.fromValue . Value.Object $ Object.fromList + [ Member.fromTuple + (Name.fromString . String.fromText $ Text.pack "const", expected) + ] + } diff --git a/source/library/Argo/Json/Array.hs b/source/library/Argo/Json/Array.hs --- a/source/library/Argo/Json/Array.hs +++ b/source/library/Argo/Json/Array.hs @@ -13,17 +13,17 @@ import qualified Argo.Vendor.Transformers as Trans import qualified GHC.Generics as Generics -newtype ArrayOf value +newtype Array value = Array [value] deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) -fromList :: [value] -> ArrayOf value +fromList :: [value] -> Array value fromList = Array -toList :: ArrayOf value -> [value] +toList :: Array value -> [value] toList (Array x) = x -encode :: (value -> Encoder.Encoder ()) -> ArrayOf value -> Encoder.Encoder () +encode :: (value -> Encoder.Encoder ()) -> Array value -> Encoder.Encoder () encode f = Encoder.list (Trans.lift . Trans.tell $ Builder.word8 Literal.leftSquareBracket) @@ -33,7 +33,7 @@ f . toList -decode :: Decoder.Decoder value -> Decoder.Decoder (ArrayOf value) +decode :: Decoder.Decoder value -> Decoder.Decoder (Array value) decode f = do Decoder.word8 Literal.leftSquareBracket Decoder.spaces diff --git a/source/library/Argo/Json/Member.hs b/source/library/Argo/Json/Member.hs --- a/source/library/Argo/Json/Member.hs +++ b/source/library/Argo/Json/Member.hs @@ -16,17 +16,16 @@ import qualified Control.Monad as Monad import qualified GHC.Generics as Generics -data MemberOf value = Member Name.Name value +data Member value = Member Name.Name value deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) -fromTuple :: (Name.Name, value) -> MemberOf value +fromTuple :: (Name.Name, value) -> Member value fromTuple = uncurry Member -toTuple :: MemberOf value -> (Name.Name, value) +toTuple :: Member value -> (Name.Name, value) toTuple (Member k v) = (k, v) -encode - :: (value -> Encoder.Encoder ()) -> MemberOf value -> Encoder.Encoder () +encode :: (value -> Encoder.Encoder ()) -> Member value -> Encoder.Encoder () encode f (Member x y) = do Name.encode x Trans.lift . Trans.tell $ Builder.word8 Literal.colon @@ -37,7 +36,7 @@ $ Builder.word8 Literal.space f y -decode :: Decoder.Decoder value -> Decoder.Decoder (MemberOf value) +decode :: Decoder.Decoder value -> Decoder.Decoder (Member value) decode g = Member <$> Name.decode diff --git a/source/library/Argo/Json/Object.hs b/source/library/Argo/Json/Object.hs --- a/source/library/Argo/Json/Object.hs +++ b/source/library/Argo/Json/Object.hs @@ -15,18 +15,17 @@ import qualified Control.Monad as Monad import qualified GHC.Generics as Generics -newtype ObjectOf value - = Object [Member.MemberOf value] +newtype Object value + = Object [Member.Member value] deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) -fromList :: [Member.MemberOf value] -> ObjectOf value +fromList :: [Member.Member value] -> Object value fromList = Object -toList :: ObjectOf value -> [Member.MemberOf value] +toList :: Object value -> [Member.Member value] toList (Object x) = x -encode - :: (value -> Encoder.Encoder ()) -> ObjectOf value -> Encoder.Encoder () +encode :: (value -> Encoder.Encoder ()) -> Object value -> Encoder.Encoder () encode f = Encoder.list (Trans.lift . Trans.tell $ Builder.word8 Literal.leftCurlyBracket) @@ -38,13 +37,13 @@ encodeElement :: (value -> Encoder.Encoder ()) -> Int - -> Member.MemberOf value + -> Member.Member value -> Encoder.Encoder () encodeElement f i x = do Monad.when (i > 0) . Trans.lift . Trans.tell $ Builder.word8 Literal.comma Member.encode f x -decode :: Decoder.Decoder value -> Decoder.Decoder (ObjectOf value) +decode :: Decoder.Decoder value -> Decoder.Decoder (Object value) decode f = do Decoder.word8 Literal.leftCurlyBracket Decoder.spaces diff --git a/source/library/Argo/Json/Value.hs b/source/library/Argo/Json/Value.hs --- a/source/library/Argo/Json/Value.hs +++ b/source/library/Argo/Json/Value.hs @@ -26,8 +26,8 @@ | Boolean Boolean.Boolean | Number Number.Number | String String.String - | Array (Array.ArrayOf Value) - | Object (Object.ObjectOf Value) + | Array (Array.Array Value) + | Object (Object.Object Value) deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) instance Data.String.IsString Value where diff --git a/source/library/Argo/Main.hs b/source/library/Argo/Main.hs --- a/source/library/Argo/Main.hs +++ b/source/library/Argo/Main.hs @@ -3,9 +3,9 @@ import qualified Argo import qualified Argo.Type.Flag as Flag import qualified Argo.Type.Settings as Settings +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.ByteString as ByteString import qualified Control.Monad as Monad -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Builder as Builder import qualified Data.Version as Version import qualified Paths_argo as This import qualified System.Console.GetOpt as Console diff --git a/source/library/Argo/Pattern.hs b/source/library/Argo/Pattern.hs --- a/source/library/Argo/Pattern.hs +++ b/source/library/Argo/Pattern.hs @@ -29,7 +29,7 @@ pattern Array :: [Value.Value] -> Value.Value pattern Array x = Value.Array (Array.Array x) -pattern Object :: [Member.MemberOf Value.Value] -> Value.Value +pattern Object :: [Member.Member Value.Value] -> Value.Value pattern Object x = Value.Object (Object.Object x) {-# COMPLETE Null, Boolean, Number, String, Array, Object #-} diff --git a/source/library/Argo/Pointer/Pointer.hs b/source/library/Argo/Pointer/Pointer.hs --- a/source/library/Argo/Pointer/Pointer.hs +++ b/source/library/Argo/Pointer/Pointer.hs @@ -62,7 +62,7 @@ _ -> Left "not indexable" evaluate (fromList ts) w -atIndex :: Token.Token -> Array.ArrayOf value -> Either String value +atIndex :: Token.Token -> Array.Array value -> Either String value atIndex t a = do i <- tokenToIndex t case drop i $ Array.toList a of @@ -77,7 +77,7 @@ Just ('0', rest) -> if Text.null rest then pure 0 else Left invalid _ -> maybe (Left invalid) pure . Read.readMaybe $ Text.unpack text -atKey :: Token.Token -> Object.ObjectOf value -> Either String value +atKey :: Token.Token -> Object.Object value -> Either String value atKey t = maybe (Left $ "missing key: " <> show t) (\(Member.Member _ v) -> pure v) . List.find diff --git a/source/library/Argo/QuasiQuoter.hs b/source/library/Argo/QuasiQuoter.hs --- a/source/library/Argo/QuasiQuoter.hs +++ b/source/library/Argo/QuasiQuoter.hs @@ -2,6 +2,7 @@ import qualified Argo.Decode as Decode import qualified Argo.Json.Value as Value +import qualified Argo.Schema.Schema as Schema import qualified Argo.Vendor.TemplateHaskell as TH import qualified Argo.Vendor.Text as Text @@ -10,6 +11,15 @@ { TH.quoteExp = either fail TH.lift . Decode.decodePointer + . Text.encodeUtf8 + . Text.pack + } + +schema :: TH.QuasiQuoter +schema = defaultQuasiQuoter + { TH.quoteExp = + either fail (TH.lift . Schema.fromValue) + . Decode.decode . Text.encodeUtf8 . Text.pack } diff --git a/source/library/Argo/Schema/Schema.hs b/source/library/Argo/Schema/Schema.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Schema/Schema.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Schema.Schema where + +import qualified Argo.Json.Array as Array +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.Object as Object +import qualified Argo.Json.String as String +import qualified Argo.Json.Value as Value +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Text as Text +import qualified GHC.Generics as Generics + +-- | A JSON Schema. +-- +newtype Schema + = Schema Value.Value + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +instance Semigroup Schema where + x <> y = fromValue . Value.Object $ Object.fromList + [ Member.fromTuple + ( Name.fromString . String.fromText $ Text.pack "oneOf" + , Value.Array $ Array.fromList [toValue x, toValue y] + ) + ] + +instance Monoid Schema where + mempty = true + +fromValue :: Value.Value -> Schema +fromValue = Schema + +toValue :: Schema -> Value.Value +toValue (Schema x) = x + +false :: Schema +false = fromValue . Value.Boolean $ Boolean.fromBool False + +true :: Schema +true = fromValue . Value.Boolean $ Boolean.fromBool True diff --git a/source/library/Argo/Type/Codec.hs b/source/library/Argo/Type/Codec.hs deleted file mode 100644 --- a/source/library/Argo/Type/Codec.hs +++ /dev/null @@ -1,252 +0,0 @@ -module Argo.Type.Codec where - -import Control.Applicative ((<|>)) - -import qualified Argo.Json.Array as Array -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.Type.Permission as Permission -import qualified Argo.Vendor.Transformers as Trans -import qualified Control.Applicative as Applicative -import qualified Control.Monad as Monad -import qualified Data.Functor.Identity as Identity -import qualified Data.List as List -import qualified Data.Text as Text - -decodeWith :: ValueCodec a -> Value.Value -> Either String a -decodeWith c = - Identity.runIdentity . Trans.runExceptT . Trans.runReaderT (decode c) - -encodeWith :: ValueCodec a -> a -> Value.Value -encodeWith c x = - snd - . Identity.runIdentity - . Trans.runStateT (Trans.runMaybeT $ encode c x) - . Value.Null - $ Null.fromUnit () - -project :: (i -> f) -> CodecOf r w f o -> CodecOf r w i o -project f c = c { encode = encode c . f } - -data CodecOf r w i o = Codec - { decode :: r o - , encode :: i -> w o - } - -instance (Functor r, Functor w) => Functor (CodecOf r w i) where - fmap f c = Codec { decode = f <$> decode c, encode = fmap f . encode c } - -instance (Applicative r, Applicative w) => Applicative (CodecOf r w i) where - pure x = Codec { decode = pure x, encode = const $ pure x } - cf <*> cx = Codec - { decode = decode cf <*> decode cx - , encode = \i -> encode cf i <*> encode cx i - } - -instance (Applicative.Alternative r, Applicative.Alternative w) => Applicative.Alternative (CodecOf r w i) where - empty = - Codec { decode = Applicative.empty, encode = const Applicative.empty } - cx <|> cy = Codec - { decode = decode cx <|> decode cy - , encode = \i -> encode cx i <|> encode cy i - } - -type Codec r w a = CodecOf r w a a - -dimap - :: (Functor r, Functor w) - => (a -> b) - -> (b -> a) - -> Codec r w a - -> Codec r w b -dimap f g c = - Codec { decode = f <$> decode c, encode = fmap f . encode c . g } - -tap :: Functor f => (a -> f b) -> a -> f a -tap f x = x <$ f x - -type ValueCodec a - = Codec - (Trans.ReaderT Value.Value (Trans.ExceptT String Identity.Identity)) - (Trans.MaybeT (Trans.StateT Value.Value Identity.Identity)) - a - -arrayCodec :: ValueCodec (Array.ArrayOf Value.Value) -arrayCodec = Codec - { decode = do - x <- Trans.ask - case x of - Value.Array y -> pure y - _ -> - Trans.lift . Trans.throwE $ "expected Array but got " <> show x - , encode = \x -> do - Trans.lift . Trans.put $ Value.Array x - pure x - } - -objectCodec :: ValueCodec (Object.ObjectOf Value.Value) -objectCodec = Codec - { decode = do - x <- Trans.ask - case x of - Value.Object y -> pure y - _ -> - Trans.lift - . Trans.throwE - $ "expected Object but got " - <> show x - , encode = \x -> do - Trans.lift . Trans.put $ Value.Object x - pure x - } - -mapMaybe - :: (Applicative.Alternative r, Applicative.Alternative w, Monad r, Monad w) - => (o2 -> Maybe o1) - -> (i1 -> Maybe i2) - -> CodecOf r w i2 o2 - -> CodecOf r w i1 o1 -mapMaybe f g c = Codec - { decode = do - o2 <- decode c - toAlternative $ f o2 - , encode = \ i1 -> do - i2 <- toAlternative $ g i1 - o2 <- encode c i2 - toAlternative $ f o2 - } - -toAlternative :: Applicative.Alternative m => Maybe a -> m a -toAlternative = maybe Applicative.empty pure - -tagged :: String -> ValueCodec a -> ValueCodec a -tagged t c = - dimap snd ((,) ()) - . fromObjectCodec Permission.Allow - $ (,) - <$> project - fst - (required - (Name.fromString . String.fromText $ Text.pack "type") - (literalCodec - (Value.String . String.fromText $ Text.pack t) - ) - ) - <*> project - snd - (required - (Name.fromString . String.fromText $ Text.pack "value") - c - ) - -literalCodec :: Value.Value -> ValueCodec () -literalCodec expected = Codec - { decode = do - actual <- Trans.ask - Monad.when (actual /= expected) - . Trans.lift - . Trans.throwE - $ "expected " - <> show expected - <> " but got " - <> show actual - , encode = const . Trans.lift $ Trans.put expected - } - -type ListCodec e a - = Codec - (Trans.StateT [e] (Trans.ExceptT String Identity.Identity)) - (Trans.WriterT [e] Identity.Identity) - a - -fromListCodec - :: ValueCodec [e] -> Permission.Permission -> ListCodec e a -> ValueCodec a -fromListCodec ce p ca = Codec - { decode = do - xs <- decode ce - case - Identity.runIdentity . Trans.runExceptT $ Trans.runStateT - (decode ca) - xs - of - Left x -> Trans.lift $ Trans.throwE x - Right (x, ys) -> do - case (p, ys) of - (Permission.Forbid, _ : _) -> - Trans.lift $ Trans.throwE "leftover elements" - _ -> pure () - pure x - , encode = \x -> do - Monad.void - . encode ce - . snd - . Identity.runIdentity - . Trans.runWriterT - $ encode ca x - pure x - } - -type ArrayCodec a = ListCodec Value.Value a - -fromArrayCodec :: Permission.Permission -> ArrayCodec a -> ValueCodec a -fromArrayCodec = fromListCodec $ dimap Array.toList Array.fromList arrayCodec - -element :: ValueCodec a -> ArrayCodec a -element c = Codec - { decode = do - l <- Trans.get - case l of - [] -> Trans.lift $ Trans.throwE "unexpected empty list" - h : t -> case decodeWith c h of - Left y -> Trans.lift $ Trans.throwE y - Right y -> do - Trans.put t - pure y - , encode = \x -> do - Trans.tell [encodeWith c x] - pure x - } - -type ObjectCodec a = ListCodec (Member.MemberOf Value.Value) a - -fromObjectCodec :: Permission.Permission -> ObjectCodec a -> ValueCodec a -fromObjectCodec = - fromListCodec $ dimap Object.toList Object.fromList objectCodec - -required :: Name.Name -> ValueCodec a -> ObjectCodec a -required k c = Codec - { decode = do - m <- decode (optional k c) - case m of - Nothing -> - Trans.lift - . Trans.throwE - $ "missing required member: " - <> show k - Just x -> pure x - , encode = \x -> do - Monad.void . encode (optional k c) $ Just x - pure x - } - -optional :: Name.Name -> ValueCodec a -> ObjectCodec (Maybe a) -optional k c = Codec - { decode = do - xs <- Trans.get - case List.partition (\(Member.Member j _) -> j == k) xs of - (Member.Member _ x : _, ys) -> case decodeWith c x of - Left y -> Trans.lift $ Trans.throwE y - Right y -> do - Trans.put ys - pure $ Just y - _ -> pure Nothing - , encode = \x -> do - case x of - Nothing -> pure () - Just y -> Trans.tell [Member.Member k $ encodeWith c y] - pure x - } diff --git a/source/library/Argo/Type/Decimal.hs b/source/library/Argo/Type/Decimal.hs --- a/source/library/Argo/Type/Decimal.hs +++ b/source/library/Argo/Type/Decimal.hs @@ -36,12 +36,14 @@ toInteger (Decimal s e) = if e < 0 then Nothing else Just $ s * 10 ^ e fromRealFloat :: RealFloat a => a -> Maybe Decimal -fromRealFloat x = if isNaN x || isInfinite x then Nothing else - Just - . (if x < 0 then Argo.Type.Decimal.negate else id) - . uncurry fromDigits - . Numeric.floatToDigits 10 - $ abs x +fromRealFloat x = if isNaN x || isInfinite x + then Nothing + else + Just + . (if x < 0 then Argo.Type.Decimal.negate else id) + . uncurry fromDigits + . Numeric.floatToDigits 10 + $ abs x toRealFloat :: RealFloat a => Decimal -> a toRealFloat = Prelude.fromRational . Argo.Type.Decimal.toRational diff --git a/source/library/Argo/Vendor/Builder.hs b/source/library/Argo/Vendor/Builder.hs --- a/source/library/Argo/Vendor/Builder.hs +++ b/source/library/Argo/Vendor/Builder.hs @@ -3,6 +3,7 @@ , Builder.Builder , Builder.byteString , Prim.condB + , Builder.hPutBuilder , Builder.integerDec , Prim.liftFixedToBounded , Builder.toLazyByteString diff --git a/source/library/Argo/Vendor/ByteString.hs b/source/library/Argo/Vendor/ByteString.hs --- a/source/library/Argo/Vendor/ByteString.hs +++ b/source/library/Argo/Vendor/ByteString.hs @@ -6,6 +6,7 @@ , ByteString.elemIndex , ByteString.empty , ByteString.foldl' + , ByteString.getContents , ByteString.length , ByteString.null , ByteString.pack diff --git a/source/test-suite/Argo/Orphanage.hs b/source/test-suite/Argo/Orphanage.hs --- a/source/test-suite/Argo/Orphanage.hs +++ b/source/test-suite/Argo/Orphanage.hs @@ -13,7 +13,7 @@ arbitrary = Argo.Name <$> Tasty.arbitrary shrink (Argo.Name x) = Argo.Name <$> Tasty.shrink x -instance Tasty.Arbitrary value => Tasty.Arbitrary (Argo.MemberOf value) where +instance Tasty.Arbitrary value => Tasty.Arbitrary (Argo.Member value) where arbitrary = Argo.Member <$> Tasty.arbitrary <*> Tasty.arbitrary shrink (Argo.Member k v) = uncurry Argo.Member <$> Tasty.shrink (k, v) 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 @@ -7,599 +7,1002 @@ import Test.Tasty.QuickCheck ((===)) import qualified Argo -import qualified Argo.Type.Codec as Codec -import qualified Argo.Type.Permission as Permission -import qualified Argo.Json.String as String -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.Int as Int -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import qualified Data.Word as Word -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.HUnit as Tasty -import qualified Test.Tasty.QuickCheck as Tasty - -main :: IO () -main = Tasty.defaultMain $ Tasty.testGroup "Argo" - [ Tasty.testGroup "encode" $ let encode = Builder.toLazyByteString . Argo.encode :: Argo.Value -> LazyByteString.ByteString in - [ Tasty.testGroup "Null" - [ Tasty.testCase "null" $ do - encode Argo.Null @?= "null" - ] - , Tasty.testGroup "Boolean" - [ Tasty.testCase "false" $ do - encode (Argo.Boolean False) @?= "false" - , Tasty.testCase "true" $ do - encode (Argo.Boolean True) @?= "true" - ] - , Tasty.testGroup "Number" - [ Tasty.testCase "zero" $ do - encode (number 0 0) @?= "0" - , Tasty.testCase "positive integer" $ do - encode (number 1 0) @?= "1" - , Tasty.testCase "negative integer" $ do - encode (number (-1) 0) @?= "-1" - , Tasty.testCase "positive exponent" $ do - encode (number 1 1) @?= "1e1" - , Tasty.testCase "negative exponent" $ do - encode (number 1 (-1)) @?= "1e-1" - , Tasty.testCase "multiple integer digits" $ do - encode (number 12 0) @?= "12" - , Tasty.testCase "multiple exponent digits" $ do - encode (number 1 12) @?= "1e12" - ] - , Tasty.testGroup "String" - [ Tasty.testCase "empty" $ do - encode (Argo.String "") @?= "\"\"" - , Tasty.testCase "one character" $ do - encode (Argo.String "a") @?= "\"a\"" - , Tasty.testCase "multiple characters" $ do - encode (Argo.String "ab") @?= "\"ab\"" - , Tasty.testCase "quotation mark" $ do - encode (Argo.String "\"") @?= "\"\\\"\"" - , Tasty.testCase "reverse solidus" $ do - encode (Argo.String "\\") @?= "\"\\\\\"" - , Tasty.testCase "backspace" $ do - encode (Argo.String "\b") @?= "\"\\b\"" - , Tasty.testCase "form feed" $ do - encode (Argo.String "\f") @?= "\"\\f\"" - , Tasty.testCase "new line" $ do - encode (Argo.String "\n") @?= "\"\\n\"" - , Tasty.testCase "carriage return" $ do - encode (Argo.String "\r") @?= "\"\\r\"" - , Tasty.testCase "horizontal tabulation" $ do - encode (Argo.String "\t") @?= "\"\\t\"" - , Tasty.testCase "null" $ do - encode (Argo.String "\x0") @?= "\"\\u0000\"" - , Tasty.testCase "unit separator" $ do - encode (Argo.String "\x1f") @?= "\"\\u001f\"" - , Tasty.testCase "one byte" $ do - encode (Argo.String "$") @?= "\"$\"" - , Tasty.testCase "two bytes" $ do - encode (Argo.String "\xa2") @?= "\"\xc2\xa2\"" - , Tasty.testCase "three bytes" $ do - encode (Argo.String "\x20ac") @?= "\"\xe2\x82\xac\"" - , Tasty.testCase "four bytes" $ do - encode (Argo.String "\x10348") @?= "\"\xf0\x90\x8d\x88\"" - ] - , Tasty.testGroup "Array" - [ Tasty.testCase "empty" $ do - encode (Argo.Array []) @?= "[]" - , Tasty.testCase "one element" $ do - encode (Argo.Array [number 1 0]) @?= "[1]" - , Tasty.testCase "two elements" $ do - encode (Argo.Array [number 1 0, number 2 0]) @?= "[1,2]" - ] - , Tasty.testGroup "Object" - [ Tasty.testCase "empty" $ do - encode (Argo.Object []) @?= "{}" - , Tasty.testCase "one element" $ do - encode (Argo.Object [Argo.Member (Argo.Name "a") $ number 1 0]) @?= "{\"a\":1}" - , Tasty.testCase "two elements" $ do - encode (Argo.Object [Argo.Member (Argo.Name "a") $ number 1 0, Argo.Member (Argo.Name "b") $ number 2 0]) @?= "{\"a\":1,\"b\":2}" - ] - ] - , Tasty.testGroup "decode" $ let decode = hush . Argo.decode :: ByteString.ByteString -> Maybe Argo.Value in - [ Tasty.testGroup "Null" - [ Tasty.testCase "null" $ do - decode "null" @?= Just Argo.Null - , Tasty.testCase "leading space" $ do - decode " null" @?= Just Argo.Null - , Tasty.testCase "trailing space" $ do - decode "null " @?= Just Argo.Null - , Tasty.testCase "trailing new line" $ do - decode "null\n" @?= Just Argo.Null - , Tasty.testCase "trailing carriage return" $ do - decode "null\r" @?= Just Argo.Null - , Tasty.testCase "trailing horizontal tab" $ do - decode "null\t" @?= Just Argo.Null - ] - , Tasty.testGroup "Boolean" - [ Tasty.testCase "false" $ do - decode "false" @?= Just (Argo.Boolean False) - , Tasty.testCase "true" $ do - decode "true" @?= Just (Argo.Boolean True) - ] - , Tasty.testGroup "Number" - [ Tasty.testCase "zero" $ do - decode "0" @?= Just (number 0 0) - , Tasty.testCase "negative zero" $ do - decode "-0" @?= Just (number 0 0) - , Tasty.testCase "positive integer" $ do - decode "1" @?= Just (number 1 0) - , Tasty.testCase "multiple integer digits" $ do - decode "12" @?= Just (number 12 0) - , Tasty.testCase "negative integer" $ do - decode "-1" @?= Just (number (-1) 0) - , Tasty.testCase "fraction" $ do - decode "0.1" @?= Just (number 1 (-1)) - , Tasty.testCase "multiple fraction digits" $ do - decode "0.12" @?= Just (number 12 (-2)) - , Tasty.testCase "leading zero fraction" $ do - decode "0.01" @?= Just (number 1 (-2)) - , Tasty.testCase "positive exponent" $ do - decode "1e1" @?= Just (number 1 1) - , Tasty.testCase "capital exponent" $ do - decode "1E1" @?= Just (number 1 1) - , Tasty.testCase "leading zero exponent" $ do - decode "1e01" @?= Just (number 1 1) - , Tasty.testCase "explicit positive exponent" $ do - decode "1e+1" @?= Just (number 1 1) - , Tasty.testCase "negative exponent" $ do - decode "1e-1" @?= Just (number 1 (-1)) - , Tasty.testCase "multiple exponent digits" $ do - decode "1e12" @?= Just (number 1 12) - , Tasty.testCase "kitchen sink" $ do - decode "12.34e56" @?= Just (number 1234 54) - , Tasty.testCase "normalized" $ do - decode "10" @?= Just (number 1 1) - , Tasty.testCase "leading zero" $ do - decode "01" @?= Nothing - , Tasty.testCase "trailing fraction" $ do - decode "1." @?= Nothing - , Tasty.testCase "leading fraction" $ do - decode ".1" @?= Nothing - , Tasty.testCase "trailing exponent" $ do - decode "1e" @?= Nothing - , Tasty.testCase "leading exponent" $ do - decode "e1" @?= Nothing - ] - , Tasty.testGroup "String" - [ Tasty.testCase "empty" $ do - decode "\"\"" @?= Just (Argo.String "") - , Tasty.testCase "one character" $ do - decode "\"a\"" @?= Just (Argo.String "a") - , Tasty.testCase "multiple characters" $ do - decode "\"ab\"" @?= Just (Argo.String "ab") - , Tasty.testCase "unnecessary escape" $ do - decode "\"\\u0020\"" @?= Just (Argo.String " ") - , Tasty.testCase "quotation mark" $ do - decode "\"\\\"\"" @?= Just (Argo.String "\"") - , Tasty.testCase "reverse solidus" $ do - decode "\"\\\\\"" @?= Just (Argo.String "\\") - , Tasty.testCase "solidus" $ do - decode "\"\\/\"" @?= Just (Argo.String "/") - , Tasty.testCase "backspace" $ do - decode "\"\\b\"" @?= Just (Argo.String "\b") - , Tasty.testCase "form feed" $ do - decode "\"\\f\"" @?= Just (Argo.String "\f") - , Tasty.testCase "new line" $ do - decode "\"\\n\"" @?= Just (Argo.String "\n") - , Tasty.testCase "carriage return" $ do - decode "\"\\r\"" @?= Just (Argo.String "\r") - , Tasty.testCase "horizontal tabulation" $ do - decode "\"\\t\"" @?= Just (Argo.String "\t") - , Tasty.testCase "null" $ do - decode "\"\\u0000\"" @?= Just (Argo.String "\x0") - , Tasty.testCase "unit separator" $ do - decode "\"\\u001f\"" @?= Just (Argo.String "\x1f") - , Tasty.testCase "capital long escape" $ do - decode "\"\\u001F\"" @?= Just (Argo.String "\x1f") - , Tasty.testCase "digits after long escape" $ do - decode "\"\\u00205\"" @?= Just (Argo.String " 5") - , Tasty.testCase "one byte" $ do - decode "\"$\"" @?= Just (Argo.String "$") - , Tasty.testCase "one byte escaped" $ do - decode "\"\\u0024\"" @?= Just (Argo.String "$") - , Tasty.testCase "two bytes" $ do - decode "\"\xc2\xa2\"" @?= Just (Argo.String "\xa2") - , Tasty.testCase "two bytes escaped" $ do - decode "\"\\u00a2\"" @?= Just (Argo.String "\xa2") - , Tasty.testCase "three bytes" $ do - decode "\"\xe2\x82\xac\"" @?= Just (Argo.String "\x20ac") - , Tasty.testCase "three bytes escaped" $ do - decode "\"\\u20ac\"" @?= Just (Argo.String "\x20ac") - , Tasty.testCase "four bytes" $ do - decode "\"\xf0\x90\x8d\x88\"" @?= Just (Argo.String "\x10348") - , Tasty.testCase "surrogate pair" $ do - decode "\"\\ud834\\udd1e\"" @?= Just (Argo.String "\x1d11e") - , Tasty.testCase "unpaired high surrogate" $ do - decode "\"\\ud800\"" @?= Just (Argo.String "\xfffd") - , Tasty.testCase "unpaired low surrogate" $ do - decode "\"\\udc00\"" @?= Just (Argo.String "\xfffd") - , Tasty.testCase "delete" $ do - decode "\"\x7f\"" @?= Just (Argo.String "\x7f") - , Tasty.testCase "invalid short escape" $ do - decode "\"\\z\"" @?= Nothing - , Tasty.testCase "capital short escape" $ do - decode "\"\\T\"" @?= Nothing - , Tasty.testCase "invalid long escape" $ do - decode "\"\\uwxyz\"" @?= Nothing - , Tasty.testCase "incomplete long escape" $ do - decode "\"\\u00\"" @?= Nothing - , Tasty.testCase "unescaped control character" $ do - decode "\"\n\"" @?= Nothing - , Tasty.testCase "unterminated" $ do - decode "\"" @?= Nothing - , Tasty.testCase "invalid UTF-8 byte" $ do - decode "\"\xff\"" @?= Nothing - ] - , Tasty.testGroup "Array" - [ Tasty.testCase "empty" $ do - decode "[]" @?= Just (Argo.Array []) - , Tasty.testCase "one element" $ do - decode "[1]" @?= Just (Argo.Array [number 1 0]) - , Tasty.testCase "two elements" $ do - decode "[1,2]" @?= Just (Argo.Array [number 1 0, number 2 0]) - , Tasty.testCase "nested" $ do - decode "[1,[2]]" @?= Just (Argo.Array [number 1 0, Argo.Array [number 2 0]]) - , Tasty.testCase "not closed" $ do - decode "[" @?= Nothing - , Tasty.testCase "not opened" $ do - decode "]" @?= Nothing - , Tasty.testCase "leading comma" $ do - decode "[,1]" @?= Nothing - , Tasty.testCase "trailing comma" $ do - decode "[1,]" @?= Nothing - , Tasty.testCase "consecutive commas" $ do - decode "[1,,2]" @?= Nothing - , Tasty.testCase "like an object" $ do - decode "[\"a\":1]" @?= Nothing - ] - , Tasty.testGroup "Object" - [ Tasty.testCase "empty" $ do - decode "{}" @?= Just (Argo.Object []) - , Tasty.testCase "one element" $ do - decode "{\"a\":1}" @?= Just (Argo.Object [Argo.Member (Argo.Name "a") $ number 1 0]) - , Tasty.testCase "two elements" $ do - decode "{\"a\":1,\"b\":2}" @?= Just (Argo.Object [Argo.Member (Argo.Name "a") $ number 1 0, Argo.Member (Argo.Name "b") $ number 2 0]) - , Tasty.testCase "nested" $ do - decode "{\"a\":{\"b\":2}}" @?= Just (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Object [Argo.Member (Argo.Name "b") $ number 2 0]]) - , Tasty.testCase "not closed" $ do - decode "{" @?= Nothing - , Tasty.testCase "not opened" $ do - decode "}" @?= Nothing - , Tasty.testCase "leading comma" $ do - decode "{,\"a\":1}" @?= Nothing - , Tasty.testCase "trailing comma" $ do - decode "{\"a\":1,}" @?= Nothing - , Tasty.testCase "consecutive commas" $ do - decode "{\"a\":1,,\"b\":2}" @?= Nothing - , Tasty.testCase "missing key" $ do - decode "{:1}" @?= Nothing - , Tasty.testCase "missing value" $ do - decode "{\"a\":}" @?= Nothing - , Tasty.testCase "missing separator" $ do - decode "{\"a\"1}" @?= Nothing - , Tasty.testCase "duplicate separator" $ do - decode "{\"a\"::1}" @?= Nothing - , Tasty.testCase "like an array" $ do - decode "{1}" @?= Nothing - , Tasty.testCase "non-string key" $ do - decode "{1:2}" @?= Nothing - ] - ] - , Tasty.testGroup "fromValue" - [ Tasty.testCase "Value" $ do - Argo.fromValue Argo.Null @?= Right Argo.Null - , Tasty.testCase "Bool" $ do - Argo.fromValue (Argo.Boolean False) @?= Right False - , Tasty.testCase "Char" $ do - Argo.fromValue (Argo.String "a") @?= Right 'a' - , Tasty.testCase "Int" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int) - , Tasty.testCase "Int8" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int8) - , Tasty.testCase "Int16" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int16) - , Tasty.testCase "Int32" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int32) - , Tasty.testCase "Int64" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int64) - , Tasty.testCase "Word" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word) - , Tasty.testCase "Word8" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word8) - , Tasty.testCase "Word16" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word16) - , Tasty.testCase "Word32" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word32) - , Tasty.testCase "Word64" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word64) - , Tasty.testCase "Integer" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Integer) - , Tasty.testCase "Float" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Float) - , Tasty.testCase "Double" $ do - Argo.fromValue (number 0 0) @?= Right (0 :: Double) - , Tasty.testCase "String" $ do - Argo.fromValue (Argo.String "") @?= Right ("" :: String) - , Tasty.testCase "Text" $ do - Argo.fromValue (Argo.String "") @?= Right ("" :: Text.Text) - , Tasty.testCase "LazyText" $ do - Argo.fromValue (Argo.String "") @?= Right ("" :: LazyText.Text) - , Tasty.testCase "Maybe a" $ do - Argo.fromValue (Argo.Boolean False) @?= Right (Just False) - , Tasty.testCase "()" $ do - Argo.fromValue (Argo.Array []) @?= Right () - , Tasty.testCase "(a, b)" $ do - Argo.fromValue (Argo.Array [Argo.Boolean False, Argo.String "a"]) @?= Right (False, 'a') - , Tasty.testCase "[a]" $ do - Argo.fromValue (Argo.Array []) @?= Right ([] :: [Bool]) - , Tasty.testCase "NonEmpty a" $ do - Argo.fromValue (Argo.Array [Argo.Boolean False]) @?= Right (False :| []) - , Tasty.testCase "Map Name a" $ do - Argo.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 []) - ] - , Tasty.testGroup "toValue" - [ Tasty.testCase "Value" $ do - Argo.toValue Argo.Null @?= Argo.Null - , Tasty.testCase "Bool" $ do - Argo.toValue False @?= Argo.Boolean False - , Tasty.testCase "Char" $ do - Argo.toValue 'a' @?= Argo.String "a" - , Tasty.testCase "Int" $ do - Argo.toValue (0 :: Int) @?= number 0 0 - , Tasty.testCase "Int8" $ do - Argo.toValue (0 :: Int.Int8) @?= number 0 0 - , Tasty.testCase "Int16" $ do - Argo.toValue (0 :: Int.Int16) @?= number 0 0 - , Tasty.testCase "Int32" $ do - Argo.toValue (0 :: Int.Int32) @?= number 0 0 - , Tasty.testCase "Int64" $ do - Argo.toValue (0 :: Int.Int64) @?= number 0 0 - , Tasty.testCase "Word" $ do - Argo.toValue (0 :: Word) @?= number 0 0 - , Tasty.testCase "Word8" $ do - Argo.toValue (0 :: Word.Word8) @?= number 0 0 - , Tasty.testCase "Word16" $ do - Argo.toValue (0 :: Word.Word16) @?= number 0 0 - , Tasty.testCase "Word32" $ do - Argo.toValue (0 :: Word.Word32) @?= number 0 0 - , Tasty.testCase "Word64" $ do - Argo.toValue (0 :: Word.Word64) @?= number 0 0 - , Tasty.testCase "Integer" $ do - Argo.toValue (0 :: Integer) @?= number 0 0 - , Tasty.testCase "Float" $ do - Argo.toValue (0 :: Float) @?= number 0 0 - , Tasty.testCase "Double" $ do - Argo.toValue (0 :: Double) @?= number 0 0 - , Tasty.testCase "String" $ do - Argo.toValue ("" :: String) @?= Argo.String "" - , Tasty.testCase "Text" $ do - Argo.toValue ("" :: Text.Text) @?= Argo.String "" - , Tasty.testCase "LazyText" $ do - Argo.toValue ("" :: LazyText.Text) @?= Argo.String "" - , Tasty.testCase "Maybe a" $ do - Argo.toValue (Just False) @?= Argo.Boolean False - , Tasty.testCase "()" $ do - Argo.toValue () @?= Argo.Array [] - , Tasty.testCase "(a, b)" $ do - Argo.toValue (False, 'a') @?= Argo.Array [Argo.Boolean False, Argo.String "a"] - , Tasty.testCase "[a]" $ do - Argo.toValue ([] :: [Bool]) @?= Argo.Array [] - , Tasty.testCase "NonEmpty a" $ do - Argo.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] - , Tasty.testCase "Pointer" $ do - Argo.toValue (Argo.Pointer []) @?= Argo.String "" - ] - , Tasty.testGroup "quasi quoter" - [ Tasty.testCase "Null" $ do - [Argo.value| null |] @?= Argo.Null - , Tasty.testCase "Boolean" $ do - [Argo.value| false |] @?= Argo.Boolean False - , Tasty.testCase "Number" $ do - [Argo.value| 0 |] @?= number 0 0 - , Tasty.testCase "String" $ do - [Argo.value| "" |] @?= Argo.String "" - , Tasty.testCase "Array" $ do - [Argo.value| [] |] @?= Argo.Array [] - , Tasty.testCase "Object" $ do - [Argo.value| {} |] @?= Argo.Object [] - ] - , Tasty.testGroup "property" - [ property "decode . encode" $ \ x -> - (Argo.decode . LazyByteString.toStrict . Builder.toLazyByteString $ Argo.encode x) === Right (x :: Argo.Value) - , property "decode . encodeWith" $ \ x -> - (Argo.decode . LazyByteString.toStrict . Builder.toLazyByteString $ Argo.encodeWith Argo.Tab x) === 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 "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) - , property "Word16" $ \ x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Word.Word16) - , property "Word32" $ \ x -> - Argo.fromValue (Argo.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) - , property "Float" $ \ x -> - Argo.fromValue (Argo.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 - 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 "[a]" $ \ x -> - Argo.fromValue (Argo.toValue x) === Right (x :: [Bool]) - , property "NonEmpty a" $ \ x -> - Argo.fromValue (Argo.toValue x) === Right (x :: NonEmpty Bool) - , property "Map Name a" $ \ x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Map.Map Argo.Name Bool) - , property "Pointer" $ \ x -> - Argo.fromValue (Argo.toValue x) === Right (x :: Argo.Pointer) - ] - ] - , Tasty.testGroup "Codec" - [ Tasty.testCase "encode text" $ do - Codec.encodeWith Argo.codec ("" :: Text.Text) @?= Argo.String "" - , Tasty.testCase "decode text" $ do - Codec.decodeWith Argo.codec (Argo.String "") @?= Right ("" :: Text.Text) - , Tasty.testCase "encode bool" $ do - Codec.encodeWith Argo.codec False @?= Argo.Boolean False - , Tasty.testCase "decode bool" $ do - Codec.decodeWith Argo.codec (Argo.Boolean False) @?= Right False - , Tasty.testCase "encode maybe bool" $ do - Codec.encodeWith Argo.codec (Nothing :: Maybe Bool) @?= Argo.Null - Codec.encodeWith Argo.codec (Just False) @?= Argo.Boolean False - , Tasty.testCase "decode maybe bool" $ do - Codec.decodeWith Argo.codec Argo.Null @?= Right (Nothing :: Maybe Bool) - Codec.decodeWith Argo.codec (Argo.Boolean False) @?= Right (Just False) - , Tasty.testCase "encode either text bool" $ do - Codec.encodeWith Argo.codec (Left "" :: Either Text.Text Bool) @?= Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Left", Argo.Member (Argo.Name "value") $ Argo.String ""] - Codec.encodeWith Argo.codec (Right False :: Either Text.Text Bool) @?= Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Right", Argo.Member (Argo.Name "value") $ Argo.Boolean False] - , Tasty.testCase "decode either text bool" $ do - Codec.decodeWith Argo.codec (Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Left", Argo.Member (Argo.Name "value") $ Argo.String ""]) @?= Right (Left "" :: Either Text.Text Bool) - Codec.decodeWith Argo.codec (Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Right", Argo.Member (Argo.Name "value") $ Argo.Boolean False]) @?= Right (Right False :: Either Text.Text Bool) - , Tasty.testCase "encode tuple text bool" $ do - Codec.encodeWith Argo.codec ("" :: Text.Text, False) @?= Argo.Array [Argo.String "", Argo.Boolean False] - , Tasty.testCase "decode tuple text bool" $ do - Codec.decodeWith Argo.codec (Argo.Array [Argo.String "", Argo.Boolean False]) @?= Right ("" :: Text.Text, False) - , Tasty.testCase "encode record" $ do - Codec.encodeWith Argo.codec (Record False Nothing) @?= Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False] - Codec.encodeWith Argo.codec (Record False $ Just "") @?= Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False, Argo.Member (Argo.Name "text") $ Argo.String ""] - , Tasty.testCase "decode record" $ do - Codec.decodeWith Argo.codec (Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False]) @?= Right (Record False Nothing) - Codec.decodeWith Argo.codec (Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False, Argo.Member (Argo.Name "text") $ Argo.String ""]) @?= Right (Record False $ Just "") - ] - , Tasty.testGroup "Pointer" - $ let pointer = Argo.Pointer . fmap Argo.Token in - [ Tasty.testCase "decode" $ do - let decode = hush . Argo.decodePointer - decode "" @?= Just (pointer []) - decode "/" @?= Just (pointer [""]) - decode "/a" @?= Just (pointer ["a"]) - decode "/a/b" @?= Just (pointer ["a", "b"]) - decode "/ab" @?= Just (pointer ["ab"]) - decode "/~0" @?= Just (pointer ["~"]) - decode "/~1" @?= Just (pointer ["/"]) - decode "/~01" @?= Just (pointer ["~1"]) - decode "a" @?= Nothing - decode "/~2" @?= Nothing - , Tasty.testCase "encode" $ do - let encode = Builder.toLazyByteString . Argo.encodePointer - encode (pointer []) @?= "" - encode (pointer [""]) @?= "/" - encode (pointer ["a"]) @?= "/a" - encode (pointer ["a", "b"]) @?= "/a/b" - encode (pointer ["ab"]) @?= "/ab" - encode (pointer ["~"]) @?= "/~0" - encode (pointer ["/"]) @?= "/~1" - encode (pointer ["~1"]) @?= "/~01" - , property "decode . encode" $ \ x -> - (Argo.decodePointer . LazyByteString.toStrict . Builder.toLazyByteString $ Argo.encodePointer x) === Right (x :: Argo.Pointer) - , Tasty.testCase "quasi-quoter" $ do - [Argo.pointer||] @?= pointer [] - [Argo.pointer|/|] @?= pointer [""] - [Argo.pointer|/a|] @?= pointer ["a"] - [Argo.pointer|/a/b|] @?= pointer ["a", "b"] - , Tasty.testCase "evaluate" $ do - let evaluate p = hush . Argo.evaluate p - evaluate (pointer []) Argo.Null @?= Just Argo.Null - evaluate (pointer ["a"]) (Argo.Object [Argo.Member (Argo.Name "a") Argo.Null]) @?= Just Argo.Null - evaluate (pointer ["a", "b"]) (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Object [Argo.Member (Argo.Name "b") Argo.Null]]) @?= Just Argo.Null - evaluate (pointer ["0"]) (Argo.Object [Argo.Member (Argo.Name "0") Argo.Null]) @?= Just Argo.Null - evaluate (pointer ["0"]) (Argo.Array [Argo.Null]) @?= Just Argo.Null - evaluate (pointer ["0", "1"]) (Argo.Array [Argo.Array [Argo.Boolean False, Argo.Null]]) @?= Just Argo.Null - evaluate (pointer ["a"]) Argo.Null @?= Nothing - evaluate (pointer ["a"]) (Argo.Object []) @?= Nothing - evaluate (pointer ["a"]) (Argo.Array [Argo.Null]) @?= Nothing - evaluate (pointer ["0"]) (Argo.Array []) @?= Nothing - evaluate (pointer ["-"]) (Argo.Array []) @?= Nothing - evaluate (pointer ["00"]) (Argo.Array [Argo.Null]) @?= Nothing - ] - , Tasty.testGroup "OverloadedStrings" - [ Tasty.testCase "Value" $ do - "" @?= Argo.String "" - , Tasty.testCase "String" $ do - "" @?= String.String "" - , Tasty.testCase "Name" $ do - "" @?= Argo.Name "" - , Tasty.testCase "Token" $ do - "" @?= Argo.Token "" - ] - ] - -number :: Integer -> Integer -> Argo.Value -number s = Argo.Number . Argo.Decimal s - -data Record = Record - { recordBool :: Bool - , recordText :: Maybe Text.Text - } deriving (Eq, Show) - -instance Argo.HasCodec Record where - codec = Codec.fromObjectCodec Permission.Allow $ Record - <$> Codec.project recordBool (Codec.required (Argo.Name "bool") Argo.codec) - <*> Codec.project recordText (Codec.optional (Argo.Name "text") Argo.codec) - -property - :: (Show t, Tasty.Testable prop, Tasty.Arbitrary t) - => Tasty.TestName - -> (t -> prop) - -> Tasty.TestTree -property n = propertyWith n Tasty.arbitrary Tasty.shrink - -propertyWith - :: (Show t, Tasty.Testable prop) - => Tasty.TestName - -> Tasty.Gen t - -> (t -> [t]) - -> (t -> prop) - -> Tasty.TestTree -propertyWith n g s f = Tasty.testProperty n - . Tasty.forAll g - $ \ x -> Tasty.shrinking s x f +import qualified Argo.Codec.Codec as Codec +import qualified Argo.Codec.Object as Codec +import qualified Argo.Codec.Value as Codec +import qualified Argo.Json.Array as Array +import qualified Argo.Json.Boolean as Boolean +import qualified Argo.Json.Name as Name +import qualified Argo.Json.Null as Null +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.Schema as Schema +import qualified Argo.Type.Decimal as Decimal +import qualified Argo.Type.Permission as Permission +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Int as Int +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Word as Word +import qualified Numeric.Natural as Natural +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty +import qualified Test.Tasty.QuickCheck as Tasty + +main :: IO () +main = Tasty.defaultMain $ Tasty.testGroup + "Argo" + [ Tasty.testGroup "encode" + $ let + encode = + Builder.toLazyByteString . Argo.encode :: Argo.Value + -> LazyByteString.ByteString + in + [ Tasty.testGroup + "Null" + [ Tasty.testCase "null" $ do + encode Argo.Null @?= "null" + ] + , Tasty.testGroup + "Boolean" + [ Tasty.testCase "false" $ do + encode (Argo.Boolean False) @?= "false" + , Tasty.testCase "true" $ do + encode (Argo.Boolean True) @?= "true" + ] + , Tasty.testGroup + "Number" + [ Tasty.testCase "zero" $ do + encode (number 0 0) @?= "0" + , Tasty.testCase "positive integer" $ do + encode (number 1 0) @?= "1" + , Tasty.testCase "negative integer" $ do + encode (number (-1) 0) @?= "-1" + , Tasty.testCase "positive exponent" $ do + encode (number 1 1) @?= "1e1" + , Tasty.testCase "negative exponent" $ do + encode (number 1 (-1)) @?= "1e-1" + , Tasty.testCase "multiple integer digits" $ do + encode (number 12 0) @?= "12" + , Tasty.testCase "multiple exponent digits" $ do + encode (number 1 12) @?= "1e12" + ] + , Tasty.testGroup + "String" + [ Tasty.testCase "empty" $ do + encode (Argo.String "") @?= "\"\"" + , Tasty.testCase "one character" $ do + encode (Argo.String "a") @?= "\"a\"" + , Tasty.testCase "multiple characters" $ do + encode (Argo.String "ab") @?= "\"ab\"" + , Tasty.testCase "quotation mark" $ do + encode (Argo.String "\"") @?= "\"\\\"\"" + , Tasty.testCase "reverse solidus" $ do + encode (Argo.String "\\") @?= "\"\\\\\"" + , Tasty.testCase "backspace" $ do + encode (Argo.String "\b") @?= "\"\\b\"" + , Tasty.testCase "form feed" $ do + encode (Argo.String "\f") @?= "\"\\f\"" + , Tasty.testCase "new line" $ do + encode (Argo.String "\n") @?= "\"\\n\"" + , Tasty.testCase "carriage return" $ do + encode (Argo.String "\r") @?= "\"\\r\"" + , Tasty.testCase "horizontal tabulation" $ do + encode (Argo.String "\t") @?= "\"\\t\"" + , Tasty.testCase "null" $ do + encode (Argo.String "\x0") @?= "\"\\u0000\"" + , Tasty.testCase "unit separator" $ do + encode (Argo.String "\x1f") @?= "\"\\u001f\"" + , Tasty.testCase "one byte" $ do + encode (Argo.String "$") @?= "\"$\"" + , Tasty.testCase "two bytes" $ do + encode (Argo.String "\xa2") @?= "\"\xc2\xa2\"" + , Tasty.testCase "three bytes" $ do + encode (Argo.String "\x20ac") @?= "\"\xe2\x82\xac\"" + , Tasty.testCase "four bytes" $ do + encode (Argo.String "\x10348") @?= "\"\xf0\x90\x8d\x88\"" + ] + , Tasty.testGroup + "Array" + [ Tasty.testCase "empty" $ do + encode (Argo.Array []) @?= "[]" + , Tasty.testCase "one element" $ do + encode (Argo.Array [number 1 0]) @?= "[1]" + , Tasty.testCase "two elements" $ do + encode (Argo.Array [number 1 0, number 2 0]) @?= "[1,2]" + ] + , Tasty.testGroup + "Object" + [ Tasty.testCase "empty" $ do + encode (Argo.Object []) @?= "{}" + , Tasty.testCase "one element" $ do + encode + (Argo.Object + [Argo.Member (Argo.Name "a") $ number 1 0] + ) + @?= "{\"a\":1}" + , Tasty.testCase "two elements" $ do + encode + (Argo.Object + [ Argo.Member (Argo.Name "a") $ number 1 0 + , Argo.Member (Argo.Name "b") $ number 2 0 + ] + ) + @?= "{\"a\":1,\"b\":2}" + ] + ] + , Tasty.testGroup "decode" + $ let + decode = + hush . Argo.decode :: ByteString.ByteString + -> Maybe Argo.Value + in + [ Tasty.testGroup + "Null" + [ Tasty.testCase "null" $ do + decode "null" @?= Just Argo.Null + , Tasty.testCase "leading space" $ do + decode " null" @?= Just Argo.Null + , Tasty.testCase "trailing space" $ do + decode "null " @?= Just Argo.Null + , Tasty.testCase "trailing new line" $ do + decode "null\n" @?= Just Argo.Null + , Tasty.testCase "trailing carriage return" $ do + decode "null\r" @?= Just Argo.Null + , Tasty.testCase "trailing horizontal tab" $ do + decode "null\t" @?= Just Argo.Null + ] + , Tasty.testGroup + "Boolean" + [ Tasty.testCase "false" $ do + decode "false" @?= Just (Argo.Boolean False) + , Tasty.testCase "true" $ do + decode "true" @?= Just (Argo.Boolean True) + ] + , Tasty.testGroup + "Number" + [ Tasty.testCase "zero" $ do + decode "0" @?= Just (number 0 0) + , Tasty.testCase "negative zero" $ do + decode "-0" @?= Just (number 0 0) + , Tasty.testCase "positive integer" $ do + decode "1" @?= Just (number 1 0) + , Tasty.testCase "multiple integer digits" $ do + decode "12" @?= Just (number 12 0) + , Tasty.testCase "negative integer" $ do + decode "-1" @?= Just (number (-1) 0) + , Tasty.testCase "fraction" $ do + decode "0.1" @?= Just (number 1 (-1)) + , Tasty.testCase "multiple fraction digits" $ do + decode "0.12" @?= Just (number 12 (-2)) + , Tasty.testCase "leading zero fraction" $ do + decode "0.01" @?= Just (number 1 (-2)) + , Tasty.testCase "positive exponent" $ do + decode "1e1" @?= Just (number 1 1) + , Tasty.testCase "capital exponent" $ do + decode "1E1" @?= Just (number 1 1) + , Tasty.testCase "leading zero exponent" $ do + decode "1e01" @?= Just (number 1 1) + , Tasty.testCase "explicit positive exponent" $ do + decode "1e+1" @?= Just (number 1 1) + , Tasty.testCase "negative exponent" $ do + decode "1e-1" @?= Just (number 1 (-1)) + , Tasty.testCase "multiple exponent digits" $ do + decode "1e12" @?= Just (number 1 12) + , Tasty.testCase "kitchen sink" $ do + decode "12.34e56" @?= Just (number 1234 54) + , Tasty.testCase "normalized" $ do + decode "10" @?= Just (number 1 1) + , Tasty.testCase "leading zero" $ do + decode "01" @?= Nothing + , Tasty.testCase "trailing fraction" $ do + decode "1." @?= Nothing + , Tasty.testCase "leading fraction" $ do + decode ".1" @?= Nothing + , Tasty.testCase "trailing exponent" $ do + decode "1e" @?= Nothing + , Tasty.testCase "leading exponent" $ do + decode "e1" @?= Nothing + ] + , Tasty.testGroup + "String" + [ Tasty.testCase "empty" $ do + decode "\"\"" @?= Just (Argo.String "") + , Tasty.testCase "one character" $ do + decode "\"a\"" @?= Just (Argo.String "a") + , Tasty.testCase "multiple characters" $ do + decode "\"ab\"" @?= Just (Argo.String "ab") + , Tasty.testCase "unnecessary escape" $ do + decode "\"\\u0020\"" @?= Just (Argo.String " ") + , Tasty.testCase "quotation mark" $ do + decode "\"\\\"\"" @?= Just (Argo.String "\"") + , Tasty.testCase "reverse solidus" $ do + decode "\"\\\\\"" @?= Just (Argo.String "\\") + , Tasty.testCase "solidus" $ do + decode "\"\\/\"" @?= Just (Argo.String "/") + , Tasty.testCase "backspace" $ do + decode "\"\\b\"" @?= Just (Argo.String "\b") + , Tasty.testCase "form feed" $ do + decode "\"\\f\"" @?= Just (Argo.String "\f") + , Tasty.testCase "new line" $ do + decode "\"\\n\"" @?= Just (Argo.String "\n") + , Tasty.testCase "carriage return" $ do + decode "\"\\r\"" @?= Just (Argo.String "\r") + , Tasty.testCase "horizontal tabulation" $ do + decode "\"\\t\"" @?= Just (Argo.String "\t") + , Tasty.testCase "null" $ do + decode "\"\\u0000\"" @?= Just (Argo.String "\x0") + , Tasty.testCase "unit separator" $ do + decode "\"\\u001f\"" @?= Just (Argo.String "\x1f") + , Tasty.testCase "capital long escape" $ do + decode "\"\\u001F\"" @?= Just (Argo.String "\x1f") + , Tasty.testCase "digits after long escape" $ do + decode "\"\\u00205\"" @?= Just (Argo.String " 5") + , Tasty.testCase "one byte" $ do + decode "\"$\"" @?= Just (Argo.String "$") + , Tasty.testCase "one byte escaped" $ do + decode "\"\\u0024\"" @?= Just (Argo.String "$") + , Tasty.testCase "two bytes" $ do + decode "\"\xc2\xa2\"" @?= Just (Argo.String "\xa2") + , Tasty.testCase "two bytes escaped" $ do + decode "\"\\u00a2\"" @?= Just (Argo.String "\xa2") + , Tasty.testCase "three bytes" $ do + decode "\"\xe2\x82\xac\"" @?= Just (Argo.String "\x20ac") + , Tasty.testCase "three bytes escaped" $ do + decode "\"\\u20ac\"" @?= Just (Argo.String "\x20ac") + , Tasty.testCase "four bytes" $ do + decode "\"\xf0\x90\x8d\x88\"" + @?= Just (Argo.String "\x10348") + , Tasty.testCase "surrogate pair" $ do + decode "\"\\ud834\\udd1e\"" + @?= Just (Argo.String "\x1d11e") + , Tasty.testCase "unpaired high surrogate" $ do + decode "\"\\ud800\"" @?= Just (Argo.String "\xfffd") + , Tasty.testCase "unpaired low surrogate" $ do + decode "\"\\udc00\"" @?= Just (Argo.String "\xfffd") + , Tasty.testCase "delete" $ do + decode "\"\x7f\"" @?= Just (Argo.String "\x7f") + , Tasty.testCase "invalid short escape" $ do + decode "\"\\z\"" @?= Nothing + , Tasty.testCase "capital short escape" $ do + decode "\"\\T\"" @?= Nothing + , Tasty.testCase "invalid long escape" $ do + decode "\"\\uwxyz\"" @?= Nothing + , Tasty.testCase "incomplete long escape" $ do + decode "\"\\u00\"" @?= Nothing + , Tasty.testCase "unescaped control character" $ do + decode "\"\n\"" @?= Nothing + , Tasty.testCase "unterminated" $ do + decode "\"" @?= Nothing + , Tasty.testCase "invalid UTF-8 byte" $ do + decode "\"\xff\"" @?= Nothing + ] + , Tasty.testGroup + "Array" + [ Tasty.testCase "empty" $ do + decode "[]" @?= Just (Argo.Array []) + , Tasty.testCase "one element" $ do + decode "[1]" @?= Just (Argo.Array [number 1 0]) + , Tasty.testCase "two elements" $ do + decode "[1,2]" + @?= Just (Argo.Array [number 1 0, number 2 0]) + , Tasty.testCase "nested" $ do + decode "[1,[2]]" + @?= Just + (Argo.Array + [number 1 0, Argo.Array [number 2 0]] + ) + , Tasty.testCase "not closed" $ do + decode "[" @?= Nothing + , Tasty.testCase "not opened" $ do + decode "]" @?= Nothing + , Tasty.testCase "leading comma" $ do + decode "[,1]" @?= Nothing + , Tasty.testCase "trailing comma" $ do + decode "[1,]" @?= Nothing + , Tasty.testCase "consecutive commas" $ do + decode "[1,,2]" @?= Nothing + , Tasty.testCase "like an object" $ do + decode "[\"a\":1]" @?= Nothing + ] + , Tasty.testGroup + "Object" + [ Tasty.testCase "empty" $ do + decode "{}" @?= Just (Argo.Object []) + , Tasty.testCase "one element" $ do + decode "{\"a\":1}" + @?= Just + (Argo.Object + [ Argo.Member (Argo.Name "a") + $ number 1 0 + ] + ) + , Tasty.testCase "two elements" $ do + decode "{\"a\":1,\"b\":2}" @?= Just + (Argo.Object + [ Argo.Member (Argo.Name "a") $ number 1 0 + , Argo.Member (Argo.Name "b") $ number 2 0 + ] + ) + , Tasty.testCase "nested" $ do + decode "{\"a\":{\"b\":2}}" @?= Just + (Argo.Object + [ Argo.Member (Argo.Name "a") $ Argo.Object + [Argo.Member (Argo.Name "b") $ number 2 0] + ] + ) + , Tasty.testCase "not closed" $ do + decode "{" @?= Nothing + , Tasty.testCase "not opened" $ do + decode "}" @?= Nothing + , Tasty.testCase "leading comma" $ do + decode "{,\"a\":1}" @?= Nothing + , Tasty.testCase "trailing comma" $ do + decode "{\"a\":1,}" @?= Nothing + , Tasty.testCase "consecutive commas" $ do + decode "{\"a\":1,,\"b\":2}" @?= Nothing + , Tasty.testCase "missing key" $ do + decode "{:1}" @?= Nothing + , Tasty.testCase "missing value" $ do + decode "{\"a\":}" @?= Nothing + , Tasty.testCase "missing separator" $ do + decode "{\"a\"1}" @?= Nothing + , Tasty.testCase "duplicate separator" $ do + decode "{\"a\"::1}" @?= Nothing + , Tasty.testCase "like an array" $ do + decode "{1}" @?= Nothing + , Tasty.testCase "non-string key" $ do + decode "{1:2}" @?= Nothing + ] + ] + , Tasty.testGroup + "fromValue" + [ Tasty.testCase "Value" $ do + Argo.fromValue Argo.Null @?= Right Argo.Null + , Tasty.testCase "Bool" $ do + Argo.fromValue (Argo.Boolean False) @?= Right False + , Tasty.testCase "Char" $ do + Argo.fromValue (Argo.String "a") @?= Right 'a' + , Tasty.testCase "Int" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Int) + , Tasty.testCase "Int8" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int8) + , Tasty.testCase "Int16" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int16) + , Tasty.testCase "Int32" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int32) + , Tasty.testCase "Int64" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Int.Int64) + , Tasty.testCase "Word" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Word) + , Tasty.testCase "Word8" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word8) + , Tasty.testCase "Word16" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word16) + , Tasty.testCase "Word32" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word32) + , Tasty.testCase "Word64" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Word.Word64) + , Tasty.testCase "Integer" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Integer) + , Tasty.testCase "Float" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Float) + , Tasty.testCase "Double" $ do + Argo.fromValue (number 0 0) @?= Right (0 :: Double) + , Tasty.testCase "String" $ do + Argo.fromValue (Argo.String "") @?= Right ("" :: String) + , Tasty.testCase "Text" $ do + Argo.fromValue (Argo.String "") @?= Right ("" :: Text.Text) + , Tasty.testCase "LazyText" $ do + Argo.fromValue (Argo.String "") @?= Right ("" :: LazyText.Text) + , Tasty.testCase "Maybe a" $ do + Argo.fromValue (Argo.Boolean False) @?= Right (Just False) + , Tasty.testCase "()" $ do + Argo.fromValue (Argo.Array []) @?= Right () + , Tasty.testCase "(a, b)" $ do + Argo.fromValue (Argo.Array [Argo.Boolean False, Argo.String "a"]) + @?= Right (False, 'a') + , Tasty.testCase "[a]" $ do + Argo.fromValue (Argo.Array []) @?= Right ([] :: [Bool]) + , Tasty.testCase "NonEmpty a" $ do + Argo.fromValue (Argo.Array [Argo.Boolean False]) + @?= Right (False :| []) + , Tasty.testCase "Map Name a" $ do + Argo.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 []) + ] + , Tasty.testGroup + "toValue" + [ Tasty.testCase "Value" $ do + Argo.toValue Argo.Null @?= Argo.Null + , Tasty.testCase "Bool" $ do + Argo.toValue False @?= Argo.Boolean False + , Tasty.testCase "Char" $ do + Argo.toValue 'a' @?= Argo.String "a" + , Tasty.testCase "Int" $ do + Argo.toValue (0 :: Int) @?= number 0 0 + , Tasty.testCase "Int8" $ do + Argo.toValue (0 :: Int.Int8) @?= number 0 0 + , Tasty.testCase "Int16" $ do + Argo.toValue (0 :: Int.Int16) @?= number 0 0 + , Tasty.testCase "Int32" $ do + Argo.toValue (0 :: Int.Int32) @?= number 0 0 + , Tasty.testCase "Int64" $ do + Argo.toValue (0 :: Int.Int64) @?= number 0 0 + , Tasty.testCase "Word" $ do + Argo.toValue (0 :: Word) @?= number 0 0 + , Tasty.testCase "Word8" $ do + Argo.toValue (0 :: Word.Word8) @?= number 0 0 + , Tasty.testCase "Word16" $ do + Argo.toValue (0 :: Word.Word16) @?= number 0 0 + , Tasty.testCase "Word32" $ do + Argo.toValue (0 :: Word.Word32) @?= number 0 0 + , Tasty.testCase "Word64" $ do + Argo.toValue (0 :: Word.Word64) @?= number 0 0 + , Tasty.testCase "Integer" $ do + Argo.toValue (0 :: Integer) @?= number 0 0 + , Tasty.testCase "Float" $ do + Argo.toValue (0 :: Float) @?= number 0 0 + , Tasty.testCase "Double" $ do + Argo.toValue (0 :: Double) @?= number 0 0 + , Tasty.testCase "String" $ do + Argo.toValue ("" :: String) @?= Argo.String "" + , Tasty.testCase "Text" $ do + Argo.toValue ("" :: Text.Text) @?= Argo.String "" + , Tasty.testCase "LazyText" $ do + Argo.toValue ("" :: LazyText.Text) @?= Argo.String "" + , Tasty.testCase "Maybe a" $ do + Argo.toValue (Just False) @?= Argo.Boolean False + , Tasty.testCase "()" $ do + Argo.toValue () @?= Argo.Array [] + , Tasty.testCase "(a, b)" $ do + Argo.toValue (False, 'a') + @?= Argo.Array [Argo.Boolean False, Argo.String "a"] + , Tasty.testCase "[a]" $ do + Argo.toValue ([] :: [Bool]) @?= Argo.Array [] + , Tasty.testCase "NonEmpty a" $ do + Argo.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] + , Tasty.testCase "Pointer" $ do + Argo.toValue (Argo.Pointer []) @?= Argo.String "" + ] + , Tasty.testGroup + "quasi quoter" + [ Tasty.testCase "Null" $ do + [Argo.value| null |] @?= Argo.Null + , Tasty.testCase "Boolean" $ do + [Argo.value| false |] @?= Argo.Boolean False + , Tasty.testCase "Number" $ do + [Argo.value| 0 |] @?= number 0 0 + , Tasty.testCase "String" $ do + [Argo.value| "" |] @?= Argo.String "" + , Tasty.testCase "Array" $ do + [Argo.value| [] |] @?= Argo.Array [] + , Tasty.testCase "Object" $ do + [Argo.value| {} |] @?= Argo.Object [] + ] + , Tasty.testGroup + "property" + [ property "decode . encode" $ \x -> + (Argo.decode + . LazyByteString.toStrict + . Builder.toLazyByteString + $ Argo.encode x + ) + === Right (x :: Argo.Value) + , property "decode . encodeWith" $ \x -> + (Argo.decode + . LazyByteString.toStrict + . Builder.toLazyByteString + $ Argo.encodeWith Argo.Tab x + ) + === 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 "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) + , property "Word16" + $ \x -> Argo.fromValue (Argo.toValue x) + === Right (x :: Word.Word16) + , property "Word32" $ \x -> + Argo.fromValue (Argo.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) + , property "Float" $ \x -> + Argo.fromValue (Argo.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 + 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 "[a]" + $ \x -> Argo.fromValue (Argo.toValue x) === Right (x :: [Bool]) + , property "NonEmpty a" + $ \x -> Argo.fromValue (Argo.toValue x) + === Right (x :: NonEmpty Bool) + , property "Map Name a" + $ \x -> Argo.fromValue (Argo.toValue x) + === Right (x :: Map.Map Argo.Name Bool) + , property "Pointer" $ \x -> + Argo.fromValue (Argo.toValue x) === Right (x :: Argo.Pointer) + ] + ] + , Tasty.testGroup + "Codec" + [ Tasty.testCase "encode text" $ do + Codec.encodeWith Argo.codec ("" :: Text.Text) @?= Argo.String "" + , Tasty.testCase "decode text" $ do + Codec.decodeWith Argo.codec (Argo.String "") + @?= Right ("" :: Text.Text) + , Tasty.testCase "encode bool" $ do + Codec.encodeWith Argo.codec False @?= Argo.Boolean False + , Tasty.testCase "decode bool" $ do + Codec.decodeWith Argo.codec (Argo.Boolean False) @?= Right False + , Tasty.testCase "encode maybe bool" $ do + Codec.encodeWith Argo.codec (Nothing :: Maybe Bool) @?= Argo.Null + Codec.encodeWith Argo.codec (Just False) @?= Argo.Boolean False + , Tasty.testCase "decode maybe bool" $ do + Codec.decodeWith Argo.codec Argo.Null + @?= Right (Nothing :: Maybe Bool) + Codec.decodeWith Argo.codec (Argo.Boolean False) + @?= Right (Just False) + , Tasty.testCase "encode either text bool" $ do + Codec.encodeWith Argo.codec (Left "" :: Either Text.Text Bool) + @?= Argo.Object + [ Argo.Member (Argo.Name "type") $ Argo.String "Left" + , Argo.Member (Argo.Name "value") $ Argo.String "" + ] + Codec.encodeWith Argo.codec (Right False :: Either Text.Text Bool) + @?= Argo.Object + [ Argo.Member (Argo.Name "type") $ Argo.String "Right" + , Argo.Member (Argo.Name "value") $ Argo.Boolean False + ] + , Tasty.testCase "decode either text bool" $ do + Codec.decodeWith + Argo.codec + (Argo.Object + [ Argo.Member (Argo.Name "type") $ Argo.String "Left" + , Argo.Member (Argo.Name "value") $ Argo.String "" + ] + ) + @?= Right (Left "" :: Either Text.Text Bool) + Codec.decodeWith + Argo.codec + (Argo.Object + [ Argo.Member (Argo.Name "type") $ Argo.String "Right" + , Argo.Member (Argo.Name "value") $ Argo.Boolean False + ] + ) + @?= Right (Right False :: Either Text.Text Bool) + , Tasty.testCase "encode tuple text bool" $ do + Codec.encodeWith Argo.codec ("" :: Text.Text, False) + @?= Argo.Array [Argo.String "", Argo.Boolean False] + , Tasty.testCase "decode tuple text bool" $ do + Codec.decodeWith + Argo.codec + (Argo.Array [Argo.String "", Argo.Boolean False]) + @?= Right ("" :: Text.Text, False) + , Tasty.testCase "encode record" $ do + Codec.encodeWith Argo.codec (Record False Nothing) + @?= Argo.Object + [Argo.Member (Argo.Name "bool") $ Argo.Boolean False] + Codec.encodeWith Argo.codec (Record False $ Just "") + @?= Argo.Object + [ Argo.Member (Argo.Name "bool") $ Argo.Boolean False + , Argo.Member (Argo.Name "text") $ Argo.String "" + ] + , Tasty.testCase "decode record" $ do + Codec.decodeWith + Argo.codec + (Argo.Object + [Argo.Member (Argo.Name "bool") $ Argo.Boolean False] + ) + @?= Right (Record False Nothing) + Codec.decodeWith + Argo.codec + (Argo.Object + [ Argo.Member (Argo.Name "bool") $ Argo.Boolean False + , Argo.Member (Argo.Name "text") $ Argo.String "" + ] + ) + @?= Right (Record False $ Just "") + ] + , Tasty.testGroup "Pointer" + $ let pointer = Argo.Pointer . fmap Argo.Token + in + [ Tasty.testCase "decode" $ do + let decode = hush . Argo.decodePointer + decode "" @?= Just (pointer []) + decode "/" @?= Just (pointer [""]) + decode "/a" @?= Just (pointer ["a"]) + decode "/a/b" @?= Just (pointer ["a", "b"]) + decode "/ab" @?= Just (pointer ["ab"]) + decode "/~0" @?= Just (pointer ["~"]) + decode "/~1" @?= Just (pointer ["/"]) + decode "/~01" @?= Just (pointer ["~1"]) + decode "a" @?= Nothing + decode "/~2" @?= Nothing + , Tasty.testCase "encode" $ do + let encode = Builder.toLazyByteString . Argo.encodePointer + encode (pointer []) @?= "" + encode (pointer [""]) @?= "/" + encode (pointer ["a"]) @?= "/a" + encode (pointer ["a", "b"]) @?= "/a/b" + encode (pointer ["ab"]) @?= "/ab" + encode (pointer ["~"]) @?= "/~0" + encode (pointer ["/"]) @?= "/~1" + encode (pointer ["~1"]) @?= "/~01" + , property "decode . encode" $ \x -> + (Argo.decodePointer + . LazyByteString.toStrict + . Builder.toLazyByteString + $ Argo.encodePointer x + ) + === Right (x :: Argo.Pointer) + , Tasty.testCase "quasi-quoter" $ do + [Argo.pointer||] @?= pointer [] + [Argo.pointer|/|] @?= pointer [""] + [Argo.pointer|/a|] @?= pointer ["a"] + [Argo.pointer|/a/b|] @?= pointer ["a", "b"] + , Tasty.testCase "evaluate" $ do + let evaluate p = hush . Argo.evaluate p + evaluate (pointer []) Argo.Null @?= Just Argo.Null + evaluate + (pointer ["a"]) + (Argo.Object [Argo.Member (Argo.Name "a") Argo.Null]) + @?= Just Argo.Null + evaluate + (pointer ["a", "b"]) + (Argo.Object + [ Argo.Member (Argo.Name "a") $ Argo.Object + [Argo.Member (Argo.Name "b") Argo.Null] + ] + ) + @?= Just Argo.Null + evaluate + (pointer ["0"]) + (Argo.Object [Argo.Member (Argo.Name "0") Argo.Null]) + @?= Just Argo.Null + evaluate (pointer ["0"]) (Argo.Array [Argo.Null]) + @?= Just Argo.Null + evaluate + (pointer ["0", "1"]) + (Argo.Array + [Argo.Array [Argo.Boolean False, Argo.Null]] + ) + @?= Just Argo.Null + evaluate (pointer ["a"]) Argo.Null @?= Nothing + evaluate (pointer ["a"]) (Argo.Object []) @?= Nothing + evaluate (pointer ["a"]) (Argo.Array [Argo.Null]) @?= Nothing + evaluate (pointer ["0"]) (Argo.Array []) @?= Nothing + evaluate (pointer ["-"]) (Argo.Array []) @?= Nothing + evaluate (pointer ["00"]) (Argo.Array [Argo.Null]) + @?= Nothing + ] + , Tasty.testGroup + "OverloadedStrings" + [ Tasty.testCase "Value" $ do + "" @?= Argo.String "" + , Tasty.testCase "String" $ do + "" @?= String.String "" + , Tasty.testCase "Name" $ do + "" @?= Argo.Name "" + , Tasty.testCase "Token" $ do + "" @?= Argo.Token "" + ] + , Tasty.testGroup + "Schema" + [ Tasty.testCase "value" $ do + let expected = [Argo.schema| true |] + actual = Codec.schema (Argo.codec :: Codec.Value Argo.Value) + actual @?= expected + , Tasty.testCase "null" $ do + let expected = [Argo.schema| { "type": "null" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Null.Null) + actual @?= expected + , Tasty.testCase "boolean" $ do + let expected = [Argo.schema| { "type": "boolean" } |] + actual = + Codec.schema (Argo.codec :: Codec.Value Boolean.Boolean) + actual @?= expected + , Tasty.testCase "number" $ do + let expected = [Argo.schema| { "type": "number" } |] + actual = + Codec.schema (Argo.codec :: Codec.Value Number.Number) + actual @?= expected + , Tasty.testCase "string" $ do + let expected = [Argo.schema| { "type": "string" } |] + actual = + Codec.schema (Argo.codec :: Codec.Value String.String) + actual @?= expected + , Tasty.testCase "array boolean" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "array", "items": { "type": "boolean" } } |] + actual = + Codec.schema + (Argo.codec :: Codec.Value + (Array.Array Boolean.Boolean) + ) + actual @?= expected + , Tasty.testCase "object boolean" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "object", "additionalProperties": { "type": "boolean" } } |] + actual = + Codec.schema + (Argo.codec :: Codec.Value + (Object.Object Boolean.Boolean) + ) + actual @?= expected + , Tasty.testCase "maybe boolean" $ do + let expected = + Schema.fromValue + [Argo.value| { "oneOf": [ { "type": "boolean" }, { "type": "null" } ] } |] + actual = Codec.schema + (Argo.codec :: Codec.Value (Maybe Boolean.Boolean)) + actual @?= expected + , 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 } ] } |] + actual = + Codec.schema + (Argo.codec :: Codec.Value + (Either Boolean.Boolean Number.Number) + ) + actual @?= expected + , Tasty.testCase "()" $ do + let expected = + Schema.fromValue + [Argo.value| { "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 + , Tasty.testCase "bool" $ do + let expected = [Argo.schema| { "type": "boolean" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Bool) + actual @?= expected + , Tasty.testCase "decimal" $ do + let expected = [Argo.schema| { "type": "number" } |] + actual = + Codec.schema (Argo.codec :: Codec.Value Decimal.Decimal) + actual @?= expected + , Tasty.testCase "text" $ do + let expected = [Argo.schema| { "type": "string" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Text.Text) + actual @?= expected + , Tasty.testCase "list boolean" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "array", "items": { "type": "boolean" } } |] + actual = + Codec.schema (Argo.codec :: Codec.Value [Boolean.Boolean]) + actual @?= expected + , Tasty.testCase "map name boolean" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "object", "additionalProperties": { "type": "boolean" } } |] + actual = + Codec.schema + (Argo.codec :: Codec.Value + (Map.Map Name.Name Boolean.Boolean) + ) + actual @?= expected + , Tasty.testCase "string" $ do + let expected = [Argo.schema| { "type": "string" } |] + actual = Codec.schema (Argo.codec :: Codec.Value String) + actual @?= expected + , Tasty.testCase "char" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "string", "minLength": 1, "maxLength": 1 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Char) + actual @?= expected + , Tasty.testCase "lazy text" $ do + let expected = [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 } |] + actual = Codec.schema + (Argo.codec :: Codec.Value (NonEmpty Boolean.Boolean)) + actual @?= expected + , Tasty.testCase "integer" $ do + let expected = [Argo.schema| { "type": "integer" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Integer) + actual @?= expected + , Tasty.testCase "int" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Int) + actual @?= expected + , Tasty.testCase "int8" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": -128, "maximum": 127 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Int.Int8) + actual @?= expected + , Tasty.testCase "int16" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": -32768, "maximum": 32767 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Int.Int16) + actual @?= expected + , Tasty.testCase "int32" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": -2147483648, "maximum": 2147483647 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Int.Int32) + actual @?= expected + , Tasty.testCase "int64" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Int.Int64) + actual @?= expected + , Tasty.testCase "natural" $ do + let expected = Schema.fromValue + [Argo.value| { "type": "integer", "minimum": 0 } |] + actual = + Codec.schema (Argo.codec :: Codec.Value Natural.Natural) + actual @?= expected + , Tasty.testCase "word" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Word) + actual @?= expected + , Tasty.testCase "word8" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": 0, "maximum": 255 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Word.Word8) + actual @?= expected + , Tasty.testCase "word16" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": 0, "maximum": 65535 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Word.Word16) + actual @?= expected + , Tasty.testCase "word32" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": 0, "maximum": 4294967295 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Word.Word32) + actual @?= expected + , Tasty.testCase "word64" $ do + let expected = + Schema.fromValue + [Argo.value| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] + actual = Codec.schema (Argo.codec :: Codec.Value Word.Word64) + actual @?= expected + , Tasty.testCase "float" $ do + let expected = [Argo.schema| { "type": "number" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Float) + actual @?= expected + , Tasty.testCase "double" $ do + let expected = [Argo.schema| { "type": "number" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Double) + actual @?= expected + , Tasty.testCase "pointer" $ do + let expected = [Argo.schema| { "type": "string" } |] + actual = Codec.schema (Argo.codec :: Codec.Value Argo.Pointer) + actual @?= expected + , Tasty.testCase "schema" $ do + let expected = [Argo.schema| true |] + actual = + Codec.schema (Argo.codec :: Codec.Value Schema.Schema) + actual @?= expected + , Tasty.testCase "record" $ do + let expected + = [Argo.schema| { "type": "object", "properties": { "bool": { "type": "boolean" }, "text": { "type": "string" } }, "required": [ "bool" ], "additionalProperties": true } |] + actual = Codec.schema (Argo.codec :: Codec.Value Record) + actual @?= expected + ] + ] + +number :: Integer -> Integer -> Argo.Value +number s = Argo.Number . Argo.Decimal s + +data Record = Record + { recordBool :: Bool + , recordText :: Maybe Text.Text + } + deriving (Eq, Show) + +instance Argo.HasCodec Record where + codec = + Codec.fromObjectCodec Permission.Allow + $ Record + <$> Codec.project + recordBool + (Codec.required (Argo.Name "bool") Argo.codec) + <*> Codec.project + recordText + (Codec.optional (Argo.Name "text") Argo.codec) + +property + :: (Show t, Tasty.Testable prop, Tasty.Arbitrary t) + => Tasty.TestName + -> (t -> prop) + -> Tasty.TestTree +property n = propertyWith n Tasty.arbitrary Tasty.shrink + +propertyWith + :: (Show t, Tasty.Testable prop) + => Tasty.TestName + -> Tasty.Gen t + -> (t -> [t]) + -> (t -> prop) + -> Tasty.TestTree +propertyWith n g s f = + Tasty.testProperty n . Tasty.forAll g $ \x -> Tasty.shrinking s x f hush :: Either String a -> Maybe a hush = either (const Nothing) Just