diff --git a/argo.cabal b/argo.cabal --- a/argo.cabal +++ b/argo.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: argo -version: 0.2022.2.2 +version: 0.2022.2.23 build-type: Simple category: JSON @@ -98,6 +98,8 @@ Argo.Type.Encoder Argo.Type.Flag Argo.Type.Indent + Argo.Type.Nullable + Argo.Type.Optional Argo.Type.Permission Argo.Type.Settings hs-source-dirs: source/library diff --git a/source/library/Argo.hs b/source/library/Argo.hs --- a/source/library/Argo.hs +++ b/source/library/Argo.hs @@ -16,7 +16,6 @@ , HasCodec.HasCodec(codec) , QuasiQuoter.value , QuasiQuoter.pointer - , QuasiQuoter.schema , Pointer.Pointer(Pointer) , Token.Token(Token) , Pointer.evaluate 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 @@ -19,11 +19,14 @@ import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value import qualified Argo.Pointer.Pointer as Pointer +import qualified Argo.Schema.Identifier as Identifier 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 import qualified Argo.Type.Encoder as Encoder +import qualified Argo.Type.Nullable as Nullable +import qualified Argo.Type.Optional as Optional import qualified Argo.Type.Permission as Permission import qualified Argo.Vendor.Builder as Builder import qualified Argo.Vendor.ByteString as ByteString @@ -34,73 +37,50 @@ import qualified Data.Functor.Identity as Identity import qualified Data.Int as Int import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Maybe as Maybe import qualified Data.Typeable as Typeable import qualified Data.Word as Word import qualified Numeric.Natural as Natural -class HasCodec a where +class Typeable.Typeable a => HasCodec a where codec :: Codec.Value a instance HasCodec Value.Value where - codec = basicCodec Schema.true id Just + codec = valueCodec Schema.true id Just instance HasCodec Null.Null where codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "null" - ) - ] + let schema = Schema.Null in - basicCodec schema Value.Null $ \value -> case value of + valueCodec schema Value.Null $ \value -> case value of Value.Null null_ -> Just null_ _ -> Nothing instance HasCodec Boolean.Boolean where codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "boolean" - ) - ] + let schema = Schema.Boolean in - basicCodec schema Value.Boolean $ \value -> case value of + valueCodec schema Value.Boolean $ \value -> case value of Value.Boolean boolean -> Just boolean _ -> Nothing instance HasCodec Number.Number where codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "number" - ) - ] + let schema = Schema.Number in - basicCodec schema Value.Number $ \value -> case value of + valueCodec schema Value.Number $ \value -> case value of Value.Number number -> Just number _ -> Nothing instance HasCodec String.String where codec = - let - schema = Schema.fromValue . Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "type" - , Value.String . String.fromText $ Text.pack "string" - ) - ] + let schema = Schema.String Nothing Nothing in - basicCodec schema Value.String $ \value -> case value of + valueCodec schema Value.String $ \value -> case value of Value.String string -> Just string _ -> Nothing -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Array.Array a) where +instance HasCodec a => HasCodec (Array.Array a) where codec = Codec.identified Codec.Codec { Codec.decode = do array <- castValue "Array" $ \value -> case value of @@ -119,25 +99,14 @@ . Array.toList , Codec.schema = do ref <- Codec.getRef (codec :: Codec.Value a) - pure - . Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack "array" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "items" - , Codec.ref ref - ) - ] + pure . Schema.unidentified $ Schema.Array + Nothing + Nothing + (Left ref) + Nothing } -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Object.Object a) where +instance HasCodec a => HasCodec (Object.Object a) where codec = Codec.identified Codec.Codec { Codec.decode = do object <- castValue "Object" $ \value -> case value of @@ -162,35 +131,19 @@ . Object.toList , Codec.schema = do ref <- Codec.getRef (codec :: Codec.Value a) - pure - . Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack "object" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "additionalProperties" - , Codec.ref ref - ) - ] + pure . Schema.unidentified . Schema.Object [] [] $ Just ref } -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Maybe a) where +instance HasCodec a => HasCodec (Nullable.Nullable a) where + codec = nullable codec + +instance HasCodec a => HasCodec (Maybe a) where codec = - Codec.identified - $ Codec.mapMaybe (Just . Just) id codec - <|> Codec.map (const Nothing) (const $ Null.fromUnit ()) codec + Codec.identified $ Codec.map Nullable.toMaybe Nullable.fromMaybe codec instance ( HasCodec a , HasCodec b - , Typeable.Typeable a - , Typeable.Typeable b ) => HasCodec (Either a b) where codec = Codec.identified @@ -210,8 +163,6 @@ instance ( HasCodec a , HasCodec b - , Typeable.Typeable a - , Typeable.Typeable b ) => HasCodec (a, b) where codec = Codec.identified @@ -224,9 +175,6 @@ ( HasCodec a , HasCodec b , HasCodec c - , Typeable.Typeable a - , Typeable.Typeable b - , Typeable.Typeable c ) => HasCodec (a, b, c) where codec = Codec.identified @@ -241,10 +189,6 @@ , HasCodec b , HasCodec c , HasCodec d - , Typeable.Typeable a - , Typeable.Typeable b - , Typeable.Typeable c - , Typeable.Typeable d ) => HasCodec (a, b, c, d) where codec = Codec.identified @@ -261,11 +205,6 @@ , HasCodec c , HasCodec d , HasCodec e - , Typeable.Typeable a - , Typeable.Typeable b - , Typeable.Typeable c - , Typeable.Typeable d - , Typeable.Typeable e ) => HasCodec (a, b, c, d, e) where codec = Codec.identified @@ -284,12 +223,6 @@ , HasCodec d , HasCodec e , HasCodec f - , Typeable.Typeable a - , Typeable.Typeable b - , Typeable.Typeable c - , Typeable.Typeable d - , Typeable.Typeable e - , Typeable.Typeable f ) => HasCodec (a, b, c, d, e, f) where codec = Codec.identified @@ -310,13 +243,6 @@ , HasCodec e , HasCodec f , HasCodec g - , Typeable.Typeable a - , Typeable.Typeable b - , Typeable.Typeable c - , Typeable.Typeable d - , Typeable.Typeable e - , Typeable.Typeable f - , Typeable.Typeable g ) => HasCodec (a, b, c, d, e, f, g) where codec = Codec.identified @@ -353,14 +279,6 @@ , HasCodec f , HasCodec g , HasCodec h - , Typeable.Typeable a - , Typeable.Typeable b - , Typeable.Typeable c - , Typeable.Typeable d - , Typeable.Typeable e - , Typeable.Typeable f - , Typeable.Typeable g - , Typeable.Typeable h ) => HasCodec (a, b, c, d, e, f, g, h) where codec = Codec.identified @@ -401,34 +319,34 @@ instance HasCodec Text.Text where codec = Codec.identified $ Codec.map String.toText String.fromText codec -instance {-# OVERLAPPABLE #-} (HasCodec a, Typeable.Typeable a) => HasCodec [a] where +instance {-# OVERLAPPABLE #-} HasCodec a => HasCodec [a] where codec = Codec.identified $ Codec.map Array.toList Array.fromList codec -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map Name.Name a) where +instance HasCodec a => HasCodec (Map.Map Name.Name a) where codec = Codec.identified $ Codec.map (Map.fromList . fmap Member.toTuple . Object.toList) (Object.fromList . fmap Member.fromTuple . Map.toList) codec -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map String.String a) where +instance HasCodec a => HasCodec (Map.Map String.String a) where codec = Codec.identified $ Codec.map (Map.mapKeys Name.toString) (Map.mapKeys Name.fromString) codec -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map Text.Text a) where +instance HasCodec a => HasCodec (Map.Map Text.Text a) where codec = Codec.identified $ Codec.map (Map.mapKeys String.toText) (Map.mapKeys String.fromText) codec -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map Text.LazyText a) where +instance HasCodec a => HasCodec (Map.Map Text.LazyText a) where codec = Codec.identified $ Codec.map (Map.mapKeys Text.fromStrict) (Map.mapKeys Text.toStrict) codec -instance (HasCodec a, Typeable.Typeable a) => HasCodec (Map.Map String a) where +instance HasCodec a => HasCodec (Map.Map String a) where codec = Codec.identified $ Codec.map (Map.mapKeys Text.unpack) (Map.mapKeys Text.pack) codec @@ -437,33 +355,7 @@ instance HasCodec Char where codec = - let - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "string" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minLength" - , Value.Number - . Number.fromDecimal - $ Decimal.fromInteger 1 - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maxLength" - , Value.Number - . Number.fromDecimal - $ Decimal.fromInteger 1 - ) - ] + let schema = Schema.unidentified $ Schema.String (Just 1) (Just 1) in Codec.identified $ Codec.mapMaybe (\x -> case Text.uncons x of @@ -476,35 +368,16 @@ instance HasCodec Text.LazyText where codec = Codec.identified $ Codec.map Text.fromStrict Text.toStrict codec -instance (HasCodec a, Typeable.Typeable a) => HasCodec (NonEmpty.NonEmpty a) where +instance HasCodec a => HasCodec (NonEmpty.NonEmpty a) where codec = let schema = do - (_, itemSchema) <- Codec.schema (codec :: Codec.Value a) - pure - . Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "array" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "items" - , Schema.toValue itemSchema - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minItems" - , Value.Number - . Number.fromDecimal - $ Decimal.fromInteger 1 - ) - ] + itemSchema <- Codec.schema (codec :: Codec.Value a) + pure . Schema.unidentified $ Schema.Array + (Just 1) + Nothing + (Left $ Schema.maybeRef itemSchema) + Nothing in Codec.identified $ Codec.mapMaybe NonEmpty.nonEmpty @@ -513,19 +386,7 @@ instance HasCodec Integer where codec = - let - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - ] + let schema = Schema.unidentified $ Schema.Integer Nothing Nothing in Codec.identified $ Codec.mapMaybe Decimal.toInteger @@ -533,413 +394,45 @@ codec { Codec.schema = pure schema } instance HasCodec Int where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int - into = fromIntegral :: Int -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Int.Int8 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int8 - into = fromIntegral :: Int.Int8 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int8) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int8) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Int.Int16 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int16 - into = fromIntegral :: Int.Int16 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int16) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int16) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Int.Int32 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int32 - into = fromIntegral :: Int.Int32 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int32) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int32) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Int.Int64 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Int.Int64 - into = fromIntegral :: Int.Int64 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Int.Int64) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Int.Int64) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Natural.Natural where codec = let from = Bits.toIntegralSized :: Integer -> Maybe Natural.Natural into = fromIntegral :: Natural.Natural -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - $ Decimal.fromInteger 0 - ) - ] + schema = Schema.unidentified $ Schema.Integer (Just 0) Nothing in Codec.identified $ Codec.mapMaybe from (Just . into) codec { Codec.schema = pure schema } instance HasCodec Word where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word - into = fromIntegral :: Word -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Word.Word8 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word8 - into = fromIntegral :: Word.Word8 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word8) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word8) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Word.Word16 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word16 - into = fromIntegral :: Word.Word16 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word16) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word16) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Word.Word32 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word32 - into = fromIntegral :: Word.Word32 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word32) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word32) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Word.Word64 where - codec = - let - from = Bits.toIntegralSized :: Integer -> Maybe Word.Word64 - into = fromIntegral :: Word.Word64 -> Integer - schema = - Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "integer" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "minimum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (minBound :: Word.Word64) - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "maximum" - , Value.Number - . Number.fromDecimal - . Decimal.fromInteger - $ toInteger (maxBound :: Word.Word64) - ) - ] - in Codec.identified $ Codec.mapMaybe - from - (Just . into) - codec { Codec.schema = pure schema } + codec = integralCodec instance HasCodec Float where codec = Codec.identified $ Codec.mapMaybe @@ -968,19 +461,295 @@ ) codec +instance HasCodec Identifier.Identifier where + codec = + let prefix = Text.pack "#/definitions/" + in + Codec.identified $ Codec.mapMaybe + (fmap Identifier.fromText . Text.stripPrefix prefix) + (Just . mappend prefix . Identifier.toText) + codec + +instance HasCodec Name.Name where + codec = Codec.identified $ Codec.map Name.fromString Name.toString codec + instance HasCodec Schema.Schema where - codec = Codec.identified $ Codec.map Schema.fromValue Schema.toValue codec + codec = + let + trueCodec = + Codec.mapMaybe + (const $ Just Schema.True) + (\x -> case x of + Schema.True -> Just () + _ -> Nothing + ) + . Codec.literalCodec + . Value.Boolean + $ Boolean.fromBool True + falseCodec = + Codec.mapMaybe + (const $ Just Schema.False) + (\x -> case x of + Schema.False -> Just () + _ -> Nothing + ) + . Codec.literalCodec + . Value.Boolean + $ Boolean.fromBool False + constCodec = + Codec.mapMaybe + (Just . Schema.Const) + (\x -> case x of + Schema.Const y -> Just y + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ Codec.required (name "const") codec + nullCodec = + Codec.mapMaybe + (const $ Just Schema.Null) + (\x -> case x of + Schema.Null -> Just () + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + . Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "null" + booleanCodec = + Codec.mapMaybe + (const $ Just Schema.Boolean) + (\x -> case x of + Schema.Boolean -> Just () + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + . Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "boolean" + numberCodec = + Codec.mapMaybe + (const $ Just Schema.Number) + (\x -> case x of + Schema.Number -> Just () + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + . Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "number" + integerCodec = + Codec.mapMaybe + (\(_, y, z) -> Just $ Schema.Integer + (Optional.toMaybe y) + (Optional.toMaybe z) + ) + (\x -> case x of + Schema.Integer y z -> + Just + ( () + , Optional.fromMaybe y + , Optional.fromMaybe z + ) + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ (,,) + <$> Codec.project + (\(a, _, _) -> a) + (Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "integer" + ) + <*> Codec.project + (\(_, b, _) -> b) + (Codec.optional (name "minimum") codec) + <*> Codec.project + (\(_, _, c) -> c) + (Codec.optional (name "maximum") codec) + stringCodec = + Codec.mapMaybe + (\(_, y, z) -> Just $ Schema.String + (Optional.toMaybe y) + (Optional.toMaybe z) + ) + (\x -> case x of + Schema.String y z -> + Just + ( () + , Optional.fromMaybe y + , Optional.fromMaybe z + ) + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ (,,) + <$> Codec.project + (\(a, _, _) -> a) + (Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "string" + ) + <*> Codec.project + (\(_, b, _) -> b) + (Codec.optional (name "minLength") codec) + <*> Codec.project + (\(_, _, c) -> c) + (Codec.optional (name "maxLength") codec) + arrayCodec = + Codec.mapMaybe + (\(_, lo, hi, e, m) -> Just $ Schema.Array + (Optional.toMaybe lo) + (Optional.toMaybe hi) + e + (Optional.toMaybe m) + ) + (\x -> case x of + Schema.Array lo hi e m -> Just + ( () + , Optional.fromMaybe lo + , Optional.fromMaybe hi + , e + , Optional.fromMaybe m + ) + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ (,,,,) + <$> Codec.project + (\(a, _, _, _, _) -> a) + (Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "array" + ) + <*> Codec.project + (\(_, b, _, _, _) -> b) + (Codec.optional (name "minItems") codec) + <*> Codec.project + (\(_, _, c, _, _) -> c) + (Codec.optional (name "maxItems") codec) + <*> Codec.project + (\(_, _, _, d, _) -> d) + (Codec.required (name "items") + . Codec.withIdentifier + (Identifier.fromText + $ Text.pack "OneOf Schema [Schema]" + ) + $ Codec.mapMaybe + (Just . Left) + (either Just $ const Nothing) + codec + <|> Codec.mapMaybe + (Just . Right) + (either (const Nothing) Just) + codec + ) + <*> Codec.project + (\(_, _, _, _, e) -> e) + (Codec.optional (name "additionalItems") codec) + objectCodec = + Codec.mapMaybe + (\(_, ps, rs, m) -> Just $ Schema.Object + (fmap Member.toTuple + . foldMap Object.toList + $ Optional.toMaybe ps + ) + (Maybe.fromMaybe [] $ Optional.toMaybe rs) + (Optional.toMaybe m) + ) + (\x -> case x of + Schema.Object ps rs m -> Just + ( () + , if null ps + then Optional.nothing + else Optional.just . Object.fromList $ fmap + Member.fromTuple + ps + , if null rs + then Optional.nothing + else Optional.just rs + , Optional.fromMaybe m + ) + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ (,,,) + <$> Codec.project + (\(a, _, _, _) -> a) + (Codec.required (name "type") + . Codec.literalCodec + . Value.String + . String.fromText + $ Text.pack "object" + ) + <*> Codec.project + (\(_, b, _, _) -> b) + (Codec.optional (name "properties") codec) + <*> Codec.project + (\(_, _, c, _) -> c) + (Codec.optional (name "required") codec) + <*> Codec.project + (\(_, _, _, d) -> d) + (Codec.optional (name "additionalProperties") codec + ) + refCodec = + Codec.mapMaybe + (Just . Schema.Ref) + (\x -> case x of + Schema.Ref y -> Just y + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ Codec.required (name "$ref") codec + oneOfCodec = + Codec.mapMaybe + (Just . Schema.OneOf) + (\x -> case x of + Schema.OneOf y -> Just y + _ -> Nothing + ) + . Codec.fromObjectCodec Permission.Forbid + $ Codec.required (name "oneOf") codec + in + Codec.identified + $ trueCodec + <|> falseCodec + <|> constCodec + <|> nullCodec + <|> booleanCodec + <|> numberCodec + <|> integerCodec + <|> stringCodec + <|> arrayCodec + <|> objectCodec + <|> refCodec + <|> oneOfCodec -basicCodec +name :: String -> Name.Name +name = Name.fromString . String.fromText . Text.pack + +valueCodec :: forall a . Typeable.Typeable a => Schema.Schema -> (a -> Value.Value) -> (Value.Value -> Maybe a) -> Codec.Value a -basicCodec schema toValue fromValue = Codec.identified Codec.Codec +valueCodec schema toValue fromValue = Codec.identified Codec.Codec { Codec.decode = castValue - (show $ Typeable.typeRep (Typeable.Proxy :: Typeable.Proxy a)) + (Codec.typeName (Typeable.Proxy :: Typeable.Proxy a)) fromValue , Codec.encode = Codec.tap $ Trans.lift . Trans.put . toValue , Codec.schema = pure $ Schema.unidentified schema @@ -1010,3 +779,40 @@ Value.Array _ -> "Array" Value.Object _ -> "Object" in "expected " <> expected <> " but got " <> actual + +integralCodec + :: forall a + . (Bits.Bits a, Bounded a, Integral a, Typeable.Typeable a) + => Codec.Value a +integralCodec = + let + from = Bits.toIntegralSized :: Integer -> Maybe a + into = fromIntegral :: a -> Integer + schema = Schema.unidentified $ Schema.Integer + (Just $ toInteger (minBound :: a)) + (Just $ toInteger (maxBound :: a)) + in Codec.identified $ Codec.mapMaybe + from + (Just . into) + codec { Codec.schema = pure schema } + +optionalNullable + :: Typeable.Typeable a + => Name.Name + -> Codec.Value a + -> Codec.Object (Maybe a) +optionalNullable k = + Codec.map + (maybe Nothing Nullable.toMaybe . Optional.toMaybe) + (Optional.fromMaybe . fmap Nullable.just) + . Codec.optional k + . nullable + +nullable + :: Typeable.Typeable a + => Codec.Value a + -> Codec.Value (Nullable.Nullable a) +nullable c = + Codec.identified + $ Codec.mapMaybe (Just . Nullable.just) Nullable.toMaybe c + <|> Codec.map (const Nullable.nothing) (const $ Null.fromUnit ()) codec diff --git a/source/library/Argo/Codec/Array.hs b/source/library/Argo/Codec/Array.hs --- a/source/library/Argo/Codec/Array.hs +++ b/source/library/Argo/Codec/Array.hs @@ -4,19 +4,14 @@ 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.Identifier as Identifier import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Permission as Permission import qualified Argo.Vendor.Map as Map -import qualified Argo.Vendor.Text as Text import qualified Argo.Vendor.Transformers as Trans import qualified Data.Functor.Identity as Identity +import qualified Data.List.NonEmpty as NonEmpty type Array a = Codec.List @@ -33,34 +28,18 @@ Codec.fromListCodec (\permission schemasM -> do schemas <- schemasM - pure - . Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "array" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "items" - , Value.Array . Array.fromList $ fmap - (Schema.toValue . snd) - schemas - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "additionalItems" - , Value.Boolean - . Boolean.fromBool - $ case permission of - Permission.Allow -> True - Permission.Forbid -> False - ) - ] + pure . Schema.unidentified $ Schema.Array + (Just . fromIntegral $ length schemas) + (case permission of + Permission.Allow -> Nothing + Permission.Forbid -> + Just . fromIntegral $ length schemas + ) + (case NonEmpty.nonEmpty $ fmap Schema.maybeRef schemas of + Nothing -> Left Schema.False + Just xs -> Right xs + ) + Nothing ) $ Codec.map Array.toList Array.fromList Codec.arrayCodec @@ -78,10 +57,5 @@ , Codec.encode = \x -> do Trans.tell [Codec.encodeWith c x] pure x - , Codec.schema = - pure - . Schema.unidentified - . Schema.fromValue - . Codec.ref - <$> Codec.getRef c + , Codec.schema = pure . Schema.unidentified <$> Codec.getRef c } diff --git a/source/library/Argo/Codec/Object.hs b/source/library/Argo/Codec/Object.hs --- a/source/library/Argo/Codec/Object.hs +++ b/source/library/Argo/Codec/Object.hs @@ -3,16 +3,14 @@ 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.Null as Null import qualified Argo.Json.Object as Object import qualified Argo.Json.String as String import qualified Argo.Json.Value as Value import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema +import qualified Argo.Type.Optional as Optional import qualified Argo.Type.Permission as Permission import qualified Argo.Vendor.Map as Map import qualified Argo.Vendor.Text as Text @@ -42,45 +40,18 @@ schemas <- schemasM pure . Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "type" - , Value.String . String.fromText $ Text.pack - "object" - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "properties" - , Value.Object . Object.fromList $ fmap - (\((k, _), (_, s)) -> - Member.fromTuple (k, Schema.toValue s) - ) - schemas - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "required" - , Value.Array . Array.fromList $ Maybe.mapMaybe - (\((k, r), _) -> if r - then Just . Value.String $ Name.toString - k - else Nothing - ) - schemas - ) - , Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack - "additionalProperties" - , Value.Boolean - . Boolean.fromBool - $ case permission of - Permission.Allow -> True - Permission.Forbid -> False - ) - ] + . Schema.Object + (fmap + (\((k, _), s) -> (k, Schema.maybeRef s)) + schemas + ) + (Maybe.mapMaybe + (\((k, r), _) -> if r then Just k else Nothing) + schemas + ) + $ case permission of + Permission.Allow -> Nothing + Permission.Forbid -> Just Schema.False ) $ Codec.map Object.toList Object.fromList Codec.objectCodec @@ -88,7 +59,7 @@ required k c = Codec.Codec { Codec.decode = do m <- Codec.decode (optional k c) - case m of + case Optional.toMaybe m of Nothing -> Trans.lift . Trans.throwE @@ -96,42 +67,30 @@ <> show k Just x -> pure x , Codec.encode = \x -> do - Monad.void . Codec.encode (optional k c) $ Just x + Monad.void . Codec.encode (optional k c) $ Optional.just x pure x , Codec.schema = - pure - . (,) (k, True) - . Schema.unidentified - . Schema.fromValue - . Codec.ref - <$> Codec.getRef c + pure . (,) (k, True) . Schema.unidentified <$> Codec.getRef c } -optional :: Name.Name -> Codec.Value a -> Object (Maybe a) +optional :: Name.Name -> Codec.Value a -> Object (Optional.Optional 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 -> if x == Value.Null (Null.fromUnit ()) - then pure Nothing - else Trans.lift $ Trans.throwE y + Left y -> Trans.lift $ Trans.throwE y Right y -> do Trans.put ys - pure $ Just y - _ -> pure Nothing + pure $ Optional.just y + _ -> pure Optional.nothing , Codec.encode = \x -> do - case x of + case Optional.toMaybe x of Nothing -> pure () Just y -> Trans.tell [Member.Member k $ Codec.encodeWith c y] pure x , Codec.schema = - pure - . (,) (k, False) - . Schema.unidentified - . Schema.fromValue - . Codec.ref - <$> Codec.getRef c + pure . (,) (k, False) . Schema.unidentified <$> Codec.getRef c } tagged :: String -> Codec.Value a -> Codec.Value a diff --git a/source/library/Argo/Codec/Value.hs b/source/library/Argo/Codec/Value.hs --- a/source/library/Argo/Codec/Value.hs +++ b/source/library/Argo/Codec/Value.hs @@ -4,11 +4,8 @@ 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.Identifier as Identifier import qualified Argo.Schema.Schema as Schema @@ -86,32 +83,31 @@ <> " but got " <> show actual , Codec.encode = const . Trans.lift $ Trans.put expected - , Codec.schema = - pure - . Schema.unidentified - . Schema.fromValue - . Value.Object - $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "const" - , expected - ) - ] + , Codec.schema = pure . Schema.unidentified $ Schema.Const expected } identified :: forall a . Typeable.Typeable a => Value a -> Value a -identified c = +identified = withIdentifier . Identifier.fromText . Text.pack $ typeName + (Typeable.Proxy :: Typeable.Proxy a) + +withIdentifier :: Identifier.Identifier -> Value a -> Value a +withIdentifier identifier codec = let - i = Identifier.fromText . Text.pack . show $ Typeable.typeRep - (Typeable.Proxy :: Typeable.Proxy a) - in c { Codec.schema = Schema.identified i . snd <$> Codec.schema c } + newSchema = do + (_, schema) <- Codec.schema codec + Trans.add $ Map.singleton identifier schema + pure $ Schema.withIdentifier identifier schema + in codec { Codec.schema = newSchema } +typeName :: Typeable.Typeable a => Typeable.Proxy a -> String +typeName = show . Typeable.typeRep + getRef :: Value a -> Trans.AccumT (Map.Map Identifier.Identifier Schema.Schema) Identity.Identity - (Either Schema.Schema Identifier.Identifier) + Schema.Schema getRef codec = do let (maybeIdentifier, schema) = @@ -119,23 +115,10 @@ (Codec.schema codec) Map.empty case maybeIdentifier of - Nothing -> pure $ Left schema + Nothing -> pure schema Just identifier -> do schemas <- Trans.look Monad.unless (Map.member identifier schemas) $ do Trans.add $ Map.singleton identifier schema Monad.void $ Codec.schema codec - pure $ Right identifier - -ref :: Either Schema.Schema Identifier.Identifier -> Value.Value -ref e = case e of - Left s -> Schema.toValue s - Right i -> Value.Object $ Object.fromList - [ Member.fromTuple - ( Name.fromString . String.fromText $ Text.pack "$ref" - , Value.String - . String.fromText - . mappend (Text.pack "#/definitions/") - $ Identifier.toText i - ) - ] + pure $ Schema.Ref identifier 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,7 +2,6 @@ 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 @@ -11,15 +10,6 @@ { 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/Identifier.hs b/source/library/Argo/Schema/Identifier.hs --- a/source/library/Argo/Schema/Identifier.hs +++ b/source/library/Argo/Schema/Identifier.hs @@ -18,7 +18,7 @@ fromString = fromText . String.fromString instance Semigroup Identifier where - x <> y = fromText $ toText x <> toText y -- TODO: remove this + x <> y = fromText $ toText x <> toText y fromText :: Text.Text -> Identifier fromText = Identifier diff --git a/source/library/Argo/Schema/Schema.hs b/source/library/Argo/Schema/Schema.hs --- a/source/library/Argo/Schema/Schema.hs +++ b/source/library/Argo/Schema/Schema.hs @@ -4,51 +4,65 @@ 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.Schema.Identifier as Identifier import qualified Argo.Vendor.DeepSeq as DeepSeq import qualified Argo.Vendor.TemplateHaskell as TH import qualified Argo.Vendor.Text as Text +import qualified Data.List.NonEmpty as NonEmpty import qualified GHC.Generics as Generics +import qualified Numeric.Natural as Natural -- | A JSON Schema. -- -newtype Schema - = Schema Value.Value +data Schema + = Array + (Maybe Natural.Natural) + (Maybe Natural.Natural) + (Either Schema (NonEmpty.NonEmpty Schema)) + (Maybe Schema) + | Boolean + | Const Value.Value + | False + | Integer (Maybe Integer) (Maybe Integer) + | Null + | Number + | Object [(Name.Name, Schema)] [Name.Name] (Maybe Schema) + | OneOf [Schema] + | Ref Identifier.Identifier + | String (Maybe Natural.Natural) (Maybe Natural.Natural) + | True 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] - ) - ] + x <> y = case (x, y) of + (OneOf xs, OneOf ys) -> OneOf $ xs <> ys + (OneOf xs, _) -> OneOf $ y : xs + (_, OneOf ys) -> OneOf $ x : ys + (_, _) -> OneOf [x, y] instance Monoid Schema where - mempty = true + mempty = Argo.Schema.Schema.True -fromValue :: Value.Value -> Schema -fromValue = Schema +member :: String -> a -> Member.Member a +member k v = + Member.fromTuple (Name.fromString . String.fromText $ Text.pack k, v) -toValue :: Schema -> Value.Value -toValue (Schema x) = x +maybeRef :: (Maybe Identifier.Identifier, Schema) -> Schema +maybeRef (m, s) = maybe s Ref m false :: Schema -false = fromValue . Value.Boolean $ Boolean.fromBool False +false = Argo.Schema.Schema.False true :: Schema -true = fromValue . Value.Boolean $ Boolean.fromBool True +true = Argo.Schema.Schema.True unidentified :: Schema -> (Maybe Identifier.Identifier, Schema) unidentified s = (Nothing, s) -identified +withIdentifier :: Identifier.Identifier -> Schema -> (Maybe Identifier.Identifier, Schema) -identified i s = (Just i, s) +withIdentifier i s = (Just i, s) diff --git a/source/library/Argo/Type/Nullable.hs b/source/library/Argo/Type/Nullable.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Type/Nullable.hs @@ -0,0 +1,17 @@ +module Argo.Type.Nullable where + +newtype Nullable a + = Nullable (Maybe a) + deriving (Eq, Show) + +fromMaybe :: Maybe a -> Nullable a +fromMaybe = Nullable + +toMaybe :: Nullable a -> Maybe a +toMaybe (Nullable x) = x + +nothing :: Nullable a +nothing = fromMaybe Nothing + +just :: a -> Nullable a +just = fromMaybe . Just diff --git a/source/library/Argo/Type/Optional.hs b/source/library/Argo/Type/Optional.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Type/Optional.hs @@ -0,0 +1,17 @@ +module Argo.Type.Optional where + +newtype Optional a + = Optional (Maybe a) + deriving (Eq, Show) + +fromMaybe :: Maybe a -> Optional a +fromMaybe = Optional + +toMaybe :: Optional a -> Maybe a +toMaybe (Optional x) = x + +nothing :: Optional a +nothing = fromMaybe Nothing + +just :: a -> Optional a +just = fromMaybe . Just diff --git a/source/library/Argo/Type/Permission.hs b/source/library/Argo/Type/Permission.hs --- a/source/library/Argo/Type/Permission.hs +++ b/source/library/Argo/Type/Permission.hs @@ -1,6 +1,19 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + module Argo.Type.Permission where +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified GHC.Generics as Generics + data Permission = Allow | Forbid - deriving (Eq, Show) + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +toBool :: Permission -> Bool +toBool x = case x of + Allow -> True + Forbid -> False diff --git a/source/library/Argo/Vendor/Text.hs b/source/library/Argo/Vendor/Text.hs --- a/source/library/Argo/Vendor/Text.hs +++ b/source/library/Argo/Vendor/Text.hs @@ -8,6 +8,7 @@ , Text.null , Text.pack , Text.singleton + , Text.stripPrefix , LazyText.toStrict , Text.uncons , Text.unpack 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,6 +7,7 @@ import Test.Tasty.QuickCheck ((===)) import qualified Argo +import qualified Argo.Class.HasCodec as HasCodec import qualified Argo.Codec.Codec as Codec import qualified Argo.Codec.Object as Codec import qualified Argo.Codec.Value as Codec @@ -20,6 +21,8 @@ import qualified Argo.Schema.Identifier as Identifier import qualified Argo.Schema.Schema as Schema import qualified Argo.Type.Decimal as Decimal +import qualified Argo.Type.Nullable as Nullable +import qualified Argo.Type.Optional as Optional import qualified Argo.Type.Permission as Permission import qualified Control.Monad.Trans.Accum as Accum import qualified Data.ByteString as ByteString @@ -31,6 +34,7 @@ import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.Word as Word +import qualified GHC.Stack as Stack import qualified Numeric.Natural as Natural import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty @@ -627,10 +631,10 @@ (Argo.Array [Argo.String "", Argo.Boolean False]) @?= Right ("" :: Text.Text, False) , Tasty.testCase "encode record" $ do - Codec.encodeWith Argo.codec (Record False Nothing) + Codec.encodeWith Argo.codec (Record False Optional.nothing) @?= Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False] - Codec.encodeWith Argo.codec (Record False $ Just "") + Codec.encodeWith Argo.codec (Record False $ Optional.just "") @?= Argo.Object [ Argo.Member (Argo.Name "bool") $ Argo.Boolean False , Argo.Member (Argo.Name "text") $ Argo.String "" @@ -641,7 +645,7 @@ (Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False] ) - @?= Right (Record False Nothing) + @?= Right (Record False Optional.nothing) Codec.decodeWith Argo.codec (Argo.Object @@ -649,7 +653,7 @@ , Argo.Member (Argo.Name "text") $ Argo.String "" ] ) - @?= Right (Record False $ Just "") + @?= Right (Record False $ Optional.just "") ] , Tasty.testGroup "Pointer" $ let pointer = Argo.Pointer . fmap Argo.Token @@ -737,111 +741,142 @@ , Tasty.testGroup "Schema" [ Tasty.testCase "value" $ do - let expected = schemafy (Just "Value") [Argo.schema| true |] - actual = Codec.schema (Argo.codec :: Codec.Value Argo.Value) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Value") + [Argo.value| true |] + (Codec.schema (Argo.codec :: Codec.Value Argo.Value)) , Tasty.testCase "null" $ do - let expected = - schemafy (Just "Null") [Argo.schema| { "type": "null" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Null.Null) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Null") + [Argo.value| { "type": "null" } |] + (Codec.schema (Argo.codec :: Codec.Value Null.Null)) , Tasty.testCase "boolean" $ do - let expected = schemafy - (Just "Boolean") - [Argo.schema| { "type": "boolean" } |] - actual = - Codec.schema (Argo.codec :: Codec.Value Boolean.Boolean) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Boolean") + [Argo.value| { "type": "boolean" } |] + (Codec.schema (Argo.codec :: Codec.Value Boolean.Boolean)) , Tasty.testCase "number" $ do - let expected = schemafy - (Just "Number") - [Argo.schema| { "type": "number" } |] - actual = - Codec.schema (Argo.codec :: Codec.Value Number.Number) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Number") + [Argo.value| { "type": "number" } |] + (Codec.schema (Argo.codec :: Codec.Value Number.Number)) , Tasty.testCase "string" $ do - let expected = schemafy - (Just "String") - [Argo.schema| { "type": "string" } |] - actual = - Codec.schema (Argo.codec :: Codec.Value String.String) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "String") + [Argo.value| { "type": "string" } |] + (Codec.schema (Argo.codec :: Codec.Value String.String)) , Tasty.testCase "array boolean" $ do - let expected = schemafy - (Just "Array Boolean") - [Argo.schema| { "type": "array", "items": { "$ref": "#/definitions/Boolean" } } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Array.Array Boolean.Boolean) - ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Array Boolean") + [Argo.value| { + "type": "array", + "items": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema + (Argo.codec :: Codec.Value (Array.Array Boolean.Boolean)) + ) , Tasty.testCase "object boolean" $ do - let expected = schemafy - (Just "Object Boolean") - [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Object.Object Boolean.Boolean) - ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Object Boolean") + [Argo.value| { + "type": "object", + "additionalProperties": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema + (Argo.codec :: Codec.Value (Object.Object Boolean.Boolean)) + ) , Tasty.testCase "maybe boolean" $ do - let expected = schemafy - (Just "Maybe Boolean") - [Argo.schema| { "oneOf": [ { "type": "boolean" }, { "type": "null" } ] } |] - actual = Codec.schema + schemaTest + (Just "Maybe Boolean") + [Argo.value| { "oneOf": [ + { "type": "boolean" }, + { "type": "null" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value (Maybe Boolean.Boolean)) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "either boolean number" $ do - let expected = schemafy - (Just "Either Boolean Number") - [Argo.schema| { "oneOf": [ { "type": "object", "properties": { "type": { "const": "Left" }, "value": { "$ref": "#/definitions/Boolean" } }, "required": [ "type", "value" ], "additionalProperties": false }, { "type": "object", "properties": { "type": { "const": "Right" }, "value": { "$ref": "#/definitions/Number" } }, "required": [ "type", "value" ], "additionalProperties": false } ] } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Either Boolean.Boolean Number.Number) - ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Either Boolean Number") + [Argo.value| { "oneOf": [ + { + "type": "object", + "properties": { + "type": { "const": "Left" }, + "value": { "$ref": "#/definitions/Boolean" } + }, + "required": [ "type", "value" ], + "additionalProperties": false }, + { + "type": "object", + "properties": { + "type": { "const": "Right" }, + "value": { "$ref": "#/definitions/Number" } + }, + "required": [ "type", "value" ], + "additionalProperties": false + } + ] } |] + (Codec.schema + (Argo.codec :: Codec.Value + (Either Boolean.Boolean Number.Number) + ) + ) , Tasty.testCase "()" $ do - let expected = schemafy - (Just "()") - [Argo.schema| { "type": "array", "items": [], "additionalItems": false } |] - actual = Codec.schema (Argo.codec :: Codec.Value ()) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "()") + [Argo.value| { + "type": "array", + "minItems": 0, + "maxItems": 0, + "items": false + } |] + (Codec.schema (Argo.codec :: Codec.Value ())) , Tasty.testCase "2-tuple" $ do - let expected = schemafy - (Just "(Value,Null)") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null)") + [Argo.value| { + "type": "array", + "minItems": 2, + "maxItems": 2, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value (Argo.Value, Null.Null)) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "3-tuple" $ do - let expected = schemafy - (Just "(Value,Null,Boolean)") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - , { "$ref": "#/definitions/Boolean" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null,Boolean)") + [Argo.value| { + "type": "array", + "minItems": 3, + "maxItems": 3, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" }, + { "$ref": "#/definitions/Boolean" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value (Argo.Value, Null.Null, Boolean.Boolean) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "4-tuple" $ do - let expected = schemafy - (Just "(Value,Null,Boolean,Number)") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - , { "$ref": "#/definitions/Boolean" } - , { "$ref": "#/definitions/Number" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null,Boolean,Number)") + [Argo.value| { + "type": "array", + "minItems": 4, + "maxItems": 4, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" }, + { "$ref": "#/definitions/Boolean" }, + { "$ref": "#/definitions/Number" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value ( Argo.Value , Null.Null @@ -849,18 +884,22 @@ , Number.Number ) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "5-tuple" $ do - let expected = schemafy - (Just "(Value,Null,Boolean,Number,Integer)") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - , { "$ref": "#/definitions/Boolean" } - , { "$ref": "#/definitions/Number" } - , { "$ref": "#/definitions/Integer" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null,Boolean,Number,Integer)") + [Argo.value| { + "type": "array", + "minItems": 5, + "maxItems": 5, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" }, + { "$ref": "#/definitions/Boolean" }, + { "$ref": "#/definitions/Number" }, + { "$ref": "#/definitions/Integer" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value ( Argo.Value , Null.Null @@ -869,19 +908,23 @@ , Integer ) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "6-tuple" $ do - let expected = schemafy - (Just "(Value,Null,Boolean,Number,Integer,String)") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - , { "$ref": "#/definitions/Boolean" } - , { "$ref": "#/definitions/Number" } - , { "$ref": "#/definitions/Integer" } - , { "$ref": "#/definitions/String" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null,Boolean,Number,Integer,String)") + [Argo.value| { + "type": "array", + "minItems": 6, + "maxItems": 6, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" }, + { "$ref": "#/definitions/Boolean" }, + { "$ref": "#/definitions/Number" }, + { "$ref": "#/definitions/Integer" }, + { "$ref": "#/definitions/String" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value ( Argo.Value , Null.Null @@ -891,20 +934,24 @@ , String.String ) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "7-tuple" $ do - let expected = schemafy - (Just "(Value,Null,Boolean,Number,Integer,String,())") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - , { "$ref": "#/definitions/Boolean" } - , { "$ref": "#/definitions/Number" } - , { "$ref": "#/definitions/Integer" } - , { "$ref": "#/definitions/String" } - , { "$ref": "#/definitions/()" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null,Boolean,Number,Integer,String,())") + [Argo.value| { + "type": "array", + "minItems": 7, + "maxItems": 7, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" }, + { "$ref": "#/definitions/Boolean" }, + { "$ref": "#/definitions/Number" }, + { "$ref": "#/definitions/Integer" }, + { "$ref": "#/definitions/String" }, + { "$ref": "#/definitions/()" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value ( Argo.Value , Null.Null @@ -915,21 +962,25 @@ , () ) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "8-tuple" $ do - let expected = schemafy - (Just "(Value,Null,Boolean,Number,Integer,String,(),Char)") - [Argo.schema| { "type": "array", "items": - [ { "$ref": "#/definitions/Value" } - , { "$ref": "#/definitions/Null" } - , { "$ref": "#/definitions/Boolean" } - , { "$ref": "#/definitions/Number" } - , { "$ref": "#/definitions/Integer" } - , { "$ref": "#/definitions/String" } - , { "$ref": "#/definitions/()" } - , { "$ref": "#/definitions/Char" } - ], "additionalItems": false } |] - actual = Codec.schema + schemaTest + (Just "(Value,Null,Boolean,Number,Integer,String,(),Char)") + [Argo.value| { + "type": "array", + "minItems": 8, + "maxItems": 8, + "items": [ + { "$ref": "#/definitions/Value" }, + { "$ref": "#/definitions/Null" }, + { "$ref": "#/definitions/Boolean" }, + { "$ref": "#/definitions/Number" }, + { "$ref": "#/definitions/Integer" }, + { "$ref": "#/definitions/String" }, + { "$ref": "#/definitions/()" }, + { "$ref": "#/definitions/Char" } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value ( Argo.Value , Null.Null @@ -941,251 +992,411 @@ , Char ) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "bool" $ do - let expected = schemafy - (Just "Bool") - [Argo.schema| { "type": "boolean" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Bool) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Bool") + [Argo.value| { "type": "boolean" } |] + (Codec.schema (Argo.codec :: Codec.Value Bool)) , Tasty.testCase "decimal" $ do - let expected = schemafy - (Just "Decimal") - [Argo.schema| { "type": "number" } |] - actual = - Codec.schema (Argo.codec :: Codec.Value Decimal.Decimal) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Decimal") + [Argo.value| { "type": "number" } |] + (Codec.schema (Argo.codec :: Codec.Value Decimal.Decimal)) , Tasty.testCase "text" $ do - let expected = schemafy - (Just "Text") - [Argo.schema| { "type": "string" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Text.Text) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Text") + [Argo.value| { "type": "string" } |] + (Codec.schema (Argo.codec :: Codec.Value Text.Text)) , Tasty.testCase "list boolean" $ do - let expected = schemafy - (Just "[Boolean]") - [Argo.schema| { "type": "array", "items": { "$ref": "#/definitions/Boolean" } } |] - actual = - Codec.schema (Argo.codec :: Codec.Value [Boolean.Boolean]) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "[Boolean]") + [Argo.value| { + "type": "array", + "items": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema (Argo.codec :: Codec.Value [Boolean.Boolean])) , Tasty.testCase "map name boolean" $ do - let expected = schemafy - (Just "Map Name Boolean") - [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Map.Map Name.Name Boolean.Boolean) - ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Map Name Boolean") + [Argo.value| { + "type": "object", + "additionalProperties": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema + (Argo.codec :: Codec.Value + (Map.Map Name.Name Boolean.Boolean) + ) + ) , Tasty.testCase "map (argo) string boolean" $ do - let expected = schemafy - (Just "Map String Boolean") - [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] - actual = Codec.schema + schemaTest + (Just "Map String Boolean") + [Argo.value| { + "type": "object", + "additionalProperties": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema (Argo.codec :: Codec.Value (Map.Map String.String Boolean.Boolean) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "map (strict) text boolean" $ do - let expected = schemafy - (Just "Map Text Boolean") - [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Map.Map Text.Text Boolean.Boolean) - ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Map Text Boolean") + [Argo.value| { + "type": "object", + "additionalProperties": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema + (Argo.codec :: Codec.Value + (Map.Map Text.Text Boolean.Boolean) + ) + ) , Tasty.testCase "map (lazy) text boolean" $ do - let expected = schemafy - (Just "Map Text Boolean") - [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] - actual = Codec.schema + schemaTest + (Just "Map Text Boolean") + [Argo.value| { + "type": "object", + "additionalProperties": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema (Argo.codec :: Codec.Value (Map.Map LazyText.Text Boolean.Boolean) ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "map (base) string boolean" $ do - let expected = schemafy - (Just "Map [Char] Boolean") - [Argo.schema| { "type": "object", "additionalProperties": { "$ref": "#/definitions/Boolean" } } |] - actual = - Codec.schema - (Argo.codec :: Codec.Value - (Map.Map String Boolean.Boolean) - ) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Map [Char] Boolean") + [Argo.value| { + "type": "object", + "additionalProperties": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema + (Argo.codec :: Codec.Value (Map.Map String Boolean.Boolean) + ) + ) , Tasty.testCase "string" $ do - let expected = schemafy - (Just "[Char]") - [Argo.schema| { "type": "string" } |] - actual = Codec.schema (Argo.codec :: Codec.Value String) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "[Char]") + [Argo.value| { "type": "string" } |] + (Codec.schema (Argo.codec :: Codec.Value String)) , Tasty.testCase "char" $ do - let expected = schemafy - (Just "Char") - [Argo.schema| { "type": "string", "minLength": 1, "maxLength": 1 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Char) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Char") + [Argo.value| { + "type": "string", + "minLength": 1, + "maxLength": 1 + } |] + (Codec.schema (Argo.codec :: Codec.Value Char)) , Tasty.testCase "lazy text" $ do - let expected = schemafy - (Just "Text") - [Argo.schema| { "type": "string" } |] - actual = - Codec.schema (Argo.codec :: Codec.Value LazyText.Text) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Text") + [Argo.value| { "type": "string" } |] + (Codec.schema (Argo.codec :: Codec.Value LazyText.Text)) , Tasty.testCase "non-empty boolean" $ do - let expected = schemafy - (Just "NonEmpty Boolean") - [Argo.schema| { "type": "array", "items": { "type": "boolean" }, "minItems": 1 } |] - actual = Codec.schema + schemaTest + (Just "NonEmpty Boolean") + [Argo.value| { + "type": "array", + "minItems": 1, + "items": { "$ref": "#/definitions/Boolean" } + } |] + (Codec.schema (Argo.codec :: Codec.Value (NonEmpty Boolean.Boolean)) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + ) , Tasty.testCase "integer" $ do - let expected = schemafy - (Just "Integer") - [Argo.schema| { "type": "integer" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Integer) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Integer") + [Argo.value| { "type": "integer" } |] + (Codec.schema (Argo.codec :: Codec.Value Integer)) , Tasty.testCase "int" $ do - let expected = schemafy - (Just "Int") - [Argo.schema| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Int) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Int") + [Argo.value| { + "type": "integer", + "minimum": -9223372036854775808, + "maximum": 9223372036854775807 + } |] + (Codec.schema (Argo.codec :: Codec.Value Int)) , Tasty.testCase "int8" $ do - let expected = schemafy - (Just "Int8") - [Argo.schema| { "type": "integer", "minimum": -128, "maximum": 127 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Int.Int8) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Int8") + [Argo.value| { + "type": "integer", + "minimum": -128, + "maximum": 127 + } |] + (Codec.schema (Argo.codec :: Codec.Value Int.Int8)) , Tasty.testCase "int16" $ do - let expected = schemafy - (Just "Int16") - [Argo.schema| { "type": "integer", "minimum": -32768, "maximum": 32767 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Int.Int16) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Int16") + [Argo.value| { + "type": "integer", + "minimum": -32768, + "maximum": 32767 + } |] + (Codec.schema (Argo.codec :: Codec.Value Int.Int16)) , Tasty.testCase "int32" $ do - let expected = schemafy - (Just "Int32") - [Argo.schema| { "type": "integer", "minimum": -2147483648, "maximum": 2147483647 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Int.Int32) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Int32") + [Argo.value| { + "type": "integer", + "minimum": -2147483648, + "maximum": 2147483647 + } |] + (Codec.schema (Argo.codec :: Codec.Value Int.Int32)) , Tasty.testCase "int64" $ do - let expected = schemafy - (Just "Int64") - [Argo.schema| { "type": "integer", "minimum": -9223372036854775808, "maximum": 9223372036854775807 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Int.Int64) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Int64") + [Argo.value| { + "type": "integer", + "minimum": -9223372036854775808, + "maximum": 9223372036854775807 + } |] + (Codec.schema (Argo.codec :: Codec.Value Int.Int64)) , Tasty.testCase "natural" $ do - let expected = schemafy - (Just "Natural") - [Argo.schema| { "type": "integer", "minimum": 0 } |] - actual = - Codec.schema (Argo.codec :: Codec.Value Natural.Natural) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Natural") + [Argo.value| { + "type": "integer", + "minimum": 0 + } |] + (Codec.schema (Argo.codec :: Codec.Value Natural.Natural)) , Tasty.testCase "word" $ do - let expected = schemafy - (Just "Word") - [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Word) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Word") + [Argo.value| { + "type": "integer", + "minimum": 0, + "maximum": 18446744073709551615 + } |] + (Codec.schema (Argo.codec :: Codec.Value Word)) , Tasty.testCase "word8" $ do - let expected = schemafy - (Just "Word8") - [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 255 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Word.Word8) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Word8") + [Argo.value| { + "type": "integer", + "minimum": 0, + "maximum": 255 + } |] + (Codec.schema (Argo.codec :: Codec.Value Word.Word8)) , Tasty.testCase "word16" $ do - let expected = schemafy - (Just "Word16") - [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 65535 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Word.Word16) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Word16") + [Argo.value| { + "type": "integer", + "minimum": 0, + "maximum": 65535 + } |] + (Codec.schema (Argo.codec :: Codec.Value Word.Word16)) , Tasty.testCase "word32" $ do - let expected = schemafy - (Just "Word32") - [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 4294967295 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Word.Word32) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Word32") + [Argo.value| { + "type": "integer", + "minimum": 0, + "maximum": 4294967295 + } |] + (Codec.schema (Argo.codec :: Codec.Value Word.Word32)) , Tasty.testCase "word64" $ do - let expected = schemafy - (Just "Word64") - [Argo.schema| { "type": "integer", "minimum": 0, "maximum": 18446744073709551615 } |] - actual = Codec.schema (Argo.codec :: Codec.Value Word.Word64) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Word64") + [Argo.value| { + "type": "integer", + "minimum": 0, + "maximum": 18446744073709551615 + } |] + (Codec.schema (Argo.codec :: Codec.Value Word.Word64)) , Tasty.testCase "float" $ do - let expected = schemafy - (Just "Float") - [Argo.schema| { "type": "number" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Float) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Float") + [Argo.value| { "type": "number" } |] + (Codec.schema (Argo.codec :: Codec.Value Float)) , Tasty.testCase "double" $ do - let expected = schemafy - (Just "Double") - [Argo.schema| { "type": "number" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Double) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Double") + [Argo.value| { "type": "number" } |] + (Codec.schema (Argo.codec :: Codec.Value Double)) , Tasty.testCase "pointer" $ do - let expected = schemafy - (Just "Pointer") - [Argo.schema| { "type": "string" } |] - actual = Codec.schema (Argo.codec :: Codec.Value Argo.Pointer) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Pointer") + [Argo.value| { "type": "string" } |] + (Codec.schema (Argo.codec :: Codec.Value Argo.Pointer)) , Tasty.testCase "schema" $ do - let expected = schemafy (Just "Schema") [Argo.schema| true |] - actual = - Codec.schema (Argo.codec :: Codec.Value Schema.Schema) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + (Just "Schema") + [Argo.value| { "oneOf": [ + { + "type": "object", + "properties": { "oneOf": { "$ref": "#/definitions/[Schema]" } }, + "required": [ "oneOf" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { "$ref": { "$ref": "#/definitions/Identifier" } }, + "required": [ "$ref" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { + "type": { "const": "object" }, + "properties": { "$ref": "#/definitions/Object Schema" }, + "required": { "$ref": "#/definitions/[Name]" }, + "additionalProperties": { "$ref": "#/definitions/Schema" } + }, + "required": [ "type" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { + "type": { "const": "array" }, + "minItems": { "$ref": "#/definitions/Natural" }, + "maxItems": { "$ref": "#/definitions/Natural" }, + "items": { "$ref": "#/definitions/OneOf Schema [Schema]" }, + "additionalItems": { "$ref": "#/definitions/Schema" } + }, + "required": [ "type", "items" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { + "type": { "const": "string" }, + "minLength": { "$ref": "#/definitions/Natural" }, + "maxLength": { "$ref": "#/definitions/Natural" } + }, + "required": [ "type" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { + "type": { "const": "integer" }, + "minimum": { "$ref": "#/definitions/Integer" }, + "maximum": { "$ref": "#/definitions/Integer" } + }, + "required": [ "type" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { "type": { "const": "number" } }, + "required": [ "type" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { "type": { "const": "boolean" } }, + "required": [ "type" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { "type": { "const": "null" } }, + "required": [ "type" ], + "additionalProperties": false + }, + { + "type": "object", + "properties": { "const": { "$ref": "#/definitions/Value" } }, + "required": [ "const" ], + "additionalProperties": false + }, + { + "const": true + }, + { + "const": false + } + ] } |] + (Codec.schema (Argo.codec :: Codec.Value Schema.Schema)) , Tasty.testCase "record" $ do - let expected = schemafy - Nothing - [Argo.schema| { "type": "object", "properties": { "bool": { "$ref": "#/definitions/Bool" }, "text": { "$ref": "#/definitions/Text" } }, "required": [ "bool" ], "additionalProperties": true } |] - actual = Codec.schema (Argo.codec :: Codec.Value Record) - Accum.evalAccumT actual mempty @?= Accum.evalAccumT expected mempty + schemaTest + Nothing + [Argo.value| { + "type": "object", + "properties": { + "bool": { "$ref": "#/definitions/Bool" }, + "text": { "$ref": "#/definitions/Text" } + }, + "required": [ "bool" ] + } |] + (Codec.schema (Argo.codec :: Codec.Value Record)) ] , Tasty.testGroup "T1" $ let codec = Argo.codec :: Codec.Value T1 in [ Tasty.testCase "schema" $ do - let expected = schemafy - Nothing - [Argo.schema| - { - "type": "object", - "properties": { - "t1c1f1": { "$ref": "#/definitions/Float" }, - "t1c1f2": { "$ref": "#/definitions/Maybe Float" }, - "t1c1f3": { "$ref": "#/definitions/Float" }, - "t1c1f4": { "$ref": "#/definitions/Maybe Float" } - }, - "required": [ "t1c1f1", "t1c1f2" ], - "additionalProperties": true - } - |] - actual = Codec.schema codec - Accum.evalAccumT actual mempty - @?= Accum.evalAccumT expected mempty + schemaTest + Nothing + [Argo.value| + { + "type": "object", + "properties": { + "t1c1f1": { "$ref": "#/definitions/Float" }, + "t1c1f2": { "$ref": "#/definitions/Nullable Float" }, + "t1c1f3": { "$ref": "#/definitions/Float" }, + "t1c1f4": { "$ref": "#/definitions/Nullable Float" } + }, + "required": [ "t1c1f1", "t1c1f2" ] + } + |] + (Codec.schema codec) , Tasty.testCase "decode" $ do hush (Argo.decode "{ \"t1c1f1\": 0 }") @?= (Nothing :: Maybe T1) Argo.decode "{ \"t1c1f1\": 0, \"t1c1f2\": null }" - @?= Right (T1C1 0 Nothing Nothing Nothing) + @?= Right + (T1C1 + 0 + Nullable.nothing + Optional.nothing + Optional.nothing + ) Argo.decode "{ \"t1c1f1\": 1, \"t1c1f2\": 0 }" - @?= Right (T1C1 1 (Just 0) Nothing Nothing) - Argo.decode - "{ \"t1c1f1\": 2, \"t1c1f2\": null, \"t1c1f3\": null }" - @?= Right (T1C1 2 Nothing Nothing Nothing) + @?= Right + (T1C1 + 1 + (Nullable.just 0) + Optional.nothing + Optional.nothing + ) + hush + (Argo.decode + "{ \"t1c1f1\": 2, \"t1c1f2\": null, \"t1c1f3\": null }" + ) + @?= (Nothing :: Maybe T1) Argo.decode "{ \"t1c1f1\": 3, \"t1c1f2\": null, \"t1c1f3\": 0 }" - @?= Right (T1C1 3 Nothing (Just 0) Nothing) + @?= Right + (T1C1 + 3 + Nullable.nothing + (Optional.just 0) + Optional.nothing + ) Argo.decode "{ \"t1c1f1\": 4, \"t1c1f2\": null, \"t1c1f4\": null }" - @?= Right (T1C1 4 Nothing Nothing (Just Nothing)) + @?= Right + (T1C1 + 4 + Nullable.nothing + Optional.nothing + (Optional.just Nullable.nothing) + ) Argo.decode "{ \"t1c1f1\": 5, \"t1c1f2\": null, \"t1c1f4\": 0 }" - @?= Right (T1C1 5 Nothing Nothing (Just (Just 0))) + @?= Right + (T1C1 + 5 + Nullable.nothing + Optional.nothing + (Optional.just $ Nullable.just 0) + ) hush (Argo.decode "{ \"t1c1f1\": 6, \"t1c1f2\": [] }") @?= (Nothing :: Maybe T1) hush @@ -1203,28 +1414,84 @@ encode = Builder.toLazyByteString . Argo.encode :: T1 -> LazyByteString.ByteString - encode (T1C1 0 Nothing Nothing Nothing) + encode + (T1C1 + 0 + Nullable.nothing + Optional.nothing + Optional.nothing + ) @?= "{\"t1c1f1\":0,\"t1c1f2\":null}" - encode (T1C1 1 (Just 0) Nothing Nothing) + encode + (T1C1 + 1 + (Nullable.just 0) + Optional.nothing + Optional.nothing + ) @?= "{\"t1c1f1\":1,\"t1c1f2\":0}" - encode (T1C1 2 Nothing (Just 0) Nothing) + encode + (T1C1 + 2 + Nullable.nothing + (Optional.just 0) + Optional.nothing + ) @?= "{\"t1c1f1\":2,\"t1c1f2\":null,\"t1c1f3\":0}" - encode (T1C1 3 Nothing Nothing (Just Nothing)) + encode + (T1C1 + 3 + Nullable.nothing + Optional.nothing + (Optional.just Nullable.nothing) + ) @?= "{\"t1c1f1\":3,\"t1c1f2\":null,\"t1c1f4\":null}" - encode (T1C1 4 Nothing Nothing (Just (Just 0))) + encode + (T1C1 + 4 + Nullable.nothing + Optional.nothing + (Optional.just $ Nullable.just 0) + ) @?= "{\"t1c1f1\":4,\"t1c1f2\":null,\"t1c1f4\":0}" ] , Tasty.testCase "T2" $ do - let schema = [Argo.schema| - { "type": "object" - , "properties": { "t2c1f1": { "$ref": "#/definitions/T2" } } - , "required": [] - , "additionalProperties": true + let schema = [Argo.value| { + "type": "object", + "properties": { "t2c1f1": { "$ref": "#/definitions/T2" } }, + "additionalProperties": false + } |] + ((i, s), m) = Accum.runAccum + (Codec.schema (Argo.codec :: Codec.Value T2)) + Map.empty + i @?= Just "T2" + toValue s @?= schema + fmap toValue m @?= Map.singleton "T2" schema + , Tasty.testGroup + "T3" + [ Tasty.testCase "schema" $ do + schemaTest + Nothing + [Argo.value| { + "type": "object", + "properties": { + "t3c1f1": { "$ref": "#/definitions/Nullable Float" } + }, + "additionalProperties": false } |] - expected = schemafy (Just "T2") schema - actual = Codec.schema (Argo.codec :: Codec.Value T2) - Accum.runAccum actual mempty - @?= (Accum.evalAccum expected mempty, Map.singleton "T2" schema) + (Codec.schema (Argo.codec :: Codec.Value T3)) + , Tasty.testCase "decode" $ do + Argo.decode "{}" @?= Right (T3C1 Nothing) + Argo.decode "{ \"t3c1f1\": null }" @?= Right (T3C1 Nothing) + Argo.decode "{ \"t3c1f1\": 0 }" @?= Right (T3C1 $ Just 0) + , Tasty.testCase "encode" $ do + let + encode = + Builder.toLazyByteString . Argo.encode :: T3 + -> LazyByteString.ByteString + encode (T3C1 Nothing) @?= "{}" + encode (T3C1 $ Just 0) @?= "{\"t3c1f1\":0}" + ] ] fromValue :: Argo.HasCodec a => Argo.Value -> Either String a @@ -1237,21 +1504,21 @@ number s = Argo.Number . Argo.Decimal s newtype T2 = T2C1 - { t2c1f1 :: Maybe T2 + { t2c1f1 :: Optional.Optional T2 } deriving (Eq, Show) instance Argo.HasCodec T2 where codec = Codec.identified - . Codec.fromObjectCodec Permission.Allow + . Codec.fromObjectCodec Permission.Forbid $ T2C1 <$> Codec.project t2c1f1 (Codec.optional "t2c1f1" Argo.codec) data T1 = T1C1 { t1c1f1 :: Float - , t1c1f2 :: Maybe Float - , t1c1f3 :: Maybe Float - , t1c1f4 :: Maybe (Maybe Float) + , t1c1f2 :: Nullable.Nullable Float + , t1c1f3 :: Optional.Optional Float + , t1c1f4 :: Optional.Optional (Nullable.Nullable Float) } deriving (Eq, Show) @@ -1264,9 +1531,19 @@ <*> Codec.project t1c1f3 (Codec.optional "t1c1f3" Argo.codec) <*> Codec.project t1c1f4 (Codec.optional "t1c1f4" Argo.codec) +newtype T3 = T3C1 + { t3c1f1 :: Maybe Float + } + deriving (Eq, Show) + +instance Argo.HasCodec T3 where + codec = Codec.fromObjectCodec Permission.Forbid $ T3C1 <$> Codec.project + t3c1f1 + (HasCodec.optionalNullable "t3c1f1" Argo.codec) + data Record = Record { recordBool :: Bool - , recordText :: Maybe Text.Text + , recordText :: Optional.Optional Text.Text } deriving (Eq, Show) @@ -1301,11 +1578,15 @@ hush :: Either String a -> Maybe a hush = either (const Nothing) Just -schemafy - :: Maybe Identifier.Identifier - -> Schema.Schema +schemaTest + :: Stack.HasCallStack + => Maybe Identifier.Identifier + -> Argo.Value -> Accum.AccumT (Map.Map Identifier.Identifier Schema.Schema) Identity.Identity (Maybe Identifier.Identifier, Schema.Schema) -schemafy m = pure . maybe Schema.unidentified Schema.identified m + -> Tasty.Assertion +schemaTest maybeIdentifier value schema = + fmap toValue (Accum.evalAccum schema Map.empty) + @?= (maybeIdentifier, value)