diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for schemas +## 0.3.0 -- 2019-10-23 +* Fixed a bug in isSubtypeOf for unions +* Fixed exponential performance (#3) +* Changed the representation of untyped schemas to remove Alternatives + Alternatives are only possible on typed schemas +* Added support for recursive schemas (#1) + ## 0.2.0.3 -- 2019-10-13 * Bug fixes and performance improvements diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -[![CI](https://travis-ci.com/pepeiborra/schemas.svg)](https://travis-ci.org/pepeiborra/threepenny-editors) -[![Hackage](https://img.shields.io/hackage/v/schemas.svg)](https://hackage.haskell.org/package/threepenny-editors) +[![CI](https://travis-ci.com/pepeiborra/schemas.svg)](https://travis-ci.com/pepeiborra/schemas) +[![Hackage](https://img.shields.io/hackage/v/schemas.svg)](https://hackage.haskell.org/package/schemas) # schemas schemas is a Haskell-centric serialization library written with versioning in mind. Since a schema is a first-class citizen, it can be serialized, reasoned about, and transmitted together with the data. Serialization and deserialization work better when the source schema is provided, and versioning is accomplished by checking that the two schemas are related by a subtyping relation. This alleviates the need to keep old versions of datatypes around. diff --git a/example/Person3.hs b/example/Person3.hs --- a/example/Person3.hs +++ b/example/Person3.hs @@ -18,12 +18,13 @@ , addresses :: [String] , spouse :: Maybe Person3 , religion :: Maybe Religion - , education :: Education + , education :: [Education] } deriving (Eq, Show) instance HasSchema Person3 where - schema = record + schema = named "Person3" + $ record $ Person3 <$> field "name" Person3.name <*> field "age" Person3.age <*> field "addresses" Person3.addresses @@ -40,12 +41,12 @@ ["2 Edward Square", "La Mar 10"] (Just laura3) Nothing - (PhD "Computer Science") + [PhD "Computer Science", Degree "Engineering"] -- laura3 has a cycle with pepe3 laura3 = pepe3 { name = "Laura" , spouse = Just pepe3 - , education = Degree "English" + , education = [Degree "English"] , addresses = ["2 Edward Square"] , religion = Just Catholic } diff --git a/example/Person4.hs b/example/Person4.hs new file mode 100644 --- /dev/null +++ b/example/Person4.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +module Person4 where + +import Control.Applicative +import Data.Generics.Labels () +import Person +import Person2 +import Schemas + +-- | v3 adds recursive field 'spouse', which leads to cycles +data Person4 = Person4 + { name :: String + , age :: Int + , addresses :: [String] + , religion :: Maybe Religion + , education :: [Education] + , a1,a2,a3,a4,a5 ,a6,a7,a8,a9,a10 + , b1,b2,b3,b4,b5,b6,b7,b8,b9,b10 + , c1,c2,c3,c4,c5,c6,c7,c8,c9,c10 + , d1,d2,d3,d4,d5,d6,d7,d8,d9,d10 + :: Bool + } + deriving (Eq, Show) + +instance HasSchema Person4 where + schema = + record + $ Person4 + <$> field "name" Person4.name + <*> field "age" Person4.age + <*> field "addresses" Person4.addresses + <*> optField "religion" Person4.religion + <*> ( field "studies" Person4.education + <|> field "education" Person4.education + ) + <*> grab "a1" a1 + <*> grab "a2" a2 + <*> grab "a3" a3 + <*> grab "a4" a4 + <*> grab "a5" a5 + <*> grab "a6" a6 + <*> grab "a7" a7 + <*> grab "a8" a8 + <*> grab "a9" a9 + <*> grab "a10" a10 + <*> grab "b1" b1 + <*> grab "b2" b2 + <*> grab "b3" b3 + <*> grab "b4" b4 + <*> grab "b5" b5 + <*> grab "b6" b6 + <*> grab "b7" b7 + <*> grab "b8" b8 + <*> grab "b9" b9 + <*> grab "b10" b10 + <*> grab "c1" c1 + <*> grab "c2" c2 + <*> grab "c3" c3 + <*> grab "c4" c4 + <*> grab "c5" c5 + <*> grab "c6" c6 + <*> grab "c7" c7 + <*> grab "c8" c8 + <*> grab "c9" c9 + <*> grab "c10" c10 + <*> grab "d1" d1 + <*> grab "d2" d2 + <*> grab "d3" d3 + <*> grab "d4" d4 + <*> grab "d5" d5 + <*> grab "d6" d6 + <*> grab "d7" d7 + <*> grab "d8" d8 + <*> grab "d9" d9 + <*> grab "d10" d10 + where grab n get = field n get <|> pure False + +pepe4 :: Person4 +pepe4 = Person4 + "Pepe" + 38 + ["2 Edward Square", "La Mar 10"] + Nothing + [PhD "Computer Science", Degree "Engineering"] + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False + False diff --git a/schemas.cabal b/schemas.cabal --- a/schemas.cabal +++ b/schemas.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: schemas -version: 0.2.0.3 +version: 0.3.0 synopsis: schema guided serialization description: Schemas is a Haskell library for serializing and deserializing data in JSON. @@ -75,9 +75,11 @@ type: exitcode-stdio-1.0 hs-source-dirs: example, test main-is: Main.hs + ghc-options: -threaded -with-rtsopts=-M1G other-modules: Person , Person2 , Person3 + , Person4 , SchemasSpec , Schemas.OpenApi2Spec , Generators @@ -93,4 +95,5 @@ , QuickCheck , schemas , text + , transformers , unordered-containers diff --git a/src/Schemas.hs b/src/Schemas.hs --- a/src/Schemas.hs +++ b/src/Schemas.hs @@ -87,14 +87,14 @@ , decodeWith , encodeToWith , decodeFromWith - , DecodeError(..) + , DecodeError + -- * working with recursive schemas - , finiteValue - , finiteEncode + , named -- * Untyped schemas , Schema(.., Empty, Union) - , Field(..) + , Field(..) , _Empty , _Union -- ** Extraction @@ -104,9 +104,7 @@ , Mismatch(..) , Trace , isSubtypeOf - , versions , coerce - , finite , validate , validatorsFor -- * Reexports diff --git a/src/Schemas/Class.hs b/src/Schemas/Class.hs --- a/src/Schemas/Class.hs +++ b/src/Schemas/Class.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -60,38 +62,42 @@ instance {-# OVERLAPPABLE #-} HasSchema a => HasSchema [a] where schema = list schema -instance HasSchema a => HasSchema (Vector a) where - schema = TArray schema id id +instance (HasSchema a) => HasSchema (Vector a) where + schema = vector schema instance (Eq a, Hashable a, HasSchema a) => HasSchema (HashSet a) where schema = list schema -instance HasSchema a => HasSchema (NonEmpty a) where +instance (HasSchema a) => HasSchema (NonEmpty a) where schema = list schema -instance HasSchema Field where - schema = record $ Field <$> field "schema" fieldSchema <*> fmap - (fromMaybe True) - (optField "isRequired" (\x -> if isRequired x then Nothing else Just False)) - instance HasSchema a => HasSchema (Identity a) where schema = dimap runIdentity Identity schema +deriving instance HasSchema SchemaName + instance HasSchema Schema where - schema = union' + schema = named "Schema" $ union' [ alt "StringMap" $ prism' StringMap (\case StringMap x -> Just x ; _ -> Nothing) , alt "Array" $ prism' Array (\case Array x -> Just x ; _ -> Nothing) , alt "Enum" $ prism' Enum (\case Enum x -> Just x ; _ -> Nothing) , alt "Record" $ prism' Record (\case Record x -> Just x ; _ -> Nothing) , alt "Empty" _Empty - , alt "AllOf" $ prism' AllOf (\case AllOf x -> Just x ; _ -> Nothing) , alt "Prim" $ prism' Prim (\case Prim x -> Just x ; _ -> Nothing) , altWith unionSchema "Union" _Union , alt "OneOf" $ prism' OneOf (\case OneOf x -> Just x ; _ -> Nothing) + , altWith namedSchema "Named" $ prism' (uncurry Named) (\case Named s sc -> Just (s,sc) ; _ -> Nothing) ] where + namedSchema = record $ (,) <$> field "name" fst <*> field "schema" snd unionSchema = list (record $ (,) <$> field "constructor" fst <*> field "schema" snd) +instance HasSchema Field where + schema = record $ + Field <$> field "schema" fieldSchema + <*> fmap (fromMaybe True) (optField "isRequired" (\x -> if isRequired x then Nothing else Just False)) + + instance HasSchema Value where schema = viaJSON "JSON" @@ -148,7 +154,7 @@ -- ----------------------------------------------------------------------------------- -- | Extract the default 'Schema' for a type theSchema :: forall a . HasSchema a => Schema -theSchema = extractSchema (schema @a) +theSchema = case extractSchema (schema @a) of x :| _ -> x validatorsFor :: forall a . HasSchema a => Validators validatorsFor = extractValidators (schema @a) @@ -163,17 +169,13 @@ encodeTo :: HasSchema a => Schema -> Either [(Trace, Mismatch)] (a -> Value) encodeTo = encodeToWith schema --- | Encode a value into a finite representation by enforcing a max depth -finiteEncode :: forall a. HasSchema a => Natural -> a -> Value -finiteEncode d = finiteValue (validatorsFor @a) d (theSchema @a) . encode - -- | Decode using the default schema. decode :: HasSchema a => Value -> Either [(Trace, DecodeError)] a decode = decodeWith schema -- | Apply `isSubtypeOf` to construct a coercion from the source schema to the default schema, -- apply the coercion to the data, and attempt to decode using the default schema. -decodeFrom :: HasSchema a => Schema -> Maybe (Value -> Either [(Trace, DecodeError)] a) +decodeFrom :: HasSchema a => Schema -> Either [(Trace, DecodeError)] (Value -> Either [(Trace, DecodeError)] a) decodeFrom = decodeFromWith schema -- | Coerce from 'sub' to 'sup'Returns 'Nothing' if 'sub' is not a subtype of 'sup' diff --git a/src/Schemas/Internal.hs b/src/Schemas/Internal.hs --- a/src/Schemas/Internal.hs +++ b/src/Schemas/Internal.hs @@ -1,26 +1,31 @@ -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS -Wno-name-shadowing #-} module Schemas.Internal where import Control.Alternative.Free import Control.Applicative (Alternative (..)) import Control.Exception -import Control.Lens hiding (Empty, enum, (<.>), allOf) +import Control.Lens hiding (Empty, allOf, enum, (<.>)) import Control.Monad import Control.Monad.Trans.Except import Data.Aeson (Value) import qualified Data.Aeson as A import Data.Biapplicative +import Data.Coerce import Data.Either import Data.Foldable (asum) import Data.Functor.Compose @@ -31,18 +36,21 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Semigroup -import Data.Text (Text, pack, unpack) +import Data.Text (Text, pack) import Data.Tuple import Data.Vector (Vector) import qualified Data.Vector as V +import Data.Void import GHC.Exts (IsList (..)) import Prelude hiding (lookup) import Schemas.Untyped +import Unsafe.Coerce + -- Typed schemas -- -------------------------------------------------------------------------------- --- | @TypedSchemaFlex enc dec@ is a schema for encoding to @enc@ and decoding to @dec@. +-- | @TypedSchemaFlex enc dec@ is a schema for encoding from @enc@ and decoding to @dec@. -- Usually we want @enc@ and @dec@ to be the same type but this flexibility comes in handy -- for composition. -- @@ -51,27 +59,37 @@ -- * composition: 'dimap', 'union', 'stringMap', 'liftPrism' -- data TypedSchemaFlex from a where - TEnum :: (NonEmpty (Text, a)) -> (from -> Text) -> TypedSchemaFlex from a - TArray :: TypedSchema b -> (Vector b -> a) -> (from -> Vector b) -> TypedSchemaFlex from a - TMap :: TypedSchema b -> (HashMap Text b -> a) -> (from -> HashMap Text b) -> TypedSchemaFlex from a + TNamed ::SchemaName -> TypedSchemaFlex from' a' -> (a' -> a) -> (from -> from') -> TypedSchemaFlex from a + TEnum ::(NonEmpty (Text, a)) -> (from -> Text) -> TypedSchemaFlex from a + TArray ::TypedSchemaFlex b b -> (Vector b -> a) -> (from -> Vector b) -> TypedSchemaFlex from a + TMap ::TypedSchemaFlex b b -> (HashMap Text b -> a) -> (from -> HashMap Text b) -> TypedSchemaFlex from a -- | Encoding and decoding support all alternatives - TAllOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a + TAllOf ::NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a -- | Decoding from all alternatives, but encoding only to one - TOneOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a - TEmpty :: a -> TypedSchemaFlex from a - TPrim :: Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a + TOneOf ::NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a + TEmpty ::a -> TypedSchemaFlex from a + TPrim ::Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a -- TTry _ is used to implement 'optField' on top of 'optFieldWith' + -- It's also crucial for implementing unions on top of TOneOf -- it could be exposed to provide some form of error handling, but currently is not - TTry :: Text -> TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b - RecordSchema :: RecordFields from a -> TypedSchemaFlex from a + TTry ::Text -> TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b + RecordSchema ::RecordFields from a -> TypedSchemaFlex from a instance Show (TypedSchemaFlex from a) where - show (TTry n sc _) = unwords ["TTry", unpack n, show sc] - show x = show $ extractSchema x + show = show . NE.head . extractSchema +type TypedSchema a = TypedSchemaFlex a a + + +-- | @named n sc@ annotates a schema with a name, allowing for circular schemas. +named :: SchemaName -> TypedSchemaFlex from' a -> TypedSchemaFlex from' a +named n sc = TNamed n sc id id + -- | @enum values mapping@ construct a schema for a non empty set of values with a 'Text' mapping enum :: Eq a => (a -> Text) -> (NonEmpty a) -> TypedSchema a -enum showF opts = TEnum alts (fromMaybe (error "invalid alt") . flip lookup altMap) +enum showF opts = TEnum + alts + (fromMaybe (error "invalid alt") . flip lookup altMap) where altMap = fmap swap $ alts --TODO fast lookup alts = opts <&> \x -> (showF x, x) @@ -107,55 +125,56 @@ readShow :: (Read a, Show a) => TypedSchema a readShow = dimap show read string -allOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a -allOf [x] = x -allOf x = TAllOf $ sconcat $ fmap f x where - f (TAllOf xx) = xx - f x = [x] - -- | The schema of undiscriminated unions. Prefer using 'union' where possible oneOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a oneOf [x] = x -oneOf x = TOneOf $ sconcat $ fmap f x where +oneOf x = TOneOf $ sconcat $ fmap f x where f (TOneOf xx) = xx - f x = [x] + f (x ) = [x] instance Functor (TypedSchemaFlex from) where fmap = rmap -instance Profunctor TypedSchemaFlex where - dimap _ f (TEmpty a ) = TEmpty (f a) - dimap g f (TTry n sc try) = TTry n (rmap f sc) (try . g) - dimap g f (TAllOf scc ) = TAllOf (dimap g f <$> scc) - dimap g f (TOneOf scc ) = TOneOf (dimap g f <$> scc) - dimap g f (TEnum opts fromf) = TEnum (second f <$> opts) (fromf . g) - dimap g f (TArray sc tof fromf) = TArray sc (f . tof) (fromf . g) - dimap g f (TMap sc tof fromf) = TMap sc (f . tof) (fromf . g) - dimap g f (TPrim n tof fromf) = TPrim n (fmap f . tof) (fromf . g) - dimap g f (RecordSchema sc) = RecordSchema (dimap g f sc) +instance Profunctor (TypedSchemaFlex) where + dimap g f (TNamed n sc tof fromf) = TNamed n sc (f . tof) (fromf . g) + dimap _ f (TEmpty a ) = TEmpty (f a) + dimap g f (TTry n sc try ) = TTry n (rmap f sc) (try . g) + dimap g f (TAllOf scc ) = TAllOf (dimap g f <$> scc) + dimap g f (TOneOf scc ) = TOneOf (dimap g f <$> scc) + dimap g f (TEnum opts fromf ) = TEnum (second f <$> opts) (fromf . g) + dimap g f (TArray sc tof fromf ) = TArray sc (f . tof) (fromf . g) + dimap g f (TMap sc tof fromf ) = TMap sc (f . tof) (fromf . g) + dimap g f (TPrim n tof fromf ) = TPrim n (fmap f . tof) (fromf . g) + dimap g f (RecordSchema sc ) = RecordSchema (dimap g f sc) instance Monoid a => Monoid (TypedSchemaFlex f a) where mempty = TEmpty mempty instance Semigroup (TypedSchemaFlex f a) where -- | Allows defining multiple schemas for the same thing, effectively implementing versioning. - TEmpty a <> TEmpty _ = TEmpty a - TEmpty{} <> x = x - x <> TEmpty{} = x - TAllOf aa <> b = allOf (aa <> [b]) - a <> TAllOf bb = allOf ([a] <> bb) - a <> b = allOf [a,b] + TEmpty a <> TEmpty _ = TEmpty a + TEmpty{} <> x = x + x <> TEmpty{} = x + TAllOf aa <> b = allOf (aa <> [b]) + a <> TAllOf bb = allOf ([a] <> bb) + a <> b = allOf [a, b] -type TypedSchema a = TypedSchemaFlex a a + sconcat = allOf +allOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a +allOf [x] = x +allOf x = TAllOf $ sconcat $ fmap f x where + f (TAllOf xx) = xx + f x = [x] + -- -------------------------------------------------------------------------------- -- Applicative records data RecordField from a where - RequiredAp :: { fieldName :: Text -- ^ Name of the field + RequiredAp ::{ fieldName :: Text -- ^ Name of the field , fieldTypedSchema :: TypedSchemaFlex from a } -> RecordField from a - OptionalAp :: { fieldName :: Text + OptionalAp ::{ fieldName :: Text , fieldTypedSchema :: TypedSchemaFlex from a , fieldDefValue :: a } -> RecordField from a @@ -163,10 +182,11 @@ -- | Lens for the 'fieldName' attribute fieldNameL :: Lens' (RecordField from a) Text fieldNameL f (RequiredAp n sc) = (`RequiredAp` sc) <$> f n -fieldNameL f OptionalAp{..} = (\fieldName -> OptionalAp{..}) <$> f fieldName +fieldNameL f OptionalAp {..} = + (\fieldName -> OptionalAp { .. }) <$> f fieldName instance Profunctor RecordField where - dimap f g (RequiredAp name sc) = RequiredAp name (dimap f g sc) + dimap f g (RequiredAp name sc ) = RequiredAp name (dimap f g sc) dimap f g (OptionalAp name sc def) = OptionalAp name (dimap f g sc) (g def) -- | An 'Alternative' profunctor for defining record schemas with versioning @@ -184,7 +204,8 @@ -- | Map a function over all the field names overFieldNames :: (Text -> Text) -> RecordFields from a -> RecordFields from a -overFieldNames f = RecordFields . hoistAlt ((over fieldNameL f)) . getRecordFields +overFieldNames f = + RecordFields . hoistAlt ((over fieldNameL f)) . getRecordFields -- | Wrap an applicative record schema record :: RecordFields from a -> TypedSchemaFlex from a @@ -196,14 +217,15 @@ -- | Generalised version of 'fieldWith' fieldWith' :: TypedSchemaFlex from a -> Text -> RecordFields from a -fieldWith' schema n = RecordFields $ liftAlt (RequiredAp n schema) +fieldWith' (schema) n = RecordFields $ liftAlt (RequiredAp n schema) -- | Project a schema through a Prism. Returns a partial schema. -- When encoding/decoding a value that doesn't fit the prism, -- an optional field will be omitted, and a required field will cause -- this alternative to be aborted. liftPrism :: Text -> Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex s t -liftPrism n p sc = withPrism p $ \t f -> rmap t (TTry n sc (either (const Nothing) Just . f)) +liftPrism n p sc = + withPrism p $ \t f -> rmap t (TTry n sc (either (const Nothing) Just . f)) -- | @liftJust = liftPrism _Just@ liftJust :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b) @@ -215,41 +237,31 @@ -- | A generalized version of 'optField'. Does not handle infinite/circular data. optFieldWith - :: forall a from - . TypedSchemaFlex from (Maybe a) - -> Text - -> RecordFields from (Maybe a) + :: forall a from + . TypedSchemaFlex from (Maybe a) + -> Text + -> RecordFields from (Maybe a) optFieldWith schema n = RecordFields $ liftAlt (OptionalAp n schema Nothing) -- | The most general introduction form for optional alts optFieldGeneral - :: forall a from - . TypedSchemaFlex from a - -> Text - -> a - -> RecordFields from a + :: forall a from . TypedSchemaFlex from a -> Text -> a -> RecordFields from a optFieldGeneral schema n def = RecordFields $ liftAlt (OptionalAp n schema def) -- | A generalized version of 'optFieldEither'. Does not handle infinite/circular data optFieldEitherWith - :: TypedSchemaFlex from (Either e a) -> Text -> e -> RecordFields from (Either e a) + :: TypedSchemaFlex from (Either e a) + -> Text + -> e + -> RecordFields from (Either e a) optFieldEitherWith schema n e = optFieldGeneral schema n (Left e) --- | Extract all the field groups (from alternatives) in the record -extractFields :: RecordFields from a -> NonDet [(Text, Field)] -extractFields = extractFieldsHelper extractField - where - extractField :: RecordField from a -> (Text, Field) - extractField (RequiredAp n sc) = (n,) . (`Field` True) $ extractSchema sc - extractField (OptionalAp n sc _) = (n,) . (`Field` False) $ extractSchema sc - -newtype NonDet a = NonDet { nonDet :: [a] } - deriving newtype (Applicative, Alternative, Foldable, Functor, Monad) - -instance Traversable NonDet where traverse f (NonDet a) = NonDet <$> traverse f a - -extractFieldsHelper :: (forall a . RecordField from a -> b) -> RecordFields from a -> NonDet [b] -extractFieldsHelper f = runAlt_ (\x -> pure [f x]) . getRecordFields +extractFieldsHelper + :: Alternative f + => (forall a . RecordField from a -> f b) + -> RecordFields from a + -> f [b] +extractFieldsHelper f = runAlt_ (\x -> (: []) <$> f x) . getRecordFields -- -------------------------------------------------------------------------------- -- Typed Unions @@ -273,13 +285,12 @@ -- | Given a non empty set of tagged partial schemas, constructs the schema that applies -- them in order and selects the first successful match. union :: (NonEmpty (Text, TypedSchema a)) -> TypedSchema a -union args = TOneOf (mk <$> args) - where - mk (name, sc) = RecordSchema $ fieldWith' sc name +union args = oneOf (mk <$> args) + where mk (name, sc) = RecordSchema $ fieldWith' sc name -- | Existential wrapper for convenient definition of discriminated unions data UnionTag from where - UnionTag :: Text -> Prism' from b -> TypedSchema b -> UnionTag from + UnionTag ::Text -> Prism' from b -> TypedSchema b -> UnionTag from -- | @altWith name prism schema@ introduces a discriminated union alternative altWith :: TypedSchema a -> Text -> Prism' from a -> UnionTag from @@ -293,125 +304,125 @@ -- -------------------------------------------------------------------------------- -- Schema extraction from a TypedSchema --- | Extract an untyped schema that can be serialized -extractSchema :: TypedSchemaFlex from a -> Schema -extractSchema (TPrim n _ _) = Prim n -extractSchema (TTry _ sc _) = extractSchema sc -extractSchema (TOneOf scc) = OneOf $ extractSchema <$> scc -extractSchema (TAllOf scc) = AllOf $ extractSchema <$> scc -extractSchema TEmpty{} = Empty -extractSchema (TEnum opts _) = Enum (fst <$> opts) -extractSchema (TArray sc _ _) = Array $ extractSchema sc -extractSchema (TMap sc _ _) = StringMap $ extractSchema sc -extractSchema (RecordSchema rs) = foldMap (Record . fromList) $ extractFields rs +-- | Extract an untyped schema that can be serialized. +-- +-- For schemas with alternatives, this enumerates all the possible +-- versions lazily. +-- Beware when using on schemas with multiple alternatives, +-- as the number of versions is exponential. +extractSchema :: TypedSchemaFlex from a -> NonEmpty Schema +extractSchema (TNamed n sc _ _) = Named n <$> extractSchema sc +extractSchema (TPrim n _ _ ) = pure $ Prim n +extractSchema (TTry _ sc _ ) = extractSchema sc +extractSchema (TOneOf scc ) = pure $ OneOf $ extractSchema =<< scc +extractSchema (TAllOf scc ) = extractSchema =<< scc +extractSchema (TEmpty{} ) = pure $ Empty +extractSchema (TEnum opts _ ) = pure $ Enum (fst <$> opts) +extractSchema (TArray sc _ _ ) = Array <$> extractSchema sc +extractSchema (TMap sc _ _ ) = StringMap <$> extractSchema sc +extractSchema (RecordSchema rs) = + fromList $ foldMap (\x -> pure (Record (fromList x))) (extractFields rs) +-- | Extract all the field groups (from alternatives) in the record +extractFields :: RecordFields from to -> [[(Text, Field)]] +extractFields = + runAlt_ (\x -> (: []) <$> NE.toList (extractField x)) . getRecordFields where + + extractField :: RecordField from to -> NonEmpty (Text, Field) + extractField (RequiredAp n sc) = + (\s -> (n, (`Field` True) s)) <$> extractSchema sc + extractField (OptionalAp n sc _) = + (\s -> (n, (`Field` False) s)) <$> extractSchema sc + + -- | Returns all the primitive validators embedded in this typed schema extractValidators :: TypedSchemaFlex from a -> Validators -extractValidators (TPrim n parse _) = - [ ( n - , (\x -> case parse x of - A.Success _ -> Nothing - A.Error e -> Just (pack e) +extractValidators = go where + go :: TypedSchemaFlex from a -> Validators + go (TPrim n parse _) = + [ ( n + , (\x -> case parse x of + A.Success _ -> Nothing + A.Error e -> Just (pack e) + ) ) - ) - ] -extractValidators (TOneOf scc) = foldMap extractValidators scc -extractValidators (TAllOf scc) = foldMap extractValidators scc -extractValidators (TArray sc _ _) = extractValidators sc -extractValidators (TMap sc _ _) = extractValidators sc -extractValidators (TTry _ sc _) = extractValidators sc -extractValidators (RecordSchema rs) = mconcat - $ mconcat $ nonDet (extractFieldsHelper (extractValidators . fieldTypedSchema) rs) -extractValidators _ = [] + ] + go (TOneOf scc ) = foldMap go scc + go (TAllOf scc ) = foldMap go scc + go (TArray sc _ _) = go sc + go (TMap sc _ _) = go sc + go (TTry _ sc _) = go sc + go (RecordSchema rs) = + mconcat $ mconcat (extractFieldsHelper (pure . go . fieldTypedSchema) rs) + go _ = [] -- --------------------------------------------------------------------------------------- -- Encoding to JSON type E = [(Trace, Mismatch)] --- | Given a value and its typed schema, produce a JSON record using the 'RecordField's +-- | Given a typed schema, produce a JSON encoder to the firt version returned by 'extractSchema' encodeWith :: TypedSchemaFlex from a -> from -> Value - -- TODO Better error messages to help debug partial schemas ? -encodeWith sc = either (throw . AllAlternativesFailed . map ([],)) id . runExcept . go sc where - go :: TypedSchemaFlex from a -> from -> Except [Mismatch] Value - go (TAllOf scc ) x = encodeAlternatives <$> traverse (`go` x) scc - go (TOneOf scc ) x = asum (fmap (`go` x) scc) - go (TTry n sc try ) x = go sc =<< maybe (throwE [TryFailed n]) pure (try x) - go (TEnum _ fromf ) b = pure $ A.String (fromf b) - go (TPrim _ _ fromf ) b = pure $ fromf b - go (TEmpty _ ) _ = pure emptyValue - go (TArray sc _ fromf) b = A.Array <$> go sc `traverse` fromf b - go (TMap sc _ fromf) b = A.Object <$> go sc `traverse` fromf b - go (RecordSchema rec ) x = do - let alternatives = extractFieldsHelper (extractField x) rec - let results = - partitionEithers $ nonDet $ fmap (runExcept . sequenceA) alternatives - case results of - (_, NE.nonEmpty -> Just alts') -> pure $ encodeAlternatives $ fmap - (A.Object . fromList . catMaybes) - alts' - (ee, _) -> throwE (concat ee) - where - - extractField b RequiredAp {..} = - Just . (fieldName, ) <$> go fieldTypedSchema b `catchE` \mm -> - throwE [InvalidRecordField fieldName (map ([],) mm)] - extractField b OptionalAp {..} = - (Just . (fieldName, ) <$> go fieldTypedSchema b) - `catchE` \_ -> pure Nothing +encodeWith sc = fromRight (error "Internal error") + $ encodeToWith sc (NE.head $ extractSchema sc) +-- | Given source and target schemas, produce a JSON encoder encodeToWith :: TypedSchemaFlex from a -> Schema -> Either E (from -> Value) encodeToWith sc target = (\m -> either (throw . AllAlternativesFailed) id . runExcept . m) - <$> runExcept (go [] sc target) + <$> runExcept (go [] [] sc (target)) where failWith ctx m = throwE [(reverse ctx, m)] go - :: Trace + :: forall from a + . [(SchemaName, Except E (Void -> Except E Value))] + -> Trace -> TypedSchemaFlex from a -> Schema - -- Returns a set of mismatches or an encoding function that can fail (TTry) -> Except E (from -> Except E Value) - go _tx TEmpty{} Array{} = pure $ pure . const (A.Array []) - go _tx TEmpty{} Record{} = pure $ pure . const (A.Object []) - go _tx TEmpty{} StringMap{} = pure $ pure . const (A.Object []) - go _tx TEmpty{} OneOf{} = pure $ pure . const emptyValue - go ctx (TPrim n _ fromf) (Prim n') + go env ctx (TNamed n sct _ fromf) (Named n' sc) | n == n' = + case lookup n env of + Just res -> do + -- TODO understand why this delay is necessary + return $ unsafeDelay $ lmap (unsafeCoerce . fromf) <$> res + Nothing -> + let res = go ((n, resDyn) : env) ctx sct sc + resDyn = lmap unsafeCoerce <$> res + in lmap fromf <$> res + go _ _tx TEmpty{} Array{} = pure $ pure . const (A.Array []) + go _ _tx TEmpty{} Record{} = pure $ pure . const (A.Object []) + go _ _tx TEmpty{} StringMap{} = pure $ pure . const (A.Object []) + go _ _tx TEmpty{} OneOf{} = pure $ pure . const emptyValue + go _ ctx (TPrim n _ fromf) (Prim n') | n == n' = pure $ pure . fromf | otherwise = failWith ctx (PrimMismatch n n') - go ctx (TArray sc _ fromf) (Array t) = do - f <- go ("[]" : ctx) sc t + go i ctx (TArray sc _ fromf) (Array t) = do + f <- go i ("[]" : ctx) sc t return $ A.Array <.> traverse f . fromf - go ctx (TMap sc _ fromf) (StringMap t) = do - f <- go ("Map" : ctx) sc t + go i ctx (TMap sc _ fromf) (StringMap t) = do + f <- go i ("Map" : ctx) sc t return $ A.Object <.> traverse f . fromf - go ctx (TEnum opts fromf) (Enum optsTarget) = do + go _ ctx (TEnum opts fromf) (Enum optsTarget) = do case NE.nonEmpty $ NE.filter (`notElem` optsTarget) (fst <$> opts) of Nothing -> pure $ pure . A.String . fromf Just xx -> failWith ctx $ MissingEnumChoices xx - go ctx sc (AllOf tt) = do - alts <- itraverse (\i -> go (tag i : ctx) sc) tt - return $ \x -> encodeAlternatives <$> traverse ($x) alts - go ctx (TAllOf scc) t = asum $ imap (\i sc -> go (tag i : ctx) sc t) scc - go ctx (TOneOf scc) t = do - alts <- itraverse (\i sc -> go (tag i : ctx) sc t) scc + go n ctx (TAllOf scc) t = asum $ imap (\i sc -> go n (tag i : ctx) sc t) scc + go n ctx (TOneOf scc) t = do + alts <- itraverse (\i sc -> go n (tag i : ctx) sc t) scc return $ \x -> asum $ fmap ($ x) alts - go ctx sc (OneOf tt) = asum $ fmap (go ctx sc) tt - go ctx (TTry n sc try) t = do - f <- go (n : ctx) sc t + go i ctx sc (OneOf tt) = asum $ fmap (go i ctx sc) tt + go i ctx (TTry n sc try) t = do + f <- go i (n : ctx) sc t return $ \x -> f =<< maybe (failWith ctx (TryFailed n)) pure (try x) - go ctx (RecordSchema rec) (Record ff) = do - let alternatives = - [ runExcept $ sequenceOf (traverse . _2) alt - | altMb <- nonDet $ extractFieldsHelper - (\f -> (fieldName f, ) <$> extractField f) - rec - , let alt = catMaybes altMb - , Set.fromList (Map.keys ff) == Set.fromList (fmap fst alt) - ] - case partitionEithers alternatives of - (_, NE.nonEmpty -> Just alts) -> pure $ \x -> asum $ fmap + go i ctx (RecordSchema rec) (Record target) = do + let alternatives = runAlt_ extractField (getRecordFields rec) + let targetFields = Set.fromList (Map.keys target) + let complete = + filter ((targetFields ==) . Set.fromList . fmap fst) alternatives + case complete of + [] -> failWith ctx NoMatches + alts -> pure $ \x -> asum $ fmap (\alt -> A.Object . fromList @@ -419,123 +430,211 @@ <$> traverse (\(fn, f) -> (fn, ) <$> f x) alt ) alts - ([], _) -> failWith ctx NoMatches - (ee, _) -> failWith ctx $ AllAlternativesFailed (concat ee) where extractField - :: RecordField from a -> Maybe (Except E (from -> Except E (Maybe Value))) - extractField RequiredAp {..} | Just f <- Map.lookup fieldName ff = Just $ do - f <- go (fieldName : ctx) fieldTypedSchema (fieldSchema f) - return $ \x -> Just <$> f x `catchE` \mm -> - failWith ctx (InvalidRecordField fieldName mm) - extractField OptionalAp {..} | Just f <- Map.lookup fieldName ff = Just $ do - f <- go (fieldName : ctx) fieldTypedSchema (fieldSchema f) - return $ \x -> (Just <$> f x) `catchE` \_ -> pure Nothing - extractField _ = Nothing - go ctx sc (Array t) = do - f <- go ctx sc t - return $ A.Array . fromList . (: []) <.> f - go _tx _ Empty = pure $ pure . const emptyValue - go ctx other tgt = failWith ctx (SchemaMismatch (extractSchema other) tgt) + :: forall from a + . RecordField from a + -> [[(Text, from -> Except E (Maybe Value))]] + extractField RequiredAp {..} = case Map.lookup fieldName target of + Nothing -> return [] + Just targetField -> do + case + runExcept $ go i + (fieldName : ctx) + fieldTypedSchema + (fieldSchema targetField) + of + Left _ -> empty + Right f -> do + let decoder x = Just <$> f x `catchE` \mm -> + failWith ctx (InvalidRecordField fieldName mm) + return [(fieldName, decoder)] + extractField OptionalAp {..} = case Map.lookup fieldName target of + Nothing -> return [] + Just targetField -> do + guard $ not (isRequired targetField) + case + runExcept $ go i + (fieldName : ctx) + fieldTypedSchema + (fieldSchema targetField) + of + Left _ -> empty + Right f -> do + let decoder x = (Just <$> f x) `catchE` \_ -> pure Nothing + return [(fieldName, decoder)] + go i ctx sc (Array t) = do + f <- go i ctx sc t + return $ A.Array . fromList . (: []) <.> f + go _ _tx _ Empty = pure $ pure . const emptyValue + go _ ctx other src = + failWith ctx (SchemaMismatch (NE.head $ extractSchema other) src) -- -------------------------------------------------------------------------- -- Decoding -data DecodeError - = VE Mismatch - | TriedAndFailed - deriving (Eq, Show) +type D = [(Trace, DecodeError)] +type DecodeError = Mismatch + -- | Runs a schema as a function @enc -> dec@. Loops for infinite/circular data runSchema :: TypedSchemaFlex enc dec -> enc -> Either [DecodeError] dec runSchema sc = runExcept . go sc - where - go :: forall from a. TypedSchemaFlex from a -> from -> Except [DecodeError] a - go (TEmpty a ) _ = pure a - go (TTry _ sc try) from = maybe (throwE [TriedAndFailed]) (go sc) (try from) - go (TPrim n toF fromF) from = case toF (fromF from) of - A.Success a -> pure a - A.Error e -> failWith (PrimError n (pack e)) - go (TEnum opts fromF) from = case lookup enumValue opts of - Just x -> pure x - Nothing -> failWith $ InvalidEnumValue enumValue (fst <$> opts) - where enumValue = fromF from - go (TMap _sc toF fromF) from = pure $ toF (fromF from) - go (TArray _sc toF fromF) from = pure $ toF (fromF from) - go (TAllOf scc ) from = msum $ (`go` from) <$> scc - go (TOneOf scc ) from = msum $ (`go` from) <$> scc - go (RecordSchema alts ) from = runAlt f (getRecordFields alts) - where - f :: RecordField from b -> Except [DecodeError] b - f RequiredAp{..} = go fieldTypedSchema from - f OptionalAp{..} = go fieldTypedSchema from + where + go :: forall from a . TypedSchemaFlex from a -> from -> Except [DecodeError] a + go (TEmpty a ) _ = pure a + go (TNamed _ sc tof fromF) a = tof <$> go sc (fromF a) + go (TTry n sc try) from = maybe (throwE [TryFailed n]) (go sc) (try from) + go (TPrim n toF fromF ) from = case toF (fromF from) of + A.Success a -> pure a + A.Error e -> failWith (PrimError n (pack e)) + go (TEnum opts fromF) from = case lookup enumValue opts of + Just x -> pure x + Nothing -> failWith $ InvalidEnumValue enumValue (fst <$> opts) + where enumValue = fromF from + go (TMap _sc toF fromF) from = pure $ toF (fromF from) + go (TArray _sc toF fromF) from = pure $ toF (fromF from) + go (TAllOf scc ) from = msum $ (`go` from) <$> scc + go (TOneOf scc ) from = msum $ (`go` from) <$> scc + go (RecordSchema alts ) from = runAlt f (getRecordFields alts) + where + f :: RecordField from b -> Except [DecodeError] b + f RequiredAp {..} = go fieldTypedSchema from + f OptionalAp {..} = go fieldTypedSchema from - failWith e = throwE [VE e] + failWith e = throwE [e] -- | Given a JSON 'Value' and a typed schema, extract a Haskell value -decodeWith :: TypedSchemaFlex from a -> Value -> Either [(Trace, DecodeError)] a --- TODO merge runSchema and decodeWith ? --- TODO change decode type to reflect partiality due to TTry _? -decodeWith sc = runExcept . go [] sc +decodeWith :: TypedSchemaFlex from a -> Value -> Either D a +decodeWith sc v = decoder >>= ($ v) + where decoder = decodeFromWith sc (NE.head $ extractSchema sc) + +decodeFromWith + :: TypedSchemaFlex from a -> Schema -> Either D (Value -> Either D a) +-- TODO merge runSchema and decodeFromWith ? +decodeFromWith sc source = (runExcept .) <$> runExcept (go [] [] sc (source)) where - failWith ctx e = throwE [(reverse ctx, VE e)] + failWith ctx e = throwE [(reverse ctx, e)] go - :: [Text] + :: [(SchemaName, Except D (Value -> Except D Void))] + -> Trace -> TypedSchemaFlex from a - -> Value - -> Except [(Trace, DecodeError)] a - go ctx (TEnum opts _) (A.String x) = - maybe (failWith ctx (InvalidEnumValue x (fst <$> opts))) pure - $ lookup x opts - go ctx (TArray sc tof _) (A.Array x) = - tof <$> traverse (go ("[]" : ctx) sc) x - go ctx (TMap sc tof _) (A.Object x) = tof <$> traverse (go ("[]" : ctx) sc) x - go _tx (TEmpty a) _ = pure a - go ctx (RecordSchema rec) o@A.Object{} = do - let alts = decodeAlternatives o - asum $ concatMap - (\(A.Object alts, _encodedPath) -> - getCompose $ runAlt (Compose . (: []) . f alts) (getRecordFields rec) - ) - alts + -> Schema + -> Except D (Value -> Except D a) + go _nv _tx (TEmpty a) _ = pure $ const $ pure a + go env ctx (TNamed n sc tof _) (Named n' s) | n == n' = case lookup n env of + Just sol -> do + -- TODO understand why this delay is necessary + return $ unsafeDelay $ (fmap . fmap . fmap) (tof . unsafeCoerce) sol + Nothing -> + let sol = go ((n, solDyn) : env) ctx sc s + solDyn = (fmap . fmap . fmap) unsafeCoerce sol + in (fmap . fmap . fmap) tof sol + go env ctx (TNamed _ sc tof _) s = (fmap . fmap . fmap) tof $ go env ctx sc s + go _nv ctx (TEnum optsTarget _) s@(Enum optsSource) = + case + NE.nonEmpty + $ NE.filter (`notElem` map fst (NE.toList optsTarget)) (optsSource) + of + Just xx -> failWith ctx $ MissingEnumChoices xx + Nothing -> pure $ \case + A.String x -> + maybe (failWith ctx (InvalidEnumValue x (fst <$> optsTarget))) pure + $ lookup x optsTarget + other -> failWith ctx (ValueMismatch s other) + go env ctx (TArray sc tof _) s@(Array src) = do + f <- go env ("[]" : ctx) sc src + return $ \case + A.Array x -> tof <$> traverse f x + other -> failWith ctx (ValueMismatch s other) + go env ctx (TMap sc tof _) s@(StringMap src) = do + f <- go env ("Map" : ctx) sc src + return $ \case + A.Object x -> tof <$> traverse f x + other -> failWith ctx (ValueMismatch s other) + go _nv ctx (TPrim n tof _) (Prim src) + | n /= src = failWith ctx (PrimMismatch n src) + | otherwise = return $ \x -> case tof x of + A.Error e -> failWith ctx (PrimError n (pack e)) + A.Success a -> return a + go env ctx (TTry n sc _try) x = go env (n : ctx) sc x + go env ctx (TAllOf scc ) src = do + let parsers = map (\sc -> runExcept $ go env ctx sc src) (NE.toList scc) + case partitionEithers parsers of + (ee, []) -> failWith ctx (AllAlternativesFailed (concat ee)) + (_ , pp) -> return $ \x -> asum (map ($ x) pp) + go env ctx (TOneOf scc) src = do + let parsers = map (\sc -> runExcept $ go env ctx sc src) (NE.toList scc) + case partitionEithers parsers of + (ee, []) -> failWith ctx (AllAlternativesFailed (concat ee)) + (_ , pp) -> return $ \x -> asum (map ($ x) pp) + go env ctx (RecordSchema (RecordFields rec)) (Record src) = do + let solutions = coerce $ runAlt f' rec + -- make sure there are no unused fields + sourceFields = Map.keys src + valid = map + (\(tgtFields, f) -> + case Set.difference (fromList sourceFields) (fromList tgtFields) of + [] -> Right f + xx -> Left (Set.toList xx) + ) + solutions + case partitionEithers valid of + (ee, [] ) -> throwE [(reverse ctx, UnusedFields ee)] + (_ , alts) -> pure $ \x -> asum $ fmap ($ x) alts where - f :: A.Object -> RecordField from a -> Except [(Trace, DecodeError)] a - f alts (RequiredAp n sc) = case Map.lookup n alts of - Just v -> go (n : ctx) sc v - Nothing -> case sc of --- TArray _ tof' _ -> pure $ tof' [] - _ -> failWith ctx (MissingRecordField n) - f alts OptionalAp {..} = case Map.lookup fieldName alts of - Just v -> go (fieldName : ctx) fieldTypedSchema v - Nothing -> pure fieldDefValue + f' + :: RecordField from a + -> ([] `Compose` (,) [Text] `Compose` (->) Value `Compose` (Except D)) + a + f' x = coerce (f x) + f :: RecordField from a -> [([Text], Value -> Except D a)] + f RequiredAp {..} = case Map.lookup fieldName src of + Nothing -> empty + Just srcField -> do + guard $ isRequired srcField + case + runExcept + $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField) + of + Left _ -> empty + Right f -> return + ( [fieldName] + , \case + A.Object o -> case Map.lookup fieldName o of + Nothing -> + failWith (fieldName : ctx) (MissingRecordField fieldName) + Just v -> f v + ) + f OptionalAp {..} = case Map.lookup fieldName src of + Nothing -> return ([fieldName], const $ return fieldDefValue) + Just srcField -> do + case + runExcept + $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField) + of + Left _ -> empty + Right f -> return + ( [fieldName] + , \case + A.Object o -> case Map.lookup fieldName o of + Nothing -> return fieldDefValue + Just v -> f v + ) - -- The TAllOf case is probably wrong. I suspect TAllOf should decode very much like TOneOf - go ctx (TAllOf scc) v = asum $ map - (\(v', i) -> go - (pack (show i) : ctx) - (fromMaybe (error "TAllOf") $ selectPath i (NE.toList scc)) - v' - ) - (decodeAlternatives v) - go ctx (TOneOf scc ) x = asum [ go ctx sc x | sc <- NE.toList scc ] + go env ctx s (OneOf xx ) = asum $ fmap (go env ctx s) xx + go env ctx sc (Named _ s) = go env ctx sc s + go _nv ctx s src = + failWith ctx (SchemaMismatch (NE.head $ extractSchema s) src) - go ctx (TPrim n tof _) x = case tof x of - A.Error e -> failWith ctx (PrimError n (pack e)) - A.Success a -> pure a - go ctx (TTry _ sc _try) x = go ctx sc x - go ctx s x = failWith ctx (ValueMismatch (extractSchema s) x) -decodeFromWith :: TypedSchema a -> Schema -> Maybe (Value -> Either [(Trace, DecodeError)] a) -decodeFromWith sc source = case isSubtypeOf (extractValidators sc) source (extractSchema sc) of - Right cast -> Just $ decodeWith sc . cast - _ -> Nothing - -- ---------------------------------------------- -- Utils -runAlt_ :: (Alternative g, Monoid m) => (forall a. f a -> g m) -> Alt f b -> g m +runAlt_ + :: (Alternative g, Monoid m) => (forall a . f a -> g m) -> Alt f b -> g m runAlt_ f = fmap getConst . getCompose . runAlt (Compose . fmap Const . f) (<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c @@ -543,3 +642,6 @@ infixr 8 <.> + +unsafeDelay :: Except a c -> c +unsafeDelay = fromRight (error "internal error") . runExcept diff --git a/src/Schemas/OpenApi2.hs b/src/Schemas/OpenApi2.hs --- a/src/Schemas/OpenApi2.hs +++ b/src/Schemas/OpenApi2.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module defines a 'TypedSchema' for the 'Schema' datatype, -- inspired in the OpenApi 2.0 specification, which may be useful @@ -37,7 +38,7 @@ import Schemas import Schemas.SOP --- | Given a schema free of undiscriminated unions and alternatives, +-- | Given a schema free of undiscriminated unions -- @encodeAsOpenApi2Document name schema@ produces an encoding of an -- OpenApi2 document that models the given schema. -- Failures are omitted, use 'toOpenApi2Document' if you care. @@ -158,7 +159,6 @@ } toOpenApi2 prim (Prim p) | Just y <- prim p = pure y toOpenApi2 _rim (Prim p) = lift $ throwE $ Unsupported $ "Unknown prim: " <> p -toOpenApi2 _rim AllOf{} = lift $ throwE $ Unsupported "alternatives (AllOf)" toOpenApi2 _rim OneOf{} = lift $ throwE $ Unsupported "undiscriminated unions (OneOf)" diff --git a/src/Schemas/Untyped.hs b/src/Schemas/Untyped.hs --- a/src/Schemas/Untyped.hs +++ b/src/Schemas/Untyped.hs @@ -1,11 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS -Wno-name-shadowing #-} module Schemas.Untyped where @@ -28,18 +34,18 @@ import Data.Maybe import Data.Text (Text, pack, unpack) import Data.Typeable -import GHC.Exts (IsList (..)) +import GHC.Exts (IsList (..), IsString(..)) import GHC.Generics (Generic) -import Numeric.Natural import Prelude hiding (lookup) import Text.Read - --- import Debug.Pretty.Simple - +import Text.Show.Functions () -- Schemas -- -------------------------------------------------------------------------------- +newtype SchemaName = SchemaName String + deriving newtype (Eq, IsString, Show) + -- | A schema for untyped data, such as JSON or XML. -- -- * introduction forms: 'extractSchema', 'theSchema', 'mempty' @@ -50,18 +56,18 @@ | StringMap Schema | Enum (NonEmpty Text) | Record (HashMap Text Field) - | AllOf (NonEmpty Schema) -- ^ Encoding and decoding work for all alternatives | OneOf (NonEmpty Schema) -- ^ Decoding works for all alternatives, encoding only for one - | Prim Text -- ^ Carries the name of primitive type + | Prim Text -- ^ Carries the name of primitive type + | Named SchemaName Schema deriving (Eq, Generic, Show) instance Monoid Schema where mempty = Empty instance Semigroup Schema where Empty <> x = x x <> Empty = x - AllOf aa <> b = AllOf (aa <> [b]) - b <> AllOf aa = AllOf ([b] <> aa) - a <> b = AllOf [a,b] + OneOf aa <> b = OneOf (aa <> [b]) + b <> OneOf aa = OneOf ([b] <> aa) + a <> b = OneOf [a,b] data Field = Field { fieldSchema :: Schema @@ -70,7 +76,7 @@ deriving (Eq, Generic) instance Show Field where - showsPrec p (Field sc True) = showsPrec p sc + showsPrec p (Field sc True) = showsPrec p sc showsPrec p (Field sc False) = ("?" ++) . showsPrec p sc fieldSchemaL :: Applicative f => (Schema -> f Schema) -> Field -> f Field @@ -89,61 +95,21 @@ build () = Record [] match (Record []) = Just () - match _ = Nothing + match _ = Nothing _Union :: Prism' Schema (NonEmpty (Text, Schema)) _Union = prism' build match where - build = OneOf . fmap (\(n,sc) -> Record [(n, Field sc True)]) + build = foldMap (\(n,sc) -> Record [(n, Field sc True)]) match (OneOf scc) = traverse viewAlt scc - match _ = Nothing + match x = (:| []) <$> viewAlt x viewAlt :: Schema -> Maybe (Text, Schema) viewAlt (Record [(n,Field sc True)]) = Just (n, sc) viewAlt _ = Nothing --- -------------------------------------------------------------------------------- --- Finite schemes - --- | Ensure that a 'Schema' is finite by enforcing a max depth. --- The result is guaranteed to be a supertype of the input. -finite :: Natural -> Schema -> Schema -finite = go - where - go :: Natural -> Schema -> Schema - go 0 _ = Empty - go d (Record opts) = Record $ fromList $ mapMaybe - (\(fieldname, Field sc isOptional) -> case go (max 0 (pred d)) sc of - Empty -> Nothing - sc' -> Just (fieldname, Field sc' isOptional) - ) - (Map.toList opts) - go d (Array sc ) = Array (go (max 0 (pred d)) sc) - go d (StringMap sc ) = StringMap (go (max 0 (pred d)) sc) - go d (AllOf opts) = let d' = max 0 (pred d) in AllOf (finite d' <$> opts) - go d (OneOf opts) = let d' = max 0 (pred d) in OneOf (finite d' <$> opts) - go _ other = other - --- | Ensure that a 'Value' is finite by enforcing a max depth in a schema preserving way -finiteValue :: Validators -> Natural -> Schema -> Value -> Value -finiteValue validators d sc - | Right cast <- isSubtypeOf validators sc (finite d sc) = cast - | otherwise = error "bug in isSubtypeOf" - -- ------------------------------------------------------------------------------------------------------ --- Versions - --- | Flattens alternatives. Returns a schema without 'AllOf' constructors -versions :: Schema -> NonEmpty Schema -versions (AllOf scc) = join $ traverse versions scc -versions (OneOf scc) = OneOf <$> traverse versions scc -versions (Record fields) = Record <$> ((traverse . fieldSchemaL) versions fields) -versions (Array sc) = Array <$> versions sc -versions (StringMap sc) = StringMap <$> versions sc -versions x = [x] - --- ------------------------------------------------------------------------------------------------------ -- Validation type Trace = [Text] @@ -164,7 +130,9 @@ | PrimMismatch {have, want :: Text} | InvalidChoice{choiceNumber :: Int} | TryFailed { name :: Text } + | UnusedFields [[Text]] | AllAlternativesFailed { mismatches :: [(Trace,Mismatch)]} + | UnexpectedAllOf | NoMatches deriving (Eq, Show, Typeable) @@ -184,7 +152,7 @@ go ctx (Prim n) x = case Map.lookup n validators of Nothing -> failWith ctx (PrimValidatorMissing n) Just v -> case v x of - Nothing -> pure () + Nothing -> pure () Just err -> failWith ctx (PrimError n err) go ctx (StringMap sc) (A.Object xx) = ifor_ xx $ \i -> go (i : ctx) sc go ctx (Array sc) (A.Array xx) = @@ -209,7 +177,6 @@ (toList scc) ) alts - go ctx (AllOf scc) v = go ctx (OneOf scc) v go ctx a b = failWith ctx (ValueMismatch a b) -- ------------------------------------------------------------------------------------------------------ @@ -222,39 +189,50 @@ -- > Record [("a", Bool)] `isSubtypeOf` Record [("a", Number)] -- Nothing isSubtypeOf :: Validators -> Schema -> Schema -> Either [(Trace, Mismatch)] (Value -> Value) -isSubtypeOf validators sub sup = runExcept $ go [] sup sub +isSubtypeOf validators sub sup = runExcept $ go [] [] sup sub where - failWith :: Trace -> Mismatch -> Except [(Trace, Mismatch)] a + failWith :: Trace -> Mismatch -> Except [(Trace, Mismatch)] b failWith ctx m = throwE [(reverse ctx, m)] -- TODO go: fix confusing order of arguments - go :: Trace -> Schema -> Schema -> Except [(Trace,Mismatch)] (Value -> Value) --- go _ sup sub | pTraceShow ("isSubtypeOf", sub, sup) False = undefined - go _tx Empty _ = pure $ const emptyValue - go _tx (Array _) Empty = pure $ const (A.Array []) - go _tx (Record _) Empty = pure $ const emptyValue - go _tx (StringMap _) Empty = pure $ const emptyValue - go _tx OneOf{} Empty = pure $ const emptyValue - go ctx (Prim a) (Prim b ) = do + go + :: [(SchemaName, Except [(Trace, Mismatch)] (Value -> Value))] + -> Trace + -> Schema + -> Schema + -> Except [(Trace, Mismatch)] (Value -> Value) + -- go _ _ sup sub | pTraceShow ("isSubtypeOf", sub, sup) False = undefined + go env ctx (Named a sa) (Named b sb) | a == b = + case lookup a env of + Just sol -> sol + Nothing -> + let sol = go ((a,sol) : env) ctx sa sb + in sol + go _nv _tx Empty _ = pure $ const emptyValue + go _nv _tx (Array _) Empty = pure $ const (A.Array []) + go _nv _tx (Record _) Empty = pure $ const emptyValue + go _nv _tx (StringMap _) Empty = pure $ const emptyValue + go _nv _tx OneOf{} Empty = pure $ const emptyValue + go _nv ctx (Prim a) (Prim b ) = do unless (a == b) $ failWith ctx (PrimMismatch b a) pure id - go ctx (Array a) (Array b) = do - f <- go ("[]" : ctx) a b + go env ctx (Array a) (Array b) = do + f <- go env ("[]" : ctx) a b pure $ over (_Array . traverse) f - go ctx (StringMap a) (StringMap b) = do - f <- go ("Map" : ctx) a b + go env ctx (StringMap a) (StringMap b) = do + f <- go env ("Map" : ctx) a b pure $ over (_Object . traverse) f - go ctx (Enum opts) (Enum opts') = + go _nv ctx (Enum opts) (Enum opts') = case NE.nonEmpty $ NE.filter (`notElem` opts) opts' of Nothing -> pure id Just xx -> failWith ctx $ MissingEnumChoices xx - go ctx (Union opts) (Union opts') = do + go env ctx (Union opts) (Union opts') = do ff <- forM opts' $ \(n, sc) -> do - sc' <- maybe (failWith ctx $ InvalidConstructor n) pure $ lookup n (toList opts) - f <- go (n : ctx) sc sc' + sc' :: Schema <- maybe (failWith ctx $ InvalidConstructor n) return $ lookup n (toList opts) + f <- go env (n : ctx) sc' sc return $ over (_Object . ix n) f return (foldr (.) id ff) - go ctx (Record opts) (Record opts') = do + go env ctx (Record opts) (Record opts') = do forM_ (Map.toList opts) $ \(n, f) -> unless (not (isRequired f) || Map.member n opts') $ failWith ctx $ MissingRecordField n @@ -265,35 +243,21 @@ Just f@(Field sc _) -> do unless (not (isRequired f) || isRequired f') $ failWith ctx $ OptionalRecordField n' - witness <- go (n' : ctx) sc sc' + witness <- go env (n' : ctx) sc sc' pure $ over (_Object . ix n') witness return (foldr (.) id ff) - go ctx (AllOf sup) sub = do - (i, c) <- msum $ imap (\i sup' -> (i,) <$> go ( tag i : ctx) sup' sub) sup - return $ \v -> A.object [(tag i, c v)] - go ctx sup (AllOf scc) = asum - [ go ctx sup b <&> \f -> - fromMaybe - ( error - $ "failed to upcast an AllOf value due to missing entry: " - <> field - ) - . preview (_Object . ix (pack field) . to f) - | (i, b) <- zip [(1 :: Int) ..] (NE.toList scc) - , let field = "#" <> show i - ] - go ctx sup (OneOf [sub]) = go ctx sup sub - go ctx sup (OneOf sub ) = do - alts <- traverse (\sc -> (sc, ) <$> go ctx sup sc) sub + go env ctx sup (OneOf [sub]) = go env ctx sup sub + go env ctx sup (OneOf sub ) = do + alts <- traverse (\sc -> (sc, ) <$> go env ctx sup sc) sub return $ \v -> head $ mapMaybe (\(sc, f) -> if null (validate validators sc v) then Just (f v) else Nothing) (toList alts) - go ctx (OneOf sup) sub = asum $ fmap (\x -> go ctx x sub) sup - go ctx (Array a) b = do - f <- go ctx a b + go env ctx (OneOf sup) sub = asum $ fmap (\x -> go env ctx x sub) sup + go env ctx (Array a) b = do + f <- go env ctx a b pure (A.Array . fromList . (: []) . f) - go _tx a b | a == b = pure id - go ctx a b = failWith ctx (SchemaMismatch a b) + -- go _tx a b | a == b = pure id + go _nv ctx a b = failWith ctx (SchemaMismatch a b) -- ---------------------------------------------- -- Utils @@ -316,11 +280,6 @@ [] -> [(obj, 0)] other -> other decodeAlternatives x = [(x,0)] - -encodeAlternatives :: NonEmpty Value -> Value -encodeAlternatives [x] = x -encodeAlternatives xx = A.object $ fromList [ (tag i, x) | (i,x) <- zip [(1::Int)..] (toList xx) ] - -- | Generalized lookup for Foldables lookup :: (Eq a, Foldable f) => a -> f (a,b) -> Maybe b lookup a = fmap snd . find ((== a) . fst) diff --git a/test/Generators.hs b/test/Generators.hs --- a/test/Generators.hs +++ b/test/Generators.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE TupleSections #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-orphans #-} module Generators where @@ -16,26 +18,16 @@ import Test.QuickCheck hasOneOf :: Schema -> Bool -hasOneOf (Array sc) = hasOneOf sc +hasOneOf (Array sc) = hasOneOf sc hasOneOf (StringMap sc) = hasOneOf sc -hasOneOf (Record ff) = any (hasOneOf . fieldSchema) ff -hasOneOf (AllOf scc) = any hasOneOf scc -hasOneOf (OneOf _) = True -hasOneOf _ = False - -hasAllOf :: Schema -> Bool -hasAllOf (Array sc) = hasAllOf sc -hasAllOf (StringMap sc) = hasAllOf sc -hasAllOf (Record ff) = any (hasAllOf . fieldSchema) ff -hasAllOf (OneOf scc) = any hasAllOf scc -hasAllOf (AllOf _) = True -hasAllOf _ = False +hasOneOf (Record ff) = any (hasOneOf . fieldSchema) ff +hasOneOf (OneOf _) = True +hasOneOf _ = False instance Arbitrary Schema where arbitrary = sized genSchema shrink (Record fields) = [Record [(n,Field sc' req)] | (n,Field sc req) <- toList fields, sc' <- shrink sc] - shrink (AllOf scc) = [AllOf [sc'] | sc <- toList scc, sc' <- shrink sc] shrink (OneOf scc) = [OneOf [sc'] | sc <- toList scc, sc' <- shrink sc] shrink (Array sc) = [sc] shrink (StringMap sc) = [sc] @@ -56,18 +48,17 @@ constructorNames :: [Text] constructorNames = ["constructor1", "constructor2"] -genSchema :: Int -> Gen (Schema) +genSchema :: Int -> Gen Schema genSchema 0 = elements [Empty, Prim "A", Prim "B"] genSchema n = frequency - [ (10,) $ Record <$> do + [ (10,) $ Record <$> do nfields <- choose (1,2) fieldArgs <- replicateM nfields (scale (`div` succ nfields) arbitrary) return $ fromList (zipWith (\n (sc,a) -> (n, Field sc a)) fieldNames fieldArgs) - , (10,) $ Array <$> scale(`div` 4) arbitrary + , (10,) $ Array <$> scale(`div` 4) arbitrary , (10,) $ Enum <$> do n <- choose (1,2) return $ fromList $ take n ["Enum1", "Enum2"] - , (1,) $ AllOf . fromList <$> listOf1 (genSchema (n`div`10)) , (1,) $ OneOf . fromList <$> listOf1 (genSchema (n`div`10)) , (5,) $ review _Union <$> do nconstructors <- choose (1,2) diff --git a/test/Schemas/OpenApi2Spec.hs b/test/Schemas/OpenApi2Spec.hs --- a/test/Schemas/OpenApi2Spec.hs +++ b/test/Schemas/OpenApi2Spec.hs @@ -18,7 +18,7 @@ let document = toOpenApi2Document defaultOptions [("Person", theSchema @Person)] Map.keys (definitions document) `shouldContain` ["Person"] Map.keys (failures document) `shouldNotContain` ["Person"] - it "does Nothing for Person2" $ do + it "works for Person2" $ do let document = toOpenApi2Document defaultOptions [("Person2", theSchema @Person2)] - Map.keys (definitions document) `shouldNotContain` ["Person2"] - Map.keys (failures document) `shouldContain` ["Person2"] + Map.keys (definitions document) `shouldContain` ["Person2"] + Map.keys (failures document) `shouldNotContain` ["Person2"] diff --git a/test/SchemasSpec.hs b/test/SchemasSpec.hs --- a/test/SchemasSpec.hs +++ b/test/SchemasSpec.hs @@ -1,26 +1,34 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module SchemasSpec where -import Control.Exception -import qualified Data.Aeson as A -import Data.Either -import Data.Maybe -import Generators -import Person -import Person2 -import Person3 -import Schemas -import Schemas.Internal -import Schemas.Untyped (Validators) -import System.Timeout -import Test.Hspec -import Test.Hspec.Runner -import Test.Hspec.QuickCheck -import Test.QuickCheck -import Text.Show.Functions () +import Control.Exception +import Control.Monad.Trans.Except +import qualified Data.Aeson as A +import Data.Coerce +import Data.Either +import Data.Foldable +import Data.Functor.Identity +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Generators +import Person +import Person2 +import Person3 +import Person4 +import Schemas +import Schemas.Untyped (Validators) +import System.Timeout +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.Hspec.Runner +import Test.QuickCheck +import Text.Show.Functions () main :: IO () main = hspecWith defaultConfig{configQuickCheckMaxSuccess = Just 10000} spec @@ -36,24 +44,9 @@ `shouldThrow` \(_ :: SomeException) -> True fromRight undefined (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [])) (Nothing :: Maybe Bool) `shouldBe` A.Object [] - it "satisfies the spec" $ do - let encoder = encodeTo (theSchema @Person) - spec = encodeToSpec (theSchema @Person) - encoder `shouldSatisfy` isRight - spec `shouldSatisfy` isJust - fromRight undefined encoder pepe `shouldBe` fromJust spec pepe - describe "versions" $ do - prop "eliminates AllOf" $ \sc -> all (not . hasAllOf) (versions sc) - describe "finite" $ do + describe "isSubtypeOf" $ do it "is reflexive (in absence of OneOf)" $ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc -> sc `shouldBeSubtypeOf` sc - it "is reflexive (corner case)" $ - finiteCornerCase `shouldBeSubtypeOf` finiteCornerCase - it "always produces a supertype (in absence of OneOf)" $ - forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc -> - forAll arbitrary $ \(SmallNatural size) -> - all (\sc -> isRight $ isSubtypeOf primValidators sc (finite size sc)) (versions sc) - describe "isSubtypeOf" $ do it "subtypes can add fields" $ do Record [makeField "a" prim True, makeField "def" prim True] `shouldBeSubtypeOf` Record [makeField "def" prim True] @@ -68,6 +61,9 @@ it "subtypes can relax the type of a field" $ do Record [makeField "a" prim True] `shouldBeSubtypeOf` Record [makeField "a" (Array prim) True] + it "subtypes can relax the type of a constructor field" $ do + Union [constructor' "a" prim] + `shouldBeSubtypeOf` Union [constructor' "a" (Array prim)] it "subtypes cannot remove Required fields" $ do Record [makeField "def" prim True] `shouldNotBeSubtypeOf` Record [makeField "def" prim True, makeField "a" prim True] @@ -90,46 +86,90 @@ Array prim `shouldNotBeSubtypeOf` prim describe "HasSchema" $ do it "Left is a constructor of Either" $ do - Union [constructor' "Left" Empty] `shouldBeSubtypeOf` theSchema @(Either () ()) + shouldBeAbleToDecode @(Either () ()) [Union [constructor' "Left" Empty]] it "left is a constructor of Either too" $ do - Union [constructor' "left" Empty] `shouldBeSubtypeOf` theSchema @(Either () ()) + shouldBeAbleToDecode @(Either () ()) [Union [constructor' "left" Empty]] describe "examples" $ do - describe "Schemas" $ do - prop "finite(schema @Schema) is a supertype of (schema @Schema)" $ \(SmallNatural n) -> - theSchema @Schema `shouldBeSubtypeOf` finite n (theSchema @Schema) + let person4_v0 = theSchema @Person4 + person2_v0 = theSchema @Person2 + person3_v0 = theSchema @Person3 + person4_vPerson2 = person2_v0 + person4_vPerson3 = person3_v0 + encoder_p4v0 = encodeTo person4_v0 + encoder_p3_to_p4 = encodeTo person4_vPerson3 + encoder_p2_to_p4 = encodeTo person4_vPerson2 + encoder_p2v0 = encodeTo person2_v0 + encoder_p3v0 = encodeTo @Person3 person3_v0 describe "Person" $ do - it "decode is the inverse of encode" $ do - decode (encode pepe) `shouldBe` Right pepe - decode (fromRight undefined (encodeTo (theSchema @Person)) pepe) `shouldBe` Right pepe + schemaSpec schema pepe describe "Person2" $ do - it "decode is the inverse of encode" $ do - decode (encode pepe2) `shouldBe` Right pepe2 - let fullEncoder = encodeTo (theSchema @Person2) - fullEncoder `shouldSatisfy` isRight - decode (fromRight (error "internal error") fullEncoder pepe2) `shouldBe` Right pepe2 + schemaSpec schema pepe2 it "Person2 < Person" $ do - theSchema @Person2 `shouldBeSubtypeOf` theSchema @Person + shouldBeAbleToEncode @Person2 (extractSchema @Person schema) + -- shouldBeAbleToDecode @Person (extractSchema @Person2 schema) it "pepe2 `as` Person" $ do let encoder = encodeTo (theSchema @Person) encoder `shouldSatisfy` isRight decode (fromRight undefined encoder pepe2) `shouldBe` Right pepe it "pepe `as` Person2" $ do let decoder = decodeFrom (theSchema @Person) - decoder `shouldSatisfy` isJust - fromJust decoder (encode pepe) `shouldBe` Right pepe2{Person2.education = [Person.studies pepe]} + decoder `shouldSatisfy` isRight + fromRight undefined decoder (encode pepe) `shouldBe` Right pepe2{Person2.education = [Person.studies pepe]} it "Person < Person2" $ do - theSchema @Person `shouldBeSubtypeOf` theSchema @Person2 + -- shouldBeAbleToEncode @Person (extractSchema @Person2 schema) + shouldBeAbleToDecode @Person2 (extractSchema @Person schema) describe "Person3" $ do - it "finiteEncode works as expected" $ shouldLoop $ evaluate $ A.encode - (finiteEncode 4 laura3) - - -encodeToWithSpec :: TypedSchema a -> Schema -> Maybe (a -> A.Value) -encodeToWithSpec sc target = case isSubtypeOf (extractValidators sc) (extractSchema sc) target of - Right cast -> Just $ cast . encodeWith sc - _ -> Nothing + it "can compute an encoder for Person3 (circular schema)" $ + shouldNotLoop $ evaluate encoder_p3v0 + describe "Person4" $ do + schemaSpec schema pepe4 + let encoded_pepe4 = fromRight undefined encoder_p4v0 pepe4 + encoded_pepe3 = fromRight undefined encoder_p3_to_p4 pepe3{Person3.spouse = Nothing} + encoded_pepe2 = fromRight undefined encoder_p2_to_p4 pepe2 + encoded_pepe2' = fromRight undefined encoder_p2v0 pepe2 + it "can compute an encoder for Person4" $ do + shouldNotLoop $ evaluate encoder_p4v0 + encoder_p4v0 `shouldSatisfy` isRight + it "can compute an encoder for Person3 in finite time" $ do + shouldNotLoop $ evaluate encoder_p3_to_p4 + it "can compute an encoder for Person2 in finite time" $ do + shouldNotLoop $ evaluate encoder_p2_to_p4 + it "can encode a Person4" $ do + shouldNotLoop $ evaluate $ A.encode encoded_pepe4 + it "can encode a Person2 as Person4 in finite time" $ do + shouldNotLoop $ evaluate $ A.encode encoded_pepe2 + it "can decode a fully defined record with source schema" $ do + let res = fromRight undefined (decodeFrom person4_v0) encoded_pepe4 + shouldNotLoop $ evaluate res + res `shouldBe` Right pepe4 + it "can decode a fully defined record without source schema" $ do + let res = decode encoded_pepe4 + shouldNotLoop $ evaluate res + res `shouldBe` Right pepe4 + it "can decode a Person2 encoded to Person4 with source schema" $ do + let res = fromRight undefined (decodeFrom person4_vPerson2) encoded_pepe2 + shouldNotLoop $ evaluate res + res `shouldBe` Right pepe4 + it "can decode a Person2" $ do + let res = fromRight undefined (decodeFrom person2_v0) encoded_pepe2' + holds = res == Right pepe4 + shouldNotLoop $ evaluate holds + shouldNotLoop $ evaluate $ length $ show res + res `shouldBe` Right pepe4 -encodeToSpec tgt = encodeToWithSpec schema tgt +schemaSpec :: (Eq a, Show a) => TypedSchema a -> a -> Spec +schemaSpec sc ex = do + let encoder = encodeToWith sc (NE.head $ extractSchema sc) + decoder = decodeFromWith sc (NE.head $ extractSchema sc) + encodedExample = fromRight undefined encoder ex + it "Can encode itself" $ + encoder `shouldSatisfy` isRight + it "Can decode itself" $ + decoder `shouldSatisfy` isRight + it "Roundtrips ex" $ + fromRight undefined decoder encodedExample `shouldBe` Right ex + it "Roundtrips ex (2)" $ + decodeWith sc (encodeWith sc ex) `shouldBe` Right ex shouldBeSubtypeOf :: Schema -> Schema -> Expectation shouldBeSubtypeOf a b = case isSubtypeOf primValidators a b of @@ -141,12 +181,28 @@ Right _ -> expectationFailure $ show a <> " should not be a subtype of " <> show b _ -> pure () -shouldLoop :: (Show a, Eq a) => IO a -> Expectation -shouldLoop act = timeout 1000000 act `shouldReturn` Nothing +shouldLoop :: (Show a) => IO a -> Expectation +shouldLoop act = do + res <- timeout 1000000 act + res `shouldSatisfy` isNothing -shouldNotLoop :: (Show a, Eq a) => IO a -> Expectation -shouldNotLoop act = timeout 1000000 act `shouldNotReturn` Nothing +shouldNotLoop :: (Show a) => IO a -> Expectation +shouldNotLoop act = do + res <- timeout 1000000 act + res `shouldSatisfy` isJust +shouldBeAbleToEncode :: forall a . (HasSchema a) => NE.NonEmpty Schema -> Expectation +shouldBeAbleToEncode sc = asumEither (fmap (encodeTo @a) sc) `shouldSatisfy` isRight + +shouldBeAbleToDecode :: forall a . (HasSchema a) => NE.NonEmpty Schema -> Expectation +shouldBeAbleToDecode sc = asumEither (fmap (decodeFrom @a) sc) `shouldSatisfy` isRight + +asumEither :: forall e a . (Monoid e) => NE.NonEmpty (Either e a) -> Either e a +asumEither = Data.Coerce.coerce asumExcept + where + asumExcept :: NE.NonEmpty (Except e a) -> Except e a + asumExcept = asum + makeField :: a -> Schema -> Bool -> (a, Field) makeField n t isReq = (n, Field t isReq) @@ -158,6 +214,3 @@ primValidators :: Validators primValidators = validatorsFor @(Schema, Double, Int, Bool) - -finiteCornerCase :: Schema -finiteCornerCase = AllOf [ Array $ Prim "A"]