schemas 0.4.0.1 → 0.4.0.2
raw patch · 8 files changed
+186/−42 lines, 8 filesdep +syb
Dependencies added: syb
Files
- CHANGELOG.md +3/−0
- schemas.cabal +4/−2
- src/Schemas/Class.hs +3/−3
- src/Schemas/Internal.hs +5/−13
- src/Schemas/Untyped.hs +9/−6
- test/Generators.hs +7/−2
- test/SchemasSpec.hs +132/−16
- test/Unions.hs +23/−0
CHANGELOG.md view
@@ -1,4 +1,7 @@ # Revision history for schemas+## 0.4.0.2 -- 2020-04-28+* Fix bug in `instance HasSchema Either`+ ## 0.4.0.1 -- 2020-01-01 * Replace breadth-first search with a greedy depth-first search
schemas.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: schemas-version: 0.4.0.1+version: 0.4.0.2 synopsis: schema guided serialization description: Schemas is a Haskell library for serializing and deserializing data in JSON.@@ -78,12 +78,13 @@ type: exitcode-stdio-1.0 hs-source-dirs: example, test main-is: Main.hs- ghc-options: -threaded -with-rtsopts=-M1G + ghc-options: -threaded -with-rtsopts=-M1G other-modules: Person , Person2 , Person3 , Person4 , Looper+ , Unions , SchemasSpec , Schemas.OpenApi2Spec , Schemas.SOPSpec@@ -100,6 +101,7 @@ , pretty-simple , QuickCheck , schemas+ , syb , text , transformers , unordered-containers
src/Schemas/Class.hs view
@@ -33,7 +33,7 @@ schema :: TypedSchema a instance HasSchema () where- schema = TPure ()+ schema = lmap (\() -> undefined) $ pureSchema () instance HasSchema Bool where schema = viaJSON "Boolean"@@ -127,8 +127,8 @@ <*> field "$5" (view _5) instance (HasSchema a, HasSchema b) => HasSchema (Either a b) where- schema = union [("Left", alt _Left), ("Right", alt _Right)- ,("left", alt _Left), ("right", alt _Right)]+ schema = union [("left", alt _Left), ("right", alt _Right)]+ <> union [("Left", alt _Left), ("Right", alt _Right)] instance (Eq key, Hashable key, HasSchema a, Key key) => HasSchema (HashMap key a) where schema = dimap toKeyed fromKeyed $ stringMap schema
src/Schemas/Internal.hs view
@@ -21,7 +21,7 @@ module Schemas.Internal where import Control.Alternative.Free-import Control.Applicative (Alternative (..), optional)+import Control.Applicative (Alternative (..)) import Control.Lens hiding (Empty, allOf, enum, (<.>)) import Control.Monad.Except import Control.Monad.Trans.Iter@@ -79,7 +79,6 @@ -> (Either a' a'' -> a) -> (from -> Either from' from'') -> TypedSchemaFlex from a- TPure :: a -> TypedSchemaFlex from a TEmpty :: (Void -> a) -> (from -> Void) -> TypedSchemaFlex from a TPrim :: Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a RecordSchema ::RecordFields from a -> TypedSchemaFlex from a@@ -92,7 +91,6 @@ instance Profunctor TypedSchemaFlex where dimap g f (TEmpty tof fromf) = TEmpty (f . tof) (fromf . g)- dimap _ f (TPure a) = TPure (f a) dimap g f (TNamed n sc tof fromf) = TNamed n sc (f . tof) (fromf . g) dimap g f (TAllOf scc ) = TAllOf (dimap g f <$> scc) dimap g f (TOneOf sca scb to fr ) = TOneOf sca scb (f . to) (fr . g)@@ -173,9 +171,9 @@ emptySchema :: TypedSchema Void emptySchema = TEmpty id id --- | The schema that can be decoded but not encoded-pureSchema :: a -> TypedSchemaFlex from a-pureSchema = TPure+-- | The schema that can be trivially decoded and encoded+pureSchema :: a -> TypedSchemaFlex a a+pureSchema a = record (pure a) allOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a allOf x = allOf' $ sconcat $ fmap f x where@@ -340,7 +338,6 @@ -- as the number of versions is exponential. extractSchema :: TypedSchemaFlex from a -> NonEmpty Schema -- extractSchema xx | pTraceShow ("extractSchema") False = undefined-extractSchema TPure{} = pure Unit extractSchema (TNamed n sc _ _) = Named n <$> extractSchema sc extractSchema (TPrim n _ _ ) = pure $ Prim n extractSchema (TOneOf s s' _ _) = (<>) <$> extractSchema s <*> extractSchema s'@@ -449,9 +446,7 @@ resDyn = lmap unsafeCoerce <$> res resDynLater = (pure . fromMaybe (error "impossible") . attemptSuccess) resDyn in lmap fromf <$> res- go _ _ _ Empty = pure $ pure . const emptyValue- go _ _tx TPure{} Array{} = pure $ pure . const (A.Array [])- go _ _tx TPure{} StringMap{} = pure $ pure . const (emptyValue)+ go _ _ _ Empty = empty go _ _tx (TEmpty _ _) _ = pure $ const empty go _ ctx (TPrim n _ fromf) (Prim n') | n == n' = pure $ pure . fromf@@ -527,7 +522,6 @@ runSchema sc = runExcept . go sc where go :: forall from a . TypedSchemaFlex from a -> from -> Except [Mismatch] a- go (TPure x) _ = pure x go (TEmpty toF fromF ) x = pure $ toF $ fromF x -- TODO handle circular data go (TNamed _ sc tof fromF) a = tof <$> go sc (fromF a)@@ -552,7 +546,6 @@ -- | Evaluates a schema as a value of type 'dec'. Can only succeed if the schema contains a 'TPure' alternative evalSchema :: forall enc dec . TypedSchemaFlex enc dec -> Maybe dec-evalSchema (TPure x ) = pure x evalSchema TEmpty{} = Nothing -- TODO handle circular data evalSchema (TNamed _ sc tof _) = tof <$> evalSchema sc@@ -591,7 +584,6 @@ -> Schema -> Attempt TracedMismatches (Value -> Result a) -- go _ _ t s | pTraceShow ("decode", t,s) False = undefined- go _nv _tx (TPure a) Unit = pure $ \_ -> pure a go _ ctx TEmpty{} Empty = pure $ const $ failWith ctx EmptySchema go env ctx (TNamed n sc tof _) (Named n' s) | n == n' = case lookup n env of Just sol ->
src/Schemas/Untyped.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}@@ -41,11 +42,13 @@ import Prelude hiding (lookup) import Text.Read import Text.Show.Functions ()+import Data.Data (Data) -- Schemas -- -------------------------------------------------------------------------------- newtype SchemaName = SchemaName String+ deriving stock (Data) deriving newtype (Eq, IsString) instance Show SchemaName where show (SchemaName s) = s@@ -61,10 +64,10 @@ | Enum (NonEmpty Text) | Record (HashMap Text Field) | 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- | Empty- deriving (Eq, Generic)+ | Empty -- ^ The void schema+ deriving (Eq, Data, Generic, Show) instance Monoid Schema where mempty = Empty instance Semigroup Schema where@@ -74,8 +77,8 @@ b <> OneOf aa = OneOf ([b] <> aa) a <> b = OneOf [a,b] -instance Show Schema where- showsPrec = go [] where+showsPrecSchema :: Integer -> Schema -> [Char] -> [Char]+showsPrecSchema = go [] where go _een p Empty = showParen (p>0) $ ("Empty " ++) go seen _ (Array sc) = (('[' :) . go seen 5 sc . (']' :)) go seen p (StringMap sc) = showParen (p > 5) (("Map " ++) . go seen 5 sc)@@ -115,7 +118,7 @@ { fieldSchema :: Schema , isRequired :: Bool -- ^ defaults to True }- deriving (Eq, Generic)+ deriving (Data, Eq, Generic) instance Show Field where showsPrec p (Field sc True) = showsPrec p sc
test/Generators.hs view
@@ -26,11 +26,16 @@ instance Arbitrary Schema where arbitrary = sized genSchema+ shrink (Record [(_, Field sc True)]) = [sc] shrink (Record fields) =- [Record [(n,Field sc' req)] | (n,Field sc req) <- toList fields, sc' <- shrink sc]- shrink (OneOf scc) = [OneOf [sc'] | sc <- toList scc, sc' <- shrink sc]+ [ Record [(n,Field sc' req)]+ | (n,Field sc req) <- toList fields, sc' <- shrink sc]+ shrink (OneOf [sc]) = [sc]+ shrink (OneOf scc) = concat+ [[OneOf [sc'], sc'] | sc <- toList scc, sc' <- shrink sc] shrink (Array sc) = [sc] shrink (StringMap sc) = [sc]+ shrink (Enum xx) = Enum . pure <$> toList xx shrink _ = [] newtype SmallNatural = SmallNatural Natural
test/SchemasSpec.hs view
@@ -18,9 +18,9 @@ import Data.Either import Data.Foldable import Data.Functor.Identity+import Data.Generics import qualified Data.List.NonEmpty as NE import Data.Maybe-import Data.Void import Generators import Looper import Person@@ -33,10 +33,10 @@ import Schemas.Untyped (Validators) import System.Timeout import Test.Hspec-import Test.Hspec.QuickCheck (prop) import Test.Hspec.Runner (configQuickCheckMaxSuccess, hspecWith, defaultConfig)-import Test.QuickCheck (sized, forAll, suchThat)+import Test.QuickCheck (arbitrary, sized, forAll, suchThat) import Text.Show.Functions ()+import Unions main :: IO () main = hspecWith defaultConfig{configQuickCheckMaxSuccess = Just 10000} spec@@ -51,9 +51,8 @@ ) ] -spec :: Spec-spec = do- describe "encode" $ do+encodeSpec :: Spec+encodeSpec = do it "prims" $ do let encoder = encode shouldNotDiverge $ evaluate encoder@@ -63,29 +62,121 @@ shouldNotDiverge $ evaluate encoder shouldNotDiverge $ evaluate $ encoder (Left ()) shouldNotDiverge $ evaluate $ encoder (Right ())+ it "recursive schemas" $ do- let encoder = (encodeWith listSchema)+ let encoder = encodeWith listSchema shouldNotDiverge $ evaluate encoder shouldNotDiverge $ evaluate $ encoder [()]- prop "is the inverse of decoding" $ \(sc :: Schema) ->- getSuccess (pure encode >>= decode . ($ sc)) == Just sc- describe "encodeTo" $ do++ it "is the inverse of decoding for canonical schemas" $+ forAll (canonical <$> arbitrary) $ \sc ->+ getSuccess (pure encode >>= decode . ($ sc)) == Just sc++canonical :: Schema -> Schema+canonical = everywhere (mkT simplify)+ where+ simplify (OneOf [x]) = x+ simplify other = other++encodeToSpec :: Spec+encodeToSpec = do it "is lazy" $ do evaluate (attemptSuccessOrError (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [makeField "bottom" prim True])) (Nothing :: Maybe Bool)) `shouldThrow` \(_ :: SomeException) -> True- let encoded = attemptSuccessOrError (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [])) (Nothing :: Maybe Bool)+ let encoded =+ attemptSuccessOrError+ (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record []))+ (Nothing :: Maybe Bool) encoded `shouldBe` A.Object []++ it "SomeNone Some" $ do+ let encoded = encodeWith schemaSomeNone (Some ())+ shouldNotDiverge $ evaluate encoded+ encoded `shouldBe` A.Object []++ it "NoneSome Some" $ do+ let encoded = encodeWith schemaNoneSome (Some ())+ shouldNotDiverge $ evaluate encoded+ encoded `shouldBe` A.Object []++ it "SomeNone None" $ do+ let encoded = encodeWith schemaSomeNone (None @(Either () ()))+ shouldNotDiverge $ evaluate encoded+ encoded `shouldBe` A.Object []++ it "NoneSome None" $ do+ let encoded = encodeWith schemaNoneSome (None @(Either () ()))+ shouldNotDiverge $ evaluate encoded+ encoded `shouldBe` A.Object []++ it "Three" $ do+ let encoded = encodeWith (schemaThree schemaNoneSome schema) (Three @(Some ()) @())+ shouldNotDiverge $ evaluate encoded+ encoded `shouldBe` A.Object []++ it "Three" $ do+ let encoded = encodeWith (schemaThree' schema schemaNoneSome) (Three @() @(Some ()))+ shouldNotDiverge $ evaluate encoded+ encoded `shouldBe` A.Object []++ describe "Either" $ do+ let -- A schema supporting both camelCase and lowercase either+ source :: TypedSchema (Either () ())+ source = schema++ it "lowerCase" $ do+ let target = Union [("right", schemaFor @()), ("left", schemaFor @())]+ encoder = encodeToWith source target+ Right f = encoder+ encoder `shouldSatisfy` isRight+ f (Right ()) `shouldBe` A.object [("right", A.Object [])]++ it "camelCase" $ do+ let target = Union [("Right", schemaFor @()), ("Left", schemaFor @())]+ encoder = encodeToWith source target+ Right f = encoder+ f (Right ()) `shouldBe` A.object [("Right", A.Object [])]++ describe "Either (nested)" $ do+ let -- A schema supporting both camelCase and lowercase either+ source :: TypedSchema (((), Either () ()))+ source = schema++ wrap sc = Record [("$1", Field (schemaFor @()) True), ("$2", Field sc True)]++ wrapVal v = A.object [("$1", A.Object []), ("$2", v)]++ it "lowerCase" $ do+ let target = wrap $ Union [("right", schemaFor @()), ("left", schemaFor @())]+ encoder = encodeToWith source target+ Right f = encoder+ encoder `shouldSatisfy` isRight+ f ((),Right ()) `shouldBe` wrapVal (A.object [("right", A.Object [])])++ it "camelCase" $ do+ let target = wrap $ Union [("Right", schemaFor @()), ("Left", schemaFor @())]+ encoder = encodeToWith source target+ Right f = encoder+ encoder `shouldSatisfy` isRight+ f ((),Right ()) `shouldBe` wrapVal (A.object [("Right", A.Object [])])++ describe "canEncode" $ do++ it "Unions of 1 constructor" $ do+ union [("Just", alt (_Just @()))] `shouldBeAbleToEncodeTo` [Union [("Just", Unit)]]+++spec :: Spec+spec = do+ describe "encode" encodeSpec+ describe "encodeTo" encodeToSpec describe "extractSchema" $ do it "Named" $ shouldNotDiverge $ evaluate $ extractSchema $ schema @Schema it "Unions" $ extractSchema (union [("Just", alt (_Just @())), ("Nothing", alt _Nothing)]) `shouldBe` [Union [("Nothing", Unit) ,("Just", Unit)]]- describe "canEncode" $ do- it "Empty to itself" $ do- mempty @(TypedSchema Void) `shouldBeAbleToEncodeTo` [Empty]- it "Unions of 1 constructor" $ do- union [("Just", alt (_Just @()))] `shouldBeAbleToEncodeTo` [Union [("Just", Unit)]]+ describe "isSubtypeOf" $ do it "is reflexive (in absence of OneOf)" $ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc -> sc `shouldBeSubtypeOf` sc@@ -126,6 +217,7 @@ prim `shouldBeSubtypeOf` Array prim it "subtypes cannot introduce an array" $ do Array prim `shouldNotBeSubtypeOf` prim+ describe "HasSchema" $ do it "Left is a constructor of Either" $ do shouldBeAbleToDecode @(Either () ()) [Union [constructor' "Left" Unit]]@@ -133,6 +225,7 @@ it "left is a constructor of Either too" $ do shouldBeAbleToDecode @(Either () ()) [Union [constructor' "left" Unit]] -- shouldBeAbleToEncode @(Either () ()) [Union [constructor' "left" Unit]]+ describe "examples" $ do describe "Schema" $ schemaSpec schema (schemaFor @Person2)@@ -147,8 +240,28 @@ encoder_p3v0 = encodeTo @Person3 person3_v0 decoder_p2v0 = decodeFrom @Person4 person2_v0 decoder_p2v2 = decodeFrom person2_v2++ describe "NoneSome Bool" $+ schemaSpec schemaNoneSome (None :: Some Bool)++ describe "SomeNone Bool" $+ schemaSpec schemaSomeNone (None :: Some Bool)++ describe "NoneSome (Either () ())" $+ schemaSpec schemaNoneSome (None :: Some (Either () ()))++ describe "SomeNone (Either () ())" $+ schemaSpec schemaSomeNone (None :: Some (Either () ()))++ describe "Three Bool Int" $+ schemaSpec (schemaThree schema schema) (Three :: Three Bool Int)++ describe "Three Int Bool" $+ schemaSpec (schemaThree' schema schema) (Three :: Three Int Bool)+ describe "Person" $ do schemaSpec schema pepe+ describe "Person2" $ do schemaSpec schema pepe2 it "Person2 < Person" $ do@@ -167,6 +280,7 @@ it "Person < Person2" $ do -- shouldBeAbleToEncode @Person (extractSchema @Person2 schema) shouldBeAbleToDecode @Person2 (extractSchema @Person schema)+ describe "Person3" $ do -- disabled because encode diverges and does not support IterT yet -- schemaSpec schema pepe3@@ -178,6 +292,7 @@ shouldNotDiverge $ evaluate $ encode martin shouldNotDiverge $ evaluate $ attemptSuccessOrError encoder_p3v0 martin+ describe "Person4" $ do schemaSpec schema pepe4 let encoded_pepe4 = attemptSuccessOrError encoder_p4v0 pepe4@@ -307,6 +422,7 @@ isFailure :: Result a -> Bool isFailure = not . isSuccess +-- | Parallel 'asum' for 'Either' asumEither :: forall e a . (Monoid e) => NE.NonEmpty (Either e a) -> Either e a asumEither = Data.Coerce.coerce asumExcept where
+ test/Unions.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+module Unions where++import Data.Generics.Labels ()+import Schemas+import GHC.Generics (Generic)++data Some a = Some a | None+ deriving (Eq, Generic, Show)++schemaSomeNone, schemaNoneSome :: HasSchema a => TypedSchema (Some a)+schemaSomeNone = oneOf [alt #_Some, alt #_None]+schemaNoneSome = oneOf [alt #_None, alt #_Some]+++data Three a b = One a | Two b | Three+ deriving (Eq, Generic, Show)++schemaThree, schemaThree' :: TypedSchema a -> TypedSchema b -> TypedSchema (Three a b)+schemaThree a b = oneOf [altWith a #_One, altWith b #_Two, alt #_Three]+schemaThree' a b = oneOf [alt #_Three, altWith a #_One, altWith b #_Two]