diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/schemas.cabal b/schemas.cabal --- a/schemas.cabal +++ b/schemas.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: schemas -version: 0.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 diff --git a/src/Schemas/Class.hs b/src/Schemas/Class.hs --- a/src/Schemas/Class.hs +++ b/src/Schemas/Class.hs @@ -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 diff --git a/src/Schemas/Internal.hs b/src/Schemas/Internal.hs --- a/src/Schemas/Internal.hs +++ b/src/Schemas/Internal.hs @@ -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 -> diff --git a/src/Schemas/Untyped.hs b/src/Schemas/Untyped.hs --- a/src/Schemas/Untyped.hs +++ b/src/Schemas/Untyped.hs @@ -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 diff --git a/test/Generators.hs b/test/Generators.hs --- a/test/Generators.hs +++ b/test/Generators.hs @@ -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 diff --git a/test/SchemasSpec.hs b/test/SchemasSpec.hs --- a/test/SchemasSpec.hs +++ b/test/SchemasSpec.hs @@ -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 diff --git a/test/Unions.hs b/test/Unions.hs new file mode 100644 --- /dev/null +++ b/test/Unions.hs @@ -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]