schemas 0.1.0.0 → 0.1.1.0

raw patch · 9 files changed

+324/−88 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• README.md +54/−0
• schemas.cabal +30/−3
• src/Schemas.hs +64/−22
• src/Schemas/Class.hs +13/−3
• src/Schemas/Internal.hs +124/−47
• src/Schemas/SOP.hs +1/−1
• src/Schemas/Untyped.hs +28/−7
• test/SchemasSpec.hs +4/−4

@@ -1,5 +1,10 @@ # Revision history for schemas -## 0.1.0.0 -- YYYY-mm-dd+## 0.1.1.0 -- +* Fixed several bugs in `isSubtypeOf` and `encodeWith`+* Better error messages when encoding with a partial schema fails+* New: 'liftPrism' and 'oneOf'++## 0.1.0.0 -- 2019-09-25  * First version. Released on an unsuspecting world.

@@ -0,0 +1,54 @@+[![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)+# schemas+A library for schema-guided serialization of Haskell data types. ++## Features+* schemas are first-class citizens and can be reasoned about,+* schema construction is statically typed,+* versioning is driven by a subtyping relation, no need for version numbers,+* Serialization to JSON only currently++## Why 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 and reasoned about. Serialization and deserialization require a source and target schema, and versioning is accomplished by checking that the two schemas are related by a subtyping relation. There is no need to keep old versions of datatypes around nor to write code for upgrades/downgrades.++Consider a schema modification that adds a field. To support upgrading old documents to the new schema, the only requirement is that the new field is optional. Downgrading is easy too, simply omit the new field. Conversely, a schema modifcation that removes a field supports trivial upgrades but the removed field must be optional to support downgrading. Changing the type of a field is supported in as much as the old and new types are relatable. Field renaming is not supported. More importantly, all these changes are defined by a schema relation, and the library provides a predicate to check whether the relation holds.++schemas can also be used in a GraphQL-like fashion, allowing clients to request a subset of the schema. This comes up specially when working with recursive schemas involving cyclic data.++## Subtyping relation++schemas relies on a simple subtyping relation between schemas to perform value conversions. The basic idea is that these conversions are fully guided by the source and target schemas and involve only simple projections and injections:+1. Projecting a subset of the source record fields.+2. Turning a source field of type `A` into a target field of type `Array A`.++For more concrete details on the subtyping relation check the definition of `isSubtypeOf`. This function returns a witness, i.e. a conversion function, whenever the relation holds.++Versioning makes use of this subtyping relation as follows. Downgrading a value `v_2 :: T_2` into a previous version `T_1` is accomplished via the witness of `schema(T_1) < schema(T_2)`. Similarly, upgrading a `v_1 :: T_1` message into a newer version `T_2` can be accomplished via the witness of `schema(T_1) > schema(T_2)`. Therefore, a type `T_1` can only be replaced by a type `T_2` in an downgrade-compatible way if `schema(T_1) < schema(T_2)`; if upggrades are required, then `schema(T_1) > schema(T_2)` is required too.++The `<` relation is reflexive and transitive, but importantly not asymmetric or antisymmetric: it can be that both `T_1 < T_2` and `T_2 < T_1` and yet they are not the same type. For example, given a `S_2` schema that adds a required field to `S_1`, we would have that `S_1 < S_2` but not `S_1 > S_2`. However, if new the field was optional, then we would have `S_1 > S_2` too. In such case, we say that `S_1 ~ S_2` because they only differ on optional fields.+For example, given a `S_3` schema that removes a field from `S_2`, we have:+- `S_2 > S_3` therefore we can upgrade `S_2` values to `S_3`+- `S_2 ~ S_3` if the removed field is optional, in which case we can also downgrade `S_3` values to `S_2`++The `~` relation is an equivalence class, i.e. it is reflexive, symmetric and transitive.++## Alternative encodings++Sometimes there is more than one way to encode a value. A field can be renamed or change its type, an optional field become mandatory, several fields can be merged into one, etc. Alternative encodings allow for backwards compatible schema evolution.++Schemas support alternative encodings via the 'Or' constructor. The schema `A|B` encodes a value in two alternative ways `A` and `B`. A message created with this schema may encodings A, B or both. 'encode' will always create messages with all the possible encodings. While messages with multiple alternative encodings are not desirable for serialization, the desired message can be carved out using the subtyping relation. All the following hold:+```+A|B < A (the coercion A -> A|B will produce a message with an A encoding)+A|B < B (the coercion B -> A|B will produce a message with a  B encoding)+A < A|B (the coercion A|B -> A will succeed only if the message contains an A encoding)+B < A|B (the coercoin A|B -> B will succeed only if the message contains a  B encoding)+```++Typed schemas implement a limited form of alternative encodings via the `Alternative` instance for record fields. In the future a similar 'Alternative' instance for union constructors could be added.++## Example+- [Person](example/Person.hs)+- [Person2](example/Person2.hs)+- [Person3](example/Person3.hs)

@@ -1,8 +1,29 @@ cabal-version:       2.0 name:                schemas-version:             0.1.0.0+version:             0.1.1.0 synopsis:            schema guided serialization--- description:+description:+  Schemas is a Haskell library for serializing and deserializing data in JSON.+  With schemas one does not define parsing and encoding functions, instead one+  defines a schema that explains the "shape" of the data, and the library provides+  the encode and decode functions. Shape descriptions are statically typed.+  .+  Schemas are related by a subtyping relation, which can be used to implement+  a simple form of schema versioning. As long as one knows the source and target+  schemas, and the source is a subtype of the target, source values can be encoded+  in the target schema.+  .+  The library also supports @oneOf@ and @allOf@ schemas, which extend the+  range of versioning changes that can be supported automatically without+  resorting to explicit versions and conversion functions.+  .+  A type class @HasSchema@ is provided purely for convenience, but none of the+  core functions in the library rely on type classes.+  .+  Schemas can be derived generically using @generics-sop@, although most of the+  time it makes more sense to define the schemas explicitly to ensure well-behaved+  versioning.+ -- bug-reports: license:             BSD3 license-file:        LICENSE@@ -11,7 +32,13 @@ -- copyright: category:            Data build-type:          Simple-extra-source-files:  CHANGELOG.md+extra-source-files:  CHANGELOG.md, README.md+homepage:            https://github.com/pepeiborra/schemas+bug-reports:         https://github.com/pepeiborra/schemas/issues++source-repository head+    type:            git+    location:        https://github.com/pepeiborra/schemas.git  library   exposed-modules:

@@ -1,39 +1,59 @@ {-# LANGUAGE PatternSynonyms #-}++-- | As a simple example of a schema, let's consider a simple record type:+--+-- @+--  import Schemas+--  import Schemas.SOP+--+--  data Person = Person+--    { name      :: String+--    , age       :: Int+--    , addresses :: [String]+--    }+--+--  personSchema :: TypedSchema Person+--  personSchema = record $ Person+--    \<$\> fieldWith string "name" name+--    \<*\> fieldWith int    "age"  age+--    \<*\> fieldWith (list string) "addresses" addresses+-- @+--+-- Or, by relying on the @HasSchema@ type class:+--+-- @+--  personSchema :: TypedSchema Person+--  personSchema = record $ Person+--    \<$\> field "name" name+--    \<*\> field "age"  age+--    \<*\> field "addresses" addresses+-- @+--+-- Or, if the type is SOP generic:+--+-- @+-- personSchema = gSchema defOptions+-- @+ module Schemas  (-  -- * Schemas-    Field(..)-  , Schema(.., Empty, Union)-  , _Empty-  , _Union-  -- ** functions for working with schemas-  , Mismatch(..)-  , Trace-  , isSubtypeOf-  , versions-  , coerce-  , finite-  , validate-  , validatorsFor   -- * Typed schemas+    TypedSchemaFlex   , TypedSchema-  , TypedSchemaFlex   , HasSchema(..)-  , theSchema-  , extractSchema   -- ** Construction   , enum   , readShow   , list   , vector+  , Key(..)   , stringMap   , viaJSON   , viaIso-  , Key(..)   -- *** Applicative record definition   , record-  , RecordField   , RecordFields+  , RecordField   , field   , fieldWith   , fieldWith'@@ -46,14 +66,17 @@   , fieldNameL   , overFieldNames   , extractFields-  , liftMaybe-  , liftEither+  -- *** Partial schemas+  , liftJust+  , liftRight+  , liftPrism   -- *** Unions   , union   , union'-  , UnionTag(..)   , alt   , altWith+  , UnionTag+  , oneOf   -- * Encoding   , encode   , decode@@ -67,6 +90,24 @@   -- * working with recursive schemas   , finiteValue   , finiteEncode++  -- * Untyped schemas+  , Schema(.., Empty, Union)+  ,  Field(..)+  , _Empty+  , _Union+  -- ** Extraction+  , extractSchema+  , theSchema+  -- ** Functions+  , Mismatch(..)+  , Trace+  , isSubtypeOf+  , versions+  , coerce+  , finite+  , validate+  , validatorsFor   -- * Reexports   , Profunctor(..)   )@@ -76,3 +117,4 @@ import Schemas.Class import Schemas.Internal import Schemas.Untyped+

@@ -145,7 +145,7 @@  -- HasSchema aware combinators -- ------------------------------------------------------------------------------------+-- | Extract the default 'Schema' for a type theSchema :: forall a . HasSchema a => Schema theSchema = extractSchema (schema @a) @@ -156,6 +156,9 @@ encode :: HasSchema a => a -> Value encode = encodeWith schema +-- | Attempt to encode to the target schema using the default schema.+--   First encodes using the default schema, then computes a coercion+--   applying 'isSubtypeOf', and then applies the coercion to the encoded data. encodeTo :: HasSchema a => Schema -> Maybe (a -> Value) encodeTo = encodeToWith schema @@ -163,9 +166,12 @@ 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 = decodeFromWith schema @@ -175,12 +181,15 @@   Right cast -> Just . cast   _          -> const Nothing +-- | @field name get@ introduces a field with the default schema for the type field :: HasSchema a => Text -> (from -> a) -> RecordFields from a field = fieldWith schema +-- | @optField name get@ introduces an optional field with the default schema for the type optField :: forall a from. HasSchema a => Text -> (from -> Maybe a) -> RecordFields from (Maybe a)-optField n get = optFieldWith (lmap get $ liftMaybe (schema @a)) n+optField n get = optFieldWith (lmap get $ liftJust (schema @a)) n +-- | @optFieldEither name get@ introduces an optional field with the default schema for the type optFieldEither     :: forall a from e      . HasSchema a@@ -188,7 +197,8 @@     -> (from -> Either e a)     -> e     -> RecordFields from (Either e a)-optFieldEither n x e = optFieldGeneral (lmap x $ liftEither schema) n (Left e)+optFieldEither n x e = optFieldGeneral (lmap x $ liftRight schema) n (Left e) +-- | @alt name prism@ introduces a discriminated union alternative with the default schema alt :: HasSchema a => Text -> Prism' from a -> UnionTag from alt = altWith schema

@@ -1,3 +1,4 @@+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveAnyClass             #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GADTs                      #-}@@ -14,7 +15,7 @@ import           Control.Alternative.Free import           Control.Applicative        (Alternative (..)) import           Control.Exception-import           Control.Lens               hiding (Empty, enum, (<.>))+import           Control.Lens               hiding (Empty, enum, (<.>), allOf) import           Control.Monad import           Control.Monad.Trans.Except import           Data.Aeson                 (Value)@@ -29,9 +30,9 @@ import           Data.List.NonEmpty         (NonEmpty (..)) import qualified Data.List.NonEmpty         as NE import           Data.Maybe+import           Data.Semigroup import           Data.Text                  (Text, pack) import           Data.Tuple-import           Data.Typeable              (Typeable) import           Data.Vector                (Vector) import qualified Data.Vector                as V import           GHC.Exts                   (IsList (..))@@ -43,7 +44,12 @@  -- | @TypedSchemaFlex enc dec@ is a schema for encoding to @enc@ and decoding to @dec@. --   Usually we want @enc@ and @dec@ to be the same type but this flexibility comes in handy---   when composing typed schemas.+--   for composition.+--+--   * introduction forms: 'record', 'enum', 'schema'+--   * operations: 'encodeTo', 'decodeFrom', 'extractSchema'+--   * 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@@ -54,44 +60,68 @@   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'+  -- TTry _ is used to implement 'optField' on top of 'optFieldWith'   -- it could be exposed to provide some form of error handling, but currently is not-  TTry   :: TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b+  TTry     :: Text -> TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b   RecordSchema :: RecordFields from a -> TypedSchemaFlex from a +-- | @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)  where   altMap = fmap swap $ alts --TODO fast lookup   alts   = opts <&> \x -> (showF x, x) +-- | @stringMap sc@ is the schema for a stringmap where the values have schema @sc@ stringMap :: TypedSchema a -> TypedSchema (HashMap Text a) stringMap sc = TMap sc id id +-- | @list sc@ is the schema for a list of values with schema @sc@ list :: IsList l => TypedSchema (Item l) -> TypedSchema l list schema = TArray schema (fromList . V.toList) (V.fromList . toList) +-- | @vector sc@ is the schema for a vector of values with schema @sc@ vector :: TypedSchema a -> TypedSchema (Vector a) vector sc = TArray sc id id +-- | @viaJson label@ constructs a schema reusing existing 'aeson' instances. The resulting schema+--  is opaque and cannot be subtyped and/or versioned, so this constructor should be used sparingly.+--  The @label@ is used to describe the extracted 'Schema'. viaJSON :: (A.FromJSON a, A.ToJSON a) => Text -> TypedSchema a viaJSON n = TPrim n A.fromJSON A.toJSON +-- | Apply an isomorphism to a schema viaIso :: Iso' a b -> TypedSchema a -> TypedSchema b viaIso iso sc = withIso iso $ \from to -> dimap to from sc +-- | The schema of String values string :: TypedSchema String string = viaJSON "String" +-- | A schema for types that can be parsed and pretty-printed. The resulting schema is opaque and cannot+-- be subtyped/versioned, so this constructor is best used for primitive value 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+  f (TOneOf xx) = xx+  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        sc        try) = TTry (rmap f sc) (try . g)+    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)@@ -104,12 +134,13 @@   mempty = TEmpty mempty  instance Semigroup a => Semigroup (TypedSchemaFlex f a) where+  -- | Allows defining multiple schemas for the same thing, effectively implementing versioning.   TEmpty a <> TEmpty b = TEmpty (a <> b)   TEmpty{} <> x = x   x <> TEmpty{} = x-  TAllOf aa <> b = TAllOf (aa <> [b])-  a <> TAllOf bb = TAllOf ([a] <> bb)-  a <> b = TAllOf [a,b]+  TAllOf aa <> b = allOf (aa <> [b])+  a <> TAllOf bb = allOf ([a] <> bb)+  a <> b = allOf [a,b]  type TypedSchema a = TypedSchemaFlex a a @@ -117,7 +148,7 @@ -- Applicative records  data RecordField from a where-  RequiredAp :: { fieldName :: Text+  RequiredAp :: { fieldName :: Text  -- ^ Name of the field                 , fieldTypedSchema :: TypedSchemaFlex from a                 } -> RecordField from a   OptionalAp :: { fieldName :: Text@@ -125,6 +156,7 @@                 , fieldDefValue :: a                 } -> RecordField from a +-- | 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@@ -133,39 +165,49 @@   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+--+-- @+--  schemaPerson = Person+--             <$> (field "name" name <|> field "full name" name)+--             <*> (field "age" age <|> pure -1)+-- @ newtype RecordFields from a = RecordFields {getRecordFields :: Alt (RecordField from) a}   deriving newtype (Alternative, Applicative, Functor, Monoid, Semigroup)  instance Profunctor RecordFields where   dimap f g = RecordFields . hoistAlt (lmap f) . fmap g . getRecordFields +-- | 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 --- | Define a record schema using applicative syntax+-- | Wrap an applicative record schema record :: RecordFields from a -> TypedSchemaFlex from a record = RecordSchema +-- | @fieldWith sc n get@ introduces a field fieldWith :: TypedSchema a -> Text -> (from -> a) -> RecordFields from a fieldWith schema n get = fieldWith' (lmap get schema) n +-- | Generalised version of 'fieldWith' fieldWith' :: TypedSchemaFlex from a -> Text -> RecordFields from a fieldWith' schema n = RecordFields $ liftAlt (RequiredAp n schema) -data TryFailed = TryFailed- deriving (Exception, Show, Typeable)---- | Project a schema through a Prism. The resulting schema is empty if the Prism doesn't fit-liftPrism :: Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex s t-liftPrism p sc = withPrism p $ \t f -> rmap t (TTry sc (either (const Nothing) Just . f))+-- | 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)) --- | Use this to build schemas for 'optFieldWith'. The resulting schema is empty for the Nothing case-liftMaybe :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b)-liftMaybe = liftPrism _Just+-- | @liftJust = liftPrism _Just@+liftJust :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b)+liftJust = liftPrism "Just" _Just --- | Use this to build schemas for 'optFieldEitherWith'. The resulting schema is empty for the Left case-liftEither :: TypedSchemaFlex a b -> TypedSchemaFlex (Either c a) (Either c b)-liftEither = liftPrism _Right+-- | @liftRight = liftPrism _Right@+liftRight :: TypedSchemaFlex a b -> TypedSchemaFlex (Either c a) (Either c b)+liftRight = liftPrism "Right" _Right  -- | A generalized version of 'optField'. Does not handle infinite/circular data. optFieldWith@@ -175,6 +217,7 @@     -> RecordFields from (Maybe a) optFieldWith schema n = RecordFields $ liftAlt (OptionalAp n schema Nothing) +-- | The most general introduction form for optional fields optFieldGeneral     :: forall a from      . TypedSchemaFlex from a@@ -189,32 +232,59 @@ optFieldEitherWith schema n e = optFieldGeneral schema n (Left e)  -- | Extract all the field groups (from alternatives) in the record-extractFields :: RecordFields from a -> [[(Text, Field)]]+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 -extractFieldsHelper :: (forall a . RecordField from a -> b) -> RecordFields from a -> [[b]]-extractFieldsHelper f = runAlt_ (\x -> (f x : []) : []) . getRecordFields+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+ -- -------------------------------------------------------------------------------- -- Typed Unions +-- | The schema of discriminated unions+--+-- @+--   import Schemas+--   import "generic-lens" Data.Generics.Labels ()+--   import GHC.Generics+--+--   data Education = Degree Text | PhD Text | NoEducation+--+--   schemaEducation = union'+--     [ alt "NoEducation" #_NoEducation+--     , alt "Degree"      #_Degree+--     , alt "PhD"         #_PhD+--     ]+--   @++-- | 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 +-- | Existential wrapper for convenient definition of discriminated unions data UnionTag from where   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 altWith sc n p = UnionTag n p sc +-- | Given a non empty set of constructors, construct the schema that selects the first+--   matching constructor union' :: (NonEmpty (UnionTag from)) -> TypedSchema from-union' args = union $ args <&> \(UnionTag c p sc) -> (c, liftPrism p sc)+union' args = union $ args <&> \(UnionTag c p sc) -> (c, liftPrism c p sc)  -- -------------------------------------------------------------------------------- -- Schema extraction from a TypedSchema@@ -222,7 +292,7 @@ -- | Extract an untyped schema that can be serialized extractSchema :: TypedSchemaFlex from a -> Schema extractSchema (TPrim n _ _) = Prim n-extractSchema (TTry sc _)      = extractSchema sc+extractSchema (TTry _ sc _)      = extractSchema sc extractSchema (TOneOf scc)     = OneOf $ extractSchema <$> scc extractSchema (TAllOf scc)     = AllOf $ extractSchema <$> scc extractSchema TEmpty{}         = Empty@@ -245,9 +315,9 @@ extractValidators (TAllOf scc) = foldMap extractValidators scc extractValidators (TArray sc _ _) = extractValidators sc extractValidators (TMap sc _ _) = extractValidators sc-extractValidators (TTry sc _) = extractValidators sc+extractValidators (TTry _ sc _) = extractValidators sc extractValidators (RecordSchema rs) = mconcat-  $ mconcat (extractFieldsHelper (extractValidators . fieldTypedSchema) rs)+  $ mconcat $ nonDet (extractFieldsHelper (extractValidators . fieldTypedSchema) rs) extractValidators _ = []  -- ---------------------------------------------------------------------------------------@@ -256,26 +326,33 @@ -- | Given a value and its typed schema, produce a JSON record using the 'RecordField's encodeWith :: TypedSchemaFlex from a -> from -> Value   -- TODO Better error messages to help debug partial schemas ?-encodeWith sc = either (throw . head) id . runExcept . go sc where-  go :: TypedSchemaFlex from a -> from -> Except [SomeException] Value-  go (TAllOf scc) x = encodeAlternatives <$> traverse (`go` x) scc-  go (TOneOf scc) x = asum (fmap (`go` x) scc)-  go (TTry   sc  try   ) x = go sc =<< maybe (throwE [toException TryFailed]) pure (try x)-  go (TEnum  _   fromf ) b = pure $ A.String (fromf b)-  go (TPrim  _ _ fromf ) b = pure $ fromf b+encodeWith sc = either (throw . AllAlternativesFailed) 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-    fields' <- traverse((`catchE` \_ -> pure Nothing) . fmap Just . sequence) fields-    case NE.nonEmpty (catMaybes fields') of-      Nothing -> throwE [] -- NOTE test-      Just fields' -> pure $ encodeAlternatives $ fmap (A.Object . fromList . catMaybes) fields'+    let alternatives = extractFieldsHelper (extractField x) rec+    let results =+          partitionEithers $ nonDet $ fmap (runExcept . sequenceA) alternatives+    case results of+      (_, NE.nonEmpty -> Just fields') -> pure $ encodeAlternatives $ fmap+        (A.Object . fromList . catMaybes)+        fields'+      (ee, _) -> throwE (concat ee)    where-    fields = extractFieldsHelper (extractField x) rec -    extractField b RequiredAp {..} =  Just . (fieldName,) <$> go fieldTypedSchema b-    extractField b OptionalAp {..} = (Just . (fieldName,) <$> go fieldTypedSchema b) `catchE` \_ -> pure Nothing+    extractField b RequiredAp {..} =+      Just . (fieldName, ) <$> go fieldTypedSchema b `catchE` \mm ->+        throwE [InvalidRecordField fieldName mm]+    extractField b OptionalAp {..} =+      (Just . (fieldName, ) <$> go fieldTypedSchema b)+        `catchE` \_ -> pure Nothing  encodeToWith :: TypedSchema a -> Schema -> Maybe (a -> Value) encodeToWith sc target = case isSubtypeOf (extractValidators sc) (extractSchema sc) target of@@ -296,7 +373,7 @@     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 (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))@@ -319,7 +396,7 @@ -- | 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?+-- TODO change decode type to reflect partiality due to TTry _? decodeWith sc = runExcept . go [] sc  where   failWith ctx e = throwE [(reverse ctx, VE e)]@@ -367,7 +444,7 @@   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 (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)

@@ -63,7 +63,7 @@             -> K (Text, TypedSchema (NS (NP I) xss)) xs         mk (Fn inject) (Fn eject) ci = K             ( cons-            , dimap (unComp . eject . K) (unK . inject . fromJust) (liftMaybe $ gSchemaNP opts ci)+            , dimap (unComp . eject . K) (unK . inject . fromJust) (liftJust $ gSchemaNP opts ci)             )             where cons = pack (constructorTagModifier opts (constructorName ci)) 

@@ -10,6 +10,7 @@  module Schemas.Untyped where +import           Control.Exception import           Control.Lens               hiding (Empty, enum, (<.>)) import           Control.Monad import           Control.Monad.Trans.Except@@ -27,6 +28,7 @@ import qualified Data.List.NonEmpty         as NE import           Data.Maybe import           Data.Text                  (Text, pack, unpack)+import           Data.Typeable import           GHC.Exts                   (IsList (..)) import           GHC.Generics               (Generic) import           Numeric.Natural@@ -36,6 +38,11 @@ -- Schemas -- -------------------------------------------------------------------------------- +-- | A schema for untyped data, such as JSON or XML.+--+--   * introduction forms: 'extractSchema', 'theSchema', 'mempty'+--   * operations: 'isSubtypeOf', 'versions', 'coerce', 'validate'+--   * composition: '(<>)' data Schema   = Array Schema   | StringMap Schema@@ -133,7 +140,10 @@ type Trace = [Text]  data Mismatch-  = MissingRecordField { name :: Text}+  = MissingRecordField { name :: Text }+  | MissingEnumChoices { choices :: NonEmpty Text }+  | OptionalRecordField { name :: Text }+  | InvalidRecordField { name :: Text, mismatches :: [Mismatch] }   | InvalidEnumValue   { given :: Text, options :: NonEmpty Text}   | InvalidConstructor { name :: Text}   | InvalidUnionValue  { contents :: Value}@@ -143,8 +153,12 @@   | PrimValidatorMissing { name :: Text }   | PrimError {name, primError :: Text}   | InvalidChoice{choiceNumber :: Int}-  deriving (Eq, Show)+  | TryFailed { name :: Text }+  | AllAlternativesFailed { mismatches :: [Mismatch]}+  deriving (Eq, Show, Typeable) +instance Exception Mismatch+ type Validators = HashMap Text ValidatePrim type ValidatePrim = Value -> Maybe Text @@ -209,7 +223,9 @@   go _tx (Record    _) Empty     = pure $ const emptyValue   go _tx (StringMap _) Empty     = pure $ const emptyValue   go _tx OneOf{}       Empty     = pure $ const emptyValue-  go _tx (Prim      a) (Prim b ) = guard (a == b) >> pure id+  go ctx (Prim      a) (Prim b ) = do+    unless (a == b) $ failWith ctx (PrimError a b)+    pure id   go ctx (Array a)     (Array b) = do     f <- go ("[]" : ctx) a b     pure $ over (_Array . traverse) f@@ -217,7 +233,10 @@     f <- go ("Map" : ctx) a b     pure $ over (_Object . traverse) f   go _tx a (Array b) | a == b = pure (A.Array . fromList . (: []))-  go _tx (Enum opts) (Enum opts') | all (`elem` opts') opts = pure id+  go 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     ff <- forM opts' $ \(n, sc) -> do       sc' <- maybe (failWith ctx $ InvalidConstructor n) pure $ lookup n (toList opts)@@ -225,14 +244,16 @@       return $ over (_Object . ix n) f     return (foldr (.) id ff)   go ctx (Record opts) (Record opts') = do-    forM_ (Map.toList opts) $ \(n, f@(Field _ _)) ->-      guard $ not (isRequired f) || Map.member n opts'+    forM_ (Map.toList opts) $ \(n, f) ->+      unless (not (isRequired f) || Map.member n opts') $+        failWith ctx $ MissingRecordField n     ff <- forM (Map.toList opts') $ \(n', f'@(Field sc' _)) -> do       case Map.lookup n' opts of         Nothing -> do           pure $ over (_Object) (Map.delete n')         Just f@(Field sc _) -> do-          guard (not (isRequired f) || isRequired f')+          unless (not (isRequired f) || isRequired f') $+            failWith ctx $ OptionalRecordField n'           witness <- go (n' : ctx) sc sc'           pure $ over (_Object . ix n') witness     return (foldr (.) id ff)

@@ -54,10 +54,10 @@     it "subtypes can remove Optional fields" $ do       Record [makeField "def" prim True] `shouldBeSubtypeOf` Record         [makeField "def" prim True, makeField "a" prim (False)]-    it "subtypes can add enum choices" $ do-      Enum ["A", "def"] `shouldBeSubtypeOf` Enum ["def"]-    it "subtypes cannot remove enum choices" $ do-      Enum ["def"] `shouldNotBeSubtypeOf` Enum ["A"]+    it "subtypes can remove enum choices" $ do+      Enum ["def"] `shouldBeSubtypeOf` Enum ["A", "def"]+    it "subtypes cannot add enum choices" $ do+      Enum ["A", "def"] `shouldNotBeSubtypeOf` Enum ["def"]     it "subtypes can remove constructors" $ do       Union [constructor' "B" Empty]         `shouldBeSubtypeOf` Union [constructor' "A" Empty, constructor' "B" Empty]