schemas 0.2.0.3 → 0.3.0

raw patch · 13 files changed

+734/−490 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +2/−2
• example/Person3.hs +5/−4
• example/Person4.hs +128/−0
• schemas.cabal +4/−1
• src/Schemas.hs +4/−6
• src/Schemas/Class.hs +18/−16
• src/Schemas/Internal.hs +359/−257
• src/Schemas/OpenApi2.hs +2/−2
• src/Schemas/Untyped.hs +70/−111
• test/Generators.hs +10/−19
• test/Schemas/OpenApi2Spec.hs +3/−3
• test/SchemasSpec.hs +122/−69

@@ -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 

@@ -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.

@@ -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                 }

@@ -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

@@ -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

@@ -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

@@ -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'

@@ -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

@@ -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)" 

@@ -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)

@@ -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)

@@ -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"]

@@ -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"]